[[20221115152920]] 『直線オートシェイプ2つを選択している状態かを調』(げん) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) |

| 全文検索 | 過去ログ ]

 

『直線オートシェイプ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

γさんヒントありがとうございます。
教えてもらったプロパティをオブジェクトブラウザで見るだけでも目がチカチカしています。
少しずつでも身につけていきたいと思います。
(げん) 2022/11/15(火) 17:35:03

興味が湧いたので、直線を二つ選択することを書いてみました。
マクロを動かすと、マウスカーソルがオブジェクトの選択用に替わりますので、
ナビ(E1セル)に従い、1つずつ選択してください。
選択が終わると、2つが選択された状態になります。
ESCキーで中止します。

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さん興味をもってくださりありがとうございます。
あれから試行錯誤し、
・ふたつの直線オートシェイプを90°のものと0°のものにする
・両端を接続する

という機能だけを実現させました。
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.