今回は、図形の回転及び移動やコピ―を同時に行うことを検討しました。

　特に、角度を他のラインから参照して回転コピーする場合は手間を簡素化できます。

Excelsheetからコントロールするようにしています。

基本設定

1-1，ExcelVBEでの設定

　新たなWorkBookで作成する場合は、BricsCADのタイプライブラリを使えるように、ExcelのVBE画面で参照設定を行います。

　初期設定は、BricsCAD VBAを使ってみよう[7]　Excelとの連携②　をご参照ください。

1-2，Excelの設定

Excelシートは以下の内容です。

①ComboBox1(ActivXｺﾝﾄﾛｰﾙ)
②③④ボタン(ﾌｫｰﾑｺﾝﾄﾛｰﾙ)
⑤OptionButton1
⑥OptionButton2
⑦OptionButton3

ComboBox1へ画層一覧をセットする

Excelのbookを開いた時に、自動実行させるコードの記述個所は、
ThisWorkbookを選択し、GeneralをWorkbookに変えます。

すると、自動的にWorkbook_Open()のsubﾌﾟﾛｼｰｼﾞｬが作成されますので、その中にbookを開いた時に、自動実行させるコードを記述します。

Option Explicit

Private Sub Workbook_Open()

''BricsCADのオブジェクト変数を宣言
Dim BcadApp As BricscadApp.AcadApplication
Dim BcadDoc As BricscadApp.AcadDocument

''現在開いているBricsCADを取得
On Error Resume Next
Set BcadApp = GetObject(, "BricscadApp.AcadApplication")
''現在開いているBricsCADを取得
If Err.Number <> 0 Then
    MsgBox "BricsCADが開かれていません" & vbCr & vbCr & "Excelを終了します"
    Application.Quit
    Err.Clear
    On Error GoTo 0
    Exit Sub
End If

BcadApp.Visible = True
Set BcadDoc = BcadApp.ActiveDocument

On Error Resume Next

''=====【画層一覧の取得】=====
Dim ComboBox1 As MSForms.ComboBox
Set ComboBox1 = ActiveSheet.ComboBox1
ComboBox1.Clear
''全画層名をComboBoxLayに格納
Dim layerNames As String
Dim LayObj As AcadLayer
    For Each LayObj In BcadDoc.Layers
        ComboBox1.AddItem LayObj.Name
    Next
''現在の画層名をｺﾝﾎﾞﾎﾞｯｸｽに標示
    ComboBox1.Value = BcadDoc.ActiveLayer.Name

''=====【ブロック一覧の取得】=====
Dim ComboBox2 As MSForms.ComboBox
Set ComboBox2 = ActiveSheet.ComboBox2
ComboBox2.Clear

Dim Blkobj As AcadBlock

For Each Blkobj In BcadDoc.Blocks
    If InStr(Blkobj.Name, "*") < 1 Then
        ComboBox2.AddItem Blkobj.Name
    End If
Next

Set BcadDoc = Nothing
Set BcadApp = Nothing

End Subこ

　コード中に、【ブロック一覧の取得】でComboBox2にセットする箇所が選りますが、これは同一ブックにブロック挿入のシートも作成している為で、ここでは関係ありませんので削除してもらって結構です。

作図用のメインプロシージャ

作図用のVBAコードは、標準モジュールを作成しその中に記述します。

②ボタンの角度取得用のコード

Option Explicit

