[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『直線オートシェイプ2つを選択している状態かを調べる』(げん)
こんにちは。お世話になります。
直線オートシェイプ2つを使ってCADソフトのような丸面取りを作りたいと思い悪戦苦闘しています。
・直線二つを交点まで延ばす
・直線二つを互いに内側となる側に丸の半径分オフセットした交点を出して面取り円の中心点とする
など構想を練っていますがまだ道半ばです。
目下質問の内容は「直線オートシェイプ2つを選択している状態か」の判定をスマートにできないか、です。
(理想はマクロを動かしてから直線を二つ選択することですがまったくできていません。)
VarType(Selection)が9でTypeName(Selection)が"DrawingObjects"で
SelectionのうちLineが・・・など拙いものになっています。
ShapeRangeやShapeへの理解が乏しいのでそのあたりもご指導願えるとありがたいです。
以下は現在作成中のコードです。
どうぞよろしくお願いします。
Dim shp(1) As Object Dim s As Object Dim c As Long If VarType(Selection) <> 9 Or TypeName(Selection) <> "DrawingObjects" Then Exit Sub For Each s In Selection If TypeName(s) = "Line" Then Set shp(c) = s c = c + 1 If c > 1 Then Exit For End If Next
< 使用 Excel:Excel2019、使用 OS:Windows10 >
さしあたって判定に必要になるのは、以下の二つのプロパティかと思います。 Sub test() Dim shp For Each shp In Selection Debug.Print shp.ShapeRange.Type Debug.Print shp.ShapeRange.AutoShapeType Next End Sub なお、Selectionのチェックは省略しています。 完成品ではなく、ヒント(のつもり)です。 (γ) 2022/11/15(火) 15:52:26
直線の判定だけでしたら、現行のコードでよろしいのではないですか? 1行2行で書く方法はないと思いますよ。 (γ) 2022/11/15(火) 16:07:17
CADでは出来ているのだから出来るのでしょうが、
この後の操作の面取りとなると私には皆目見当がつきません。
該当シートモジュールに記載
Sub test() Dim line1 As Shape, line2 As Shape
Set line1 = ライン選択("直線1") '一つ目の線 If line1 Is Nothing Then Exit Sub 'キャンセルで終了 Do Set line2 = ライン選択("直線2") '二つ目の線 If line2 Is Nothing Then Exit Sub 'キャンセルで終了 Loop Until Not line1 Is line2 '二つが異なるまで繰り返し line1.Select line2.Select False '二つを選択状態にする(見た目用) End Sub
Private Function ライン選択(s As String) As Shape Dim sp As Line ' Dim sp As Drawing '曲線で書いた直線を使用する場合 Dim r As Range Set r = Range("E1") '操作ナビ r.Value = s & "を選んで下さい" r.Font.Size = 24 r.Select
Application.CommandBars.ExecuteMso "ObjectsSelect" 'オブジェクトの選択 On Error Resume Next Do Until Not Application.CommandBars.GetPressedMso("ObjectsSelect") 'ESCで解除 Set sp = Selection If Not sp Is Nothing Then 'spが1つ選択されると抜ける Exit Do End If DoEvents: DoEvents Loop
If Not sp Is Nothing Then Set ライン選択 = sp.ShapeRange(1) Application.CommandBars.ExecuteMso "ObjectsSelect" 'オブジェクトの選択解除 End If r.Value = "" End Function
(kazuo) 2022/11/15(火) 19:34:37
という機能だけを実現させました。
kazuoさんが考えてくださったコードについては
操作ナビをステータスバーに表示させる形に変更しましたが
ほぼそのまま取り入れさせてもらいました。
まだ自由な角度の線の接続や面取りは今後の課題です。
現状のコードは以下のとおりです。
Sub Test() ' Const RADIUS As Double = 10 Dim shp() As Shape Dim i As Long Dim iRad(1) As Double
'直線オートシェイプ2つを選択 shp = Select2Lines
'2つの直線を比較し縦線と横線にする '線Aと線BのWeight/Height比を比べる For i = 0 To 1 With shp(i) If .Width = 0 Then iRad(i) = 90 '幅0の場合は90°とみなす Else iRad(i) = Atn(.Height / .Width) * 45 / Atn(1) '幅0以外は高さ÷幅で角度を算出 End If End With Next If iRad(0) = iRad(1) Then Exit Sub 'どちらの角度も同じの場合は処理を中止
'線の色と太さを先に選択した方に合わせる With shp(1).line With .ForeColor .RGB = shp(0).line.ForeColor.RGB .TintAndShade = shp(0).line.ForeColor.TintAndShade .Brightness = shp(0).line.ForeColor.Brightness End With .Transparency = shp(0).line.Transparency .DashStyle = shp(0).line.DashStyle .Style = shp(0).line.Style .Weight = shp(0).line.Weight .BeginArrowheadStyle = shp(0).line.BeginArrowheadStyle .BeginArrowheadLength = shp(0).line.BeginArrowheadLength .BeginArrowheadWidth = shp(0).line.BeginArrowheadWidth .EndArrowheadStyle = shp(0).line.EndArrowheadStyle .EndArrowheadLength = shp(0).line.EndArrowheadLength .EndArrowheadWidth = shp(0).line.EndArrowheadWidth End With
'角度の大きい方を縦線(Weight=0)、小さい方を横線(Height=0)にする If iRad(0) < iRad(1) Then '後に選択した方の角度が大きい場合はShp(0)とShp(1)を入れ替える Dim tmp As Shape Set tmp = shp(0) Set shp(0) = shp(1) Set shp(1) = tmp End If
shp(0).Width = 0 'Shp(0)の幅を0にする(縦線化) shp(1).Height = 0 'Shp(1)の高さを0にする(横線化)
'横線のTop値(1)と縦線のTop値(2)、Top+Height値(3)を比較する Dim buf1 As Double, buf2 As Double, buf3 As Double With shp(0) buf1 = shp(1).Top buf2 = .Top buf3 = buf2 + .Height Select Case True Case buf3 <= buf1 '1.((2)<)(3)<=(1) →横線が下にある→縦線の下側を延ばす(角丸の中心は横線の上) .Height = buf1 - buf2 Case buf1 <= buf2 '2.(1)<=(2)(<(3)) →横線が上にある→縦線の上側を延ばす(角丸の中心は横線の下) .Height = buf3 - buf1 .Top = buf1 Case buf1 - buf2 >= buf3 - buf1 '3.(2)<(1)<(3) →横線が縦線の間にある ' 3-1.(1)-(2)>=(3)-(1) →下寄り →縦線の下側を縮める(角丸の中心は横線の上) .Height = buf1 - buf2 Case Else ' 3-2.(1)-(2)<(3)-(1) →上寄り →縦線の上側を縮める(角丸の中心は横線の下) .Height = buf3 - buf1 .Top = buf1 End Select End With With shp(1) '縦線のLeft値(1)と横線のLeft値(2)、Left+Width値(3)を比較する buf1 = shp(0).Left buf2 = .Left buf3 = buf2 + .Width Select Case True Case buf3 <= buf1 '1.((2)<)(3)<=(1) →縦線が右にある→横線の右側を延ばす(角丸の中心は縦線の左) .Width = buf1 - buf2 Case buf1 <= buf2 '2.(1)<=(2)(<(3)) →縦線が左にある→横線の左側を延ばす(角丸の中心は縦線の右) .Width = buf3 - buf1 .Left = buf1 Case buf1 - buf2 >= buf3 - buf1 '3.(2)<(1)<(3) →縦線が横線の間にある ' 3-1.(1)-(2)>=(3)-(1) →右寄り →横線の右側を縮める(角丸の中心は縦線の左) .Width = buf1 - buf2 Case Else ' 3-2.(1)-(2)<(3)-(1) →左寄り →横線の左側を縮める(角丸の中心は縦線の右) .Width = buf3 - buf1 .Left = buf1 End Select End With
End Sub
Private Function Select2Lines() As Shape() Dim line(1) As Shape Set line(0) = SelectShape("直線1") '一つ目の線 If line(0) Is Nothing Then Exit Function 'キャンセルで終了 Do Set line(1) = SelectShape("直線2") '二つ目の線 If line(1) Is Nothing Then Exit Function 'キャンセルで終了 Loop Until Not line(0) Is line(1) '二つが異なるまで繰り返し 'line1.Select 'line2.Select False '二つを選択状態にする(見た目用) Select2Lines = line End Function Private Function SelectShape(msg As String) As Shape Dim sp As line ' Dim sp As Drawing '曲線で書いた直線を使用する場合 Application.StatusBar = msg & "を選んで下さい" '操作ナビ Application.CommandBars.ExecuteMso "ObjectsSelect" 'オブジェクトの選択 On Error Resume Next Do Until Not Application.CommandBars.GetPressedMso("ObjectsSelect") 'ESCで解除 Set sp = Selection If Not sp Is Nothing Then 'spが1つ選択されると抜ける Exit Do End If DoEvents: DoEvents Loop If Not sp Is Nothing Then Set SelectShape = sp.ShapeRange(1) sp.TopLeftCell.Select Application.CommandBars.ExecuteMso "ObjectsSelect" 'オブジェクトの選択解除 End If Application.StatusBar = False End Function
(げん) 2022/11/24(木) 15:59:21
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.