[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『直線オートシェイプ２つを選択している状態かを調べる』（げん）
こんにちは。お世話になります。
直線オートシェイプ２つを使ってCADソフトのような丸面取りを作りたいと思い悪戦苦闘しています。
・直線二つを交点まで延ばす
・直線二つを互いに内側となる側に丸の半径分オフセットした交点を出して面取り円の中心点とする
など構想を練っていますがまだ道半ばです。
目下質問の内容は「直線オートシェイプ２つを選択している状態か」の判定をスマートにできないか、です。
（理想はマクロを動かしてから直線を二つ選択することですがまったくできていません。）
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行２行で書く方法はないと思いますよ。 （γ） 2022/11/15(火) 16:07:17
CADでは出来ているのだから出来るのでしょうが、
この後の操作の面取りとなると私には皆目見当がつきません。
該当シートモジュールに記載
Sub test()
Dim line1 As Shape, line2 As Shape
Set line1 = ライン選択("直線１") '一つ目の線
If line1 Is Nothing Then Exit Sub 'キャンセルで終了
Do
Set line2 = ライン選択("直線２") '二つ目の線
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が１つ選択されると抜ける
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
'直線オートシェイプ２つを選択
shp = Select2Lines
'２つの直線を比較し縦線と横線にする
'線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("直線１") '一つ目の線
If line(0) Is Nothing Then Exit Function 'キャンセルで終了
Do
Set line(1) = SelectShape("直線２") '二つ目の線
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が１つ選択されると抜ける
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.