''Win32API宣言(64bit)Sleep関数
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
''クラス名またはキャプションタイトルからウィンドウハンドルを取得
Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
    (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
''フォアグラウンドウィンドウのハンドルを取得。
Declare PtrSafe Function GetForegroundWindow Lib "user32" () As Long
''指定されたウィンドウのハンドルからキャプションタイトルを取得。
Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
''指定されたウィンドウをZオーダーのトップ位置に移動。
Declare PtrSafe Function SetForegroundWindow Lib "user32" (ByVal hwnd As LongPtr) As Long


Sub Get2PointsAngle()

''NUMLOCK用
Dim WshShell
Set WshShell = CreateObject("WScript.Shell")


''【BricsCADのオブジェクト変数を宣言】
Dim BcadApp As BricscadApp.AcadApplication
Dim BcadDoc As BricscadApp.AcadDocument
''現在開いているBricsCADを取得する
Set BcadApp = GetObject(, "BricscadApp.AcadApplication")
BcadApp.Visible = True
Set BcadDoc = BcadApp.ActiveDocument

'' BricsCADのキャプションを取得
Dim BcadCaption As String
BcadCaption = BcadDoc.Application.Caption
'' Excelのキャプションを取得
Dim xlApp As String
xlApp = Excel.Application.Caption
'' Excelのハンドルを取得
Dim XLhWnd As Long
XLhWnd = FindWindow(vbNullString, xlApp)

    
Dim P1() As Double, P2() As Double
On Error Resume Next

'' BricsCADの画面をアクティブ
AppActivate BcadCaption

        P1 = BcadDoc.Utility.GetPoint(, "1点目をクリック : ESCで終了 ")
        'ｷｬﾝｾﾙの場合
            If Err Then
                On Error GoTo 0
                Exit Sub
         End If
        P2 = BcadDoc.Utility.GetPoint(, "2点目をクリック: ")

Dim Deg As Double, Ang As Double, PI As Double

''水平の場合
If P1(1) = P2(1) Then
    If P1(0) < P2(0) Then
        Ang = 0
    ElseIf P1(0) > P2(0) Then
        Ang = 180
    End If
''垂直の場合
ElseIf P1(0) = P2(0) Then
    If P1(1) < P2(1) Then
        Ang = 90
    ElseIf P1(1) > P2(1) Then
        Ang = 270
    End If
''垂直の場合
Else
''斜めの場合
    PI = WorksheetFunction.PI()
    Deg = Atn((P2(1) - P1(1)) / (P2(0) - P1(0)))
    Ang = Deg * 180 / PI
    If P1(0) < P2(0) Then
        Ang = Ang
           If P1(1) > P2(1) Then Ang = Ang + 360
    ElseIf P1(0) > P2(0) Then
        Ang = Ang + 180
    End If
End If


''Excelへ計測角度を記入する
Cells(3, 4).Select
        Cells(4, 3).Value = Ang


''Excelの画面をアクティブ
        Call BcadActive(WshShell, XLhWnd, xlApp)

Set WshShell = Nothing
Set BcadDoc = Nothing
Set BcadApp = Nothing

End Sub

Sub DataClear_1()

    ''取得データーをクリア
    Dim LastDataRow As Long
    LastDataRow = Cells(Rows.Count, 1).End(xlUp).Row
    ActiveSheet.Range(Rows(7), Rows(LastDataRow)).ClearContents
    Cells(5, 2).Value = 1
    Range("B5").Activate
    
End Sub

Public Function BcadActive(WshShell, XLhWnd As Long, xlApp As String) As Boolean
''フォアグランドのタイトル
    Dim FGtitle As String
''現在フォアグラウンドになっているウィンドウハンドルを取得
    Dim FGHwnd As Long
    FGHwnd = GetForegroundWindow
''フォアグラウンドのタイトルバーテキストを格納
    FGtitle = String(100, Chr(0))
    GetWindowText FGHwnd, FGtitle, Len(FGtitle)
    ''フォアグランドタイトルがBricsCADの場合
    If FGtitle <> xlApp Then
        ''フォアグランドタイトルをExcelにする
        SetForegroundWindow (XLhWnd)
        ''「ALT+TAB」キーストロークを送りExcelを最前面にする
        Application.SendKeys "%{tab}", True
        ''NUMLOCK
        WshShell.SendKeys "{NUMLOCK}"
        Else
            AppActivate xlApp
        End If
End Function

 

③ボタンの回転用のコード

Sub Rotation()

''NUMLOCK用
Dim WshShell
Set WshShell = CreateObject("WScript.Shell")
''【BricsCADのオブジェクト変数を宣言】
Dim BcadApp As BricscadApp.AcadApplication
Dim BcadDoc As BricscadApp.AcadDocument
''現在開いているBricsCADを取得する
Set BcadApp = GetObject(, "BricscadApp.AcadApplication")
BcadApp.Visible = True
Set BcadDoc = BcadApp.ActiveDocument
'' BricsCADのキャプションを取得
Dim BcadCaption As String
BcadCaption = BcadDoc.Application.Caption
'' Excelのキャプションを取得
Dim xlApp As String
xlApp = Excel.Application.Caption
'' Excelのハンドルを取得
Dim XLhWnd As Long
XLhWnd = FindWindow(vbNullString, xlApp)

''現在の画層名を取得
Dim CurLyr As String
CurLyr = BcadDoc.ActiveLayer.Name
''作図用画層名を取得
Dim SelLyr As String
SelLyr = ActiveSheet.ComboBox1.Value

''回転角度を取得
Dim Ang As Double
Ang = Cells(4, 2).Value

''オプションボタンを取得
Dim Btn1 As Boolean, Btn2 As Boolean, Btn3 As Boolean
Btn1 = ActiveSheet.OptionButton1.Value
Btn2 = ActiveSheet.OptionButton2.Value
Btn3 = ActiveSheet.OptionButton3.Value

''■■作図実行■■

'' BricsCADの画面をアクティブ
AppActivate BcadCaption

On Error Resume Next

'' UNDO開始
BcadDoc.SendCommand "undo" & vbCr & "BE" & vbCr

Dim Getpt() As Double
Getpt = BcadDoc.Utility.GetPoint(, "回転基点をクリック")
''ｷｬﾝｾﾙの場合
        If Err.Number <> 0 Then
            Err.Clear
            On Error GoTo 0
            GoTo Errline
        End If

If Btn2 = True Or Btn3 = True Then
    Dim Retpt() As Double
    Dim Ret As String
        If Btn2 = True Then
            Ret = "移動先をクリック"
        ElseIf Btn3 = True Then
            Ret = "コピー先をクリック"
        End If
    Retpt = BcadDoc.Utility.GetPoint(, Ret)
End If

Sleep 300

Dim objSelSet As AcadSelectionSet
''同じ選択ｾｯﾄが有れば削除Btn1.Value = True Then
    BcadDoc.SelectionSets("selobj").Delete

''選択セットを作成
Set objSelSet = BcadDoc.SelectionSets.Add("selobj")
'エラートラップ
        If Err Then
            Set objSelSet = BcadDoc.SelectionSets.Item("selobj")
            Err.Clear
            objSelSet.Clear
        End If
''図形を選択セットに格納
objSelSet.SelectOnScreen

' 図形が選択されなかった時は終了
If objSelSet.Count = 0 Then
 ' 選択セット(selobj)を削除する。
    BcadDoc.SelectionSets("selobj").Delete
    GoTo Errline
    Exit Sub
End If

''πの設定
Dim PI As Double
PI = WorksheetFunction.PI()

''選択セットの図形を回転する
Dim objEntity As AcadEntity
For Each objEntity In objSelSet
    ''コピーの場合は元の図形をコピーして残す
    If Btn3 = True Then objEntity.Copy
    objEntity.Rotate Getpt, 0
    objEntity.Rotate Getpt, Ang * PI / 180
    ''移動もしくはコピーの場合
    If Btn2 = True Or Btn3 = True Then
        objEntity.Move Getpt, Retpt
    End If
    '' 画層変更
    If SelLyr <> CurLyr Then
    objEntity.Layer = SelLyr
    objEntity.Update
    End If
Next

' 図面内のオブジェクトを更新する。
BcadDoc.Application.Update
' 選択セットを削除する。
BcadDoc.SelectionSets("selobj").Delete

''図面を更新
BcadDoc.Application.Update

'' UNDO終了
BcadDoc.SendCommand "undo" & vbCr & "E" & vbCr

Sleep 300

Errline:
''Excelの画面をアクティブ
Call BcadActive(WshShell, XLhWnd, xlApp)

Set objSelSet = Nothing
Set WshShell = Nothing
Set BcadDoc = Nothing
Set BcadApp = Nothing

End Sub

 

④ボタンのUNDO用のコード

Sub UNDO()

Dim BcadApp As BricscadApp.AcadApplication
Dim BcadDoc As BricscadApp.AcadDocument
Set BcadApp = GetObject(, "BricscadApp.AcadApplication")
Set BcadDoc = BcadApp.ActiveDocument
Dim BcadCaption As String
BcadCaption = BcadDoc.Application.Caption
AppActivate BcadCaption
BcadDoc.SendCommand "undo" & vbCr & vbCr

Set BcadDoc = Nothing
Set BcadApp = Nothing

End Sub

 

作図操作

OptionButtonの「Non」は、移動やコピーを行わない意味です。

excelシートオープン時では画層は現在の画層が表示されています。

処理後の図形の画層を変更したい場合は、コンボボックスを変更画層名に切り替えておきます。

「回転」ボタン→回転の基点をクリック→回転したい複数図形を選択
（単一図形では、その図形を直接選択できます)

ここでは、回転した図形が画層２に変更されています。

移動やコピーの場合は、移動先をクリックしてから図形選択です。

角度を参照して回転させる

角度の取得は、2点クリックで取得します。

初めに回転の中心側をクリックして、遠い側をクリックし～360°の角度を取得します。

角度は、水平レベルより左回転で得られます。

その為、水平方向の図形は、（前述の水平方向の矢印の場合の様に）得られた角度そのままで回転すればいいのですが、垂直な図形では、回転角度を逆算する必要があります。

例えば、垂直な方位マークを回転するために参照したラインの角度が52°の場合は、

回転角度は90°ー52°＝38°で、右回りに38°なので、-38と入力してください。

この方位マークはブロックではなく、全て線分なので、回転動作時は細かく線ごとに順番に回転していくので見ていて面白いです。

次回は、同様の操作でブロック挿入の予定です。

 

BricsCAD VBAを使ってみよう　INDEX

BricsCAD VBAを使ってみよう[1]　VBAのｲﾝｽﾄｰﾙ

BricsCAD VBAを使ってみよう[2]　UserFormその１
「BricsCAD VBA 」Creating UserForm

BricsCAD VBAを使ってみよう[3]　UserFormその２
「BricsCAD VBA 」SerialNumber drawing with UserForm

BricsCAD VBAを使ってみよう[4]　VBAの基本コード①

BricsCAD VBAを使ってみよう[5]　VBAの基本コード②

BricsCAD VBAを使ってみよう[6]　Excelとの連携①
「BricsCAD VBA to Excel」Get_CoordinateValues

BricsCAD VBAを使ってみよう[7]　Excelとの連携②　
「Excel VBA to BricsCAD」Get_Area

BricsCAD VBAを使ってみよう[8]　Excelとの連携②-2　
「Excel VBA to BricsCAD」Draw_ChannelSteel

BricsCAD VBAを使ってみよう[9]　TABLEの自動作成と値入力
「BricsCAD VBA 」AutomaticCreation of TABLE

BricsCAD VBAを使ってみよう[10]　Excelとの連携②-3
「Excel VBA to BricsCAD」SerialNumber_Ⅱ

BricsCAD VBAを使ってみよう[11]　Excelとの連携②-4 
「Excel VBA to BricsCAD」Draw_Rectang

BricsCAD VBAを使ってみよう[12]　Excelとの連携②-5 指定画層にOffset
「Excel VBA to BricsCAD」Continuous Offset to Specified Layer

BricsCAD VBAを使ってみよう[13]　Excelとの連携②-6 指定画層にHATCH
「Excel VBA to BricsCAD」Continuous Hatch to Specified Layer

BricsCAD VBAを使ってみよう[14]　Excelとの連携②-7　長さ計測
「Excel VBA to BricsCAD」Get Length

BricsCAD VBAを使ってみよう[15]　Excelとの連携②-8　画層状態ｺﾝﾄﾛｰﾙ
「Excel VBA to BricsCAD」LayerStatusControl

BricsCAD VBAを使ってみよう[16]　Excelとの連携②-9　回転＆移動orｺﾋﾟｰ
「Excel VBA to BricsCAD」Rotate & move or copy

 

以下検討中です。

◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇
「この特集記事の内容につきましては、
こちらの環境のみの検討結果です。
動作保証は出来かねますため、ご参考
資料としてお扱いください。
Windows11（64bit）
BricsCAD pro V21（64bit）
Office2019（64bit）
◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