前回の、
BricsCAD VBAを使ってみよう[10]　Excelとの連携②-3
からの続篇です。

【2021.09.21改定】

連番用のVBAを元に使用頻度の高い図形で、四角形の連続作図を検討しました。

同サイズでは、連続して作図できます。
サイズを変更する場合は、一旦ESCキーで終了して、HとWの値を入力します。
動作中に、【Spaceｷｰ→ﾃﾝｷｰで直接選択】もしくは【右ｸﾘｯｸにより基点1～9→１～をｽｸﾛｰﾙ】で作図基点を変えることができます。（自動的にPASTECLIPする図形の基点を変更します）

1，連番のVBAコードからの変更点の概要

 １，Excelのbookを開いた時の自動実行

基本は前回の連番と同様に、先にBricsCADを開いておきます。

次に、WorkBookを開いた時、BricsCADに作図用の画層を自動作成します。

作成する画層は、「PASTECLIP」用の画層のみです。

現在の画層一覧を取得しcomboboxに格納します。
「PASTECLIP」用の画層はリストに含まないようにしています。
RECTANG作図用の画層をcomboboxから選択します。

 

自動実行のコード

前回の連番の時と同様に、Workbook_Open()のsubﾌﾟﾛｼｰｼﾞｬ内に記述します。

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

''======【PASTECLIP判定用画層の確認と作成】=====
    Dim PastLyr As String, LayCol As Integer
    ''PASTECLIP用画層名
    PastLyr = Cells(6, 2).Value
    ''画層色を指定
    LayCol = 4
    
    Dim LayObj As AcadLayer
    Dim NwLayObj As AcadLayer
    Dim CkLyr As Boolean
    CkLyr = False
    ''同じ画層名が有るかチェック
    For Each LayObj In BcadDoc.Layers
        If LayObj.Name = PastLyr Then
            CkLyr = True
            Exit For
        End If
    Next
    If CkLyr = False Then
        ''画層がない場合は作成する
        Set NwLayObj = BcadDoc.Layers.Add(PastLyr)
        NwLayObj.Color = LayCol
    End If

''=====【画層一覧の取得】=====
''ComboBoxのオブジェクト変数を宣言
Dim ComboBox As MSForms.ComboBox
Set ComboBox = ActiveSheet.ComboBox1
''全画層名をComboBox1に格納
    Dim layerNames As String
    For Each LayObj In BcadDoc.Layers
        ''PASTECLIP用画層名以外の全画層名を取得
        If LayObj.Name <> PastLyr Then
            layerNames = layerNames + LayObj.Name + vbCrLf
            ComboBox.AddItem LayObj.Name
        End If
    Next
''現在の画層名をｺﾝﾎﾞﾎﾞｯｸｽに標示
    ComboBox.Value = BcadDoc.ActiveLayer.Name

Set NwLayObj = Nothing
Set ComboBox = Nothing
Set BcadDoc = Nothing
Set BcadApp = Nothing

End Sub

 

2，WorkSheetの構成

RECTANGの四隅を、1・3・7・9とし、更にテンキーのNoと同様の位置を基点に追加しています。
ActiveXコントロールのOptionButton★を、テンキーと同様に★１～9で並べ、10を単位の㎜、★11をｍにしています。

実行ボタンは、フォームコントロールのボタンです。

作図実行時の基点は、OptionButtonを選択しておきます。
作図繰り返し動作中は、Spaceキーを先に押して（押し続けません）、
次にテンキーで変更する基点を選択して、PASTECLIP用のPOLYLINE図形を変更するか、
右クリックで現在の基点Noからカウントアップして、PASTECLIP用のPOLYLINE図形を変更します。(連続して右クリックで変更できます)

３，RECTANG作図用のプロシージャ

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

今回は、他でも使えそうなので、キー操作での選択を追加しました。

【2021.09.21改定】

Option Explicit

''Win32API宣言(64bit)Sleep関数
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Declare PtrSafe Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long

Sub Draw_Rectang()

''=========================================
''四角形連続作図 (BricsCAD V21  Excel2019)
''2021.08.22初稿
''2021.09.18改定：再作図時の座標値を訂正
''2021.09.21改定：作図時のズーム範囲を訂正
''=========================================

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

''現在開いているBricsCADを取得する
Set BcadApp = GetObject(, "BricscadApp.AcadApplication")

BcadApp.Visible = True
Set BcadDoc = BcadApp.ActiveDocument

''現在の画層名を取得
Dim CurLyr As String
CurLyr = BcadDoc.ActiveLayer.Name
''作図用画層名を取得
Dim SelLyr As String
SelLyr = ActiveSheet.ComboBox1.Value
''PASTECLIP用画層名
Dim PastLyr As String
PastLyr = Cells(6, 2).Value

''↓↓必要に応じて設定してください。
''図形スナップモードの変数を宣言
'Dim OSM As Integer
''図形スナップモードをOFF
'BcadDoc.SetVariable "OSMODE", 0
''図形スナップモードを元に戻す
'BcadDoc.SetVariable "OSMODE", OSM

''右ｸﾘｯｸﾒﾆｭｰの変数を宣言
Dim RkMenu As Integer
''右ｸﾘｯｸﾒﾆｭｰの取得
RkMenu = BcadDoc.GetVariable("SHORTCUTMENU")
''右ｸﾘｯｸﾒﾆｭｰOFF
BcadDoc.SetVariable "SHORTCUTMENU", 0

''BricsCADのキャプションを取得
    Dim BcadCaption As String
    BcadCaption = BcadDoc.Application.Caption

'' Excelのキャプションを取得
Dim xlApp As String
xlApp = Excel.Application.Caption

''図形ｻｲｽﾞの変数を宣言(ﾀﾃ・ﾖｺ)
    Dim Objhi, ObjWd As Double
''ﾀﾃﾖｺ寸法
    Objhi = Cells(3, 2).Value: ObjWd = Cells(4, 2).Value
''入力単位がｍの場合の換算
    If ActiveSheet.OptionButton11.Value = True Then
        Objhi = Objhi * 1000: ObjWd = ObjWd * 1000
    End If
    
    If Objhi = 0 Or ObjWd = 0 Then MsgBox "値が入力されていません": Exit Sub

''作図開始時判定ﾌﾗｸﾞ
    Dim STFlg As Boolean
    STFlg = True
''ESCｷｰ時判定ﾌﾗｸﾞ
    Dim EscFlg As Boolean
    EscFlg = False
''PASTECLIP時判定ﾌﾗｸﾞ
    Dim PastFlg As Boolean
    PastFlg = False

''===========================================
''===========================================

'' BricsCADの画面をアクティブ
    AppActivate BcadCaption
    
'' MODEMACRO表示
BcadDoc.SendCommand "MODEMACRO" & vbCr & "終了【ESC】/基点変更【右ｸﾘｯｸ】or【Space→ﾃﾝｷｰ】" & vbCr

'' 作図繰り返し
ReturnLine:

''画層を"PASTECLIP"に変更する
    BcadDoc.SetVariable "CLAYER", PastLyr

''===========================================
''===========================================

Dim Getpt() As Double
''開始時は画面中央座標を取得する
    If STFlg = True Then
        Getpt = BcadDoc.GetVariable("VIEWCTR")
    End If
''Polylineで四角形を描画
    Dim objPoly As AcadPolyline
    Call DrawPolyline(PastFlg, Getpt, Objhi, ObjWd, BcadDoc, objPoly)

''開始時の画面表示ｻｲｽﾞ調整
    ''作図位置にズーム
        Sleep 30
        Dim Zp1(0 To 2) As Double, Zp2(0 To 2) As Double
        Dim ZA As Double
        If ObjWd >= Objhi Then
         ZA = Objhi
        Else
         ZA = ObjWd
        End If
        Zp1(0) = Getpt(0) - ObjWd: Zp1(1) = Getpt(1) - Objhi: Zp1(2) = Getpt(2)
        Zp2(0) = Getpt(0) + ObjWd: Zp2(1) = Getpt(1) + Objhi: Zp2(2) = Getpt(2)
        ZoomWindow Zp1, Zp2

        STFlg = False

''Polyline図形を選択
    BcadDoc.SendCommand "SELECT" & vbCr & "L" & vbCr & vbCr

''【COPYBASE】
    BcadDoc.SendCommand "COPYBASE" & vbCr & Getpt(0) & "," & Getpt(1) & vbCr
    BcadDoc.SendCommand "ERASE" & vbCr

''===========================================
''              【PASTECLIP】
''===========================================

''PASTECLIP判定用SelectionSets
    On Error Resume Next
    Dim RectObj As AcadSelectionSet
    ''同じ選択ｾｯﾄが有れば削除
    BcadDoc.SelectionSets("Rectang").Delete

    Set RectObj = BcadDoc.SelectionSets.Add("Rectang")
    'エラートラップ
        If Err Then
            Set RectObj = BcadDoc.SelectionSets.Item("Rectang")
            Err.Clear
            RectObj.Clear
        End If
    
    Dim FilterType(0 To 1) As Integer
    Dim FilterData(0 To 1) As Variant

''PASTECLIPした図形(POLYLINE)の選択条件を設定
    FilterType(0) = 0
    FilterData(0) = "POLYLINE"
    FilterType(1) = 8
    FilterData(1) = "PASTECLIP"

BcadDoc.SendCommand "_PASTECLIP" & vbCr

Dim SelCnt As Integer

Do
    Sleep 30
    
    ''ESCキーでループを抜けて終了する
    If GetAsyncKeyState(vbKeyEscape) Then
    
        EscFlg = True: Exit Do
    
    ''Spaceキーで、基点をテンキー選択で再作図
    ElseIf GetAsyncKeyState(vbKeySpace) Then

        ''図形を選択セットに格納(フィルタ：画面全体、画層、ラインタイプ)
        RectObj.Select acSelectionSetAll, , , FilterType, FilterData
        ''選択セット内のオブジェクト数を取得
        'Dim SelCnt As Integer
        SelCnt = RectObj.Count
        ''PASTECLIPされた場合
            If SelCnt <> 0 Then
                Sleep 100
                 RectObj.Erase
            End If
        Do
            Sleep 30
            If GetAsyncKeyState(vbKeyNumpad1) Then
                ActiveSheet.OptionButton1.Value = True: Exit Do
            ElseIf GetAsyncKeyState(vbKeyNumpad2) Then
                ActiveSheet.OptionButton2.Value = True: Exit Do
            ElseIf GetAsyncKeyState(vbKeyNumpad3) Then
                ActiveSheet.OptionButton3.Value = True: Exit Do
            ElseIf GetAsyncKeyState(vbKeyNumpad4) Then
                ActiveSheet.OptionButton4.Value = True: Exit Do
            ElseIf GetAsyncKeyState(vbKeyNumpad5) Then
                ActiveSheet.OptionButton5.Value = True: Exit Do
            ElseIf GetAsyncKeyState(vbKeyNumpad6) Then
                ActiveSheet.OptionButton6.Value = True: Exit Do
            ElseIf GetAsyncKeyState(vbKeyNumpad7) Then
                ActiveSheet.OptionButton7.Value = True: Exit Do
            ElseIf GetAsyncKeyState(vbKeyNumpad8) Then
                ActiveSheet.OptionButton8.Value = True: Exit Do
            ElseIf GetAsyncKeyState(vbKeyNumpad9) Then
                ActiveSheet.OptionButton9.Value = True: Exit Do
            End If
        Loop
        
        EscFlg = False: GoTo ReturnLine
        
    ''【右ｸﾘｯｸで基点を１～９ｽｸﾛｰﾙで変更し再作図】
    ElseIf GetAsyncKeyState(vbKeyRButton) <> 0 Then
    
        Sleep 300
    
        ''図形を選択セットに格納(フィルタ：画面全体、画層、ラインタイプ)
        RectObj.Select acSelectionSetAll, , , FilterType, FilterData
        ''選択セット内のオブジェクト数を取得
        'Dim SelCnt As Integer
        SelCnt = RectObj.Count
        ''PASTECLIPされた場合
            If SelCnt <> 0 Then
                Sleep 100
                 RectObj.Erase
            End If
        ''挿入基準点変更に伴う四角形４隅の移動量
        If ActiveSheet.OptionButton1.Value = True Then
            ActiveSheet.OptionButton2.Value = True
        ElseIf ActiveSheet.OptionButton2.Value = True Then
            ActiveSheet.OptionButton3.Value = True
        ElseIf ActiveSheet.OptionButton3.Value = True Then
            ActiveSheet.OptionButton4.Value = True
        ElseIf ActiveSheet.OptionButton4.Value = True Then
            ActiveSheet.OptionButton5.Value = True
        ElseIf ActiveSheet.OptionButton5.Value = True Then
            ActiveSheet.OptionButton6.Value = True
        ElseIf ActiveSheet.OptionButton6.Value = True Then
            ActiveSheet.OptionButton7.Value = True
        ElseIf ActiveSheet.OptionButton7.Value = True Then
            ActiveSheet.OptionButton8.Value = True
        ElseIf ActiveSheet.OptionButton8.Value = True Then
            ActiveSheet.OptionButton9.Value = True
        ElseIf ActiveSheet.OptionButton9.Value = True Then
            ActiveSheet.OptionButton1.Value = True
        End If

        EscFlg = False: GoTo ReturnLine

    Else

        ''POLYLINE図形を選択セットに格納
        RectObj.Select acSelectionSetAll, , , FilterType, FilterData
        ''選択セット内のオブジェクト数を取得
        SelCnt = RectObj.Count

        ''PASTECLIPされた場合
        If SelCnt <> 0 Then
            PastFlg = True
            Dim PastObj As AcadEntity
            Set PastObj = RectObj.Item(0)
        ''PASTECLIPした囲い図形にREGIONを作成
            Dim RegObj As Variant
            RegObj = BcadDoc.ModelSpace.AddRegion(PastObj)
        ''PASTECLIPした囲い図形を削除
            RectObj.Item(0).Erase

        ''REGIONの選択条件を設定
            FilterType(0) = 0
            FilterData(0) = "REGION"
            FilterType(1) = 8
            FilterData(1) = "PASTECLIP"
        ''REGIONを選択セットに格納
            RectObj.Select acSelectionSetAll, , , FilterType, FilterData
        ''REGIONの中心座標を取得
            Dim Centpt() As Double
            Centpt = RectObj.Item(1).Centroid
        ''作図座標に格納
            Getpt(0) = Centpt(0): Getpt(1) = Centpt(1): Getpt(2) = Centpt(2)
         ''REGIONを削除
            RectObj.Item(1).Erase
        
        ''画層を"作図画層"に変更する
        BcadDoc.SetVariable "CLAYER", SelLyr
        
        ''PASTECLIPした座標にPolyline図形を再作図
        Call DrawPolyline(PastFlg, Getpt, Objhi, ObjWd, BcadDoc, objPoly)
        
        PastFlg = False
        
        ''次回作図時に、図形のCOPYBASEを前回作図位置で行うための基点変更
        If ActiveSheet.OptionButton1.Value = True Then
            Getpt(0) = Centpt(0) - ObjWd / 2: Getpt(1) = Centpt(1) - Objhi / 2: Getpt(2) = Centpt(2)
        ElseIf ActiveSheet.OptionButton2.Value = True Then
           Getpt(0) = Centpt(0): Getpt(1) = Centpt(1) - Objhi / 2: Getpt(2) = Centpt(2)
        ElseIf ActiveSheet.OptionButton3.Value = True Then
           Getpt(0) = Centpt(0) + ObjWd / 2: Getpt(1) = Centpt(1) - Objhi / 2: Getpt(2) = Centpt(2)
        ElseIf ActiveSheet.OptionButton4.Value = True Then
           Getpt(0) = Centpt(0) - ObjWd / 2:: Getpt(1) = Centpt(1): Getpt(2) = Centpt(2)
        ElseIf ActiveSheet.OptionButton5.Value = True Then
           Getpt(0) = Centpt(0): Getpt(1) = Centpt(1): Getpt(2) = Centpt(2)
        ElseIf ActiveSheet.OptionButton6.Value = True Then
           Getpt(0) = Centpt(0): Getpt(1) = Centpt(1) + Objhi / 2: Getpt(2) = Centpt(2)
        ElseIf ActiveSheet.OptionButton7.Value = True Then
           Getpt(0) = Centpt(0) - ObjWd / 2: Getpt(1) = Centpt(1) + Objhi / 2:: Getpt(2) = Centpt(2)
        ElseIf ActiveSheet.OptionButton8.Value = True Then
           Getpt(0) = Centpt(0): Getpt(1) = Centpt(1) + Objhi / 2:: Getpt(2) = Centpt(2)
        ElseIf ActiveSheet.OptionButton9.Value = True Then
           Getpt(0) = Centpt(0) + ObjWd / 2: Getpt(1) = Centpt(1) + Objhi / 2: Getpt(2) = Centpt(2)
        End If
        
        Sleep 30

        Exit Do
        
        End If

    End If

Loop

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

''Esc終了時はｴﾗｰ処理後終了する
If EscFlg = True Then GoTo ErrLine

''作図繰り返し
    GoTo ReturnLine

ErrLine:

    '' MODEMACROをなしにする
    BcadDoc.SendCommand "MODEMACRO" & vbCr & "." & vbCr
    ''画層を元に戻す
    BcadDoc.SetVariable "CLAYER", CurLyr
    ''図形スナップモードを元に戻す
    'BcadDoc.SetVariable "OSMODE", OSM
    ''ﾐ右ｸﾘｯｸﾒﾆｭy-を元に戻す
    BcadDoc.SetVariable "SHORTCUTMENU", RkMenu

    '' Excelの画面をアクティブ
    AppActivate xlApp

    Set RectObj = Nothing
    Set objPoly = Nothing
    Set BcadDoc = Nothing
    Set BcadApp = Nothing

End Sub

Private Sub ComboBox1_Change()

    SelLyr = ActiveSheet.ComboBox1.Value
    BcadDoc.SetVariable "CLAYER", SelLyr

End Sub

Private Sub DrawPolyline(ByVal PastFlg As Boolean, ByVal Getpt As Variant, ByVal Objhi As Double, ByVal ObjWd As Double, BcadDoc As BricscadApp.AcadDocument, objPoly As AcadPolyline)

''挿入基準点変更に伴う作図用座標値の移動
    Dim Mx, My As Double

If PastFlg = False Then

        If ActiveSheet.OptionButton1.Value = True Then
            Mx = 0: My = 0
        ElseIf ActiveSheet.OptionButton2.Value = True Then
            Mx = -ObjWd / 2: My = 0
        ElseIf ActiveSheet.OptionButton3.Value = True Then
            Mx = -ObjWd: My = 0
        ElseIf ActiveSheet.OptionButton4.Value = True Then
            Mx = 0: My = -Objhi / 2
        ElseIf ActiveSheet.OptionButton5.Value = True Then
            Mx = -ObjWd / 2: My = -Objhi / 2
        ElseIf ActiveSheet.OptionButton6.Value = True Then
            Mx = -ObjWd: My = -Objhi / 2
        ElseIf ActiveSheet.OptionButton7.Value = True Then
            Mx = 0: My = -Objhi
        ElseIf ActiveSheet.OptionButton8.Value = True Then
            Mx = -ObjWd / 2: My = -Objhi
        ElseIf ActiveSheet.OptionButton9.Value = True Then
            Mx = -ObjWd: My = -Objhi
        End If
Else
        Mx = -ObjWd / 2: My = -Objhi / 2
End If

   
''RECTANGをPolylineで描画
    Dim Pv(0 To 14) As Double
        ''左下の座標
        Pv(0) = Getpt(0) + Mx: Pv(1) = Getpt(1) + My: Pv(2) = Getpt(2)
        ''右下の座標
        Pv(3) = Getpt(0) + Mx: Pv(4) = Getpt(1) + My + Objhi: Pv(5) = Getpt(2)
        ''右上の座標
        Pv(6) = Getpt(0) + Mx + ObjWd: Pv(7) = Getpt(1) + My + Objhi: Pv(8) = Getpt(2)
        ''左上の座標
        Pv(9) = Getpt(0) + Mx + ObjWd: Pv(10) = Getpt(1) + My: Pv(11) = Getpt(2)
        ''左上の座標
        Pv(12) = Getpt(0) + Mx: Pv(13) = Getpt(1) + My: Pv(14) = Getpt(2)
        ''3Dポリライン作図
        Set objPoly = BcadDoc.ModelSpace.AddPolyline(Pv)
        ''ポリラインを閉じる
        objPoly.Closed = False

End Sub

 

Do～Loop内のコードをSleepでコントロールしていますので、ＰＣの処理速度の影響があるかもわかりません。そのあたりは以下のcoffe breakを参照ください。

以下続く・・・・

 

coffee break

今回はEsc終了以外に、作図基点を作図中に変更することを検討しました。
Do～Loopで選択を行っていますが、使用しているSleepの30と300を逆にすると、エラーになります。Escキー、右クリック、テンキーのキーアクションをとらえれない状態で、コードのすり抜けが発生し、連続的に原点でPASTECLIPする場合があります。この場合Escキーを連打で終了します。

SendCommandも、コマンドの組み合わせによっては、影響が生じる場合が有ります。
CadもExcelもいったん閉じて再度実行で治っていますので、その他まだ気づいていない要因が有るのかも分かりません。

この辺りは、コマンドラインウインドウで、動作状態を確認しながら調整することも重要ですね。

2021.09.21　一部改定しました。

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

 

以下検討中です。

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