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

以前に
BricsCAD VBAを使ってみよう[3] UserFormその2
で検討した、連番【初号機】では、クリック後に連番を描画するため、位置とサイズが事前に確認できず、後で位置をずらす必要が生じる場合が多く操作性が今一でした。


クリックした位置に連番を描画します。

そこで、改訂版の連番【2号機】を検討しました。

マウスカーソルに連番がくっついた状態で、スクロールや拡大縮小して、位置やサイズを目視確認しながら連番の描画位置をクリックします。

Excelとの連携を検討しました、Excel VBA を用いた
BricsCAD VBAを使ってみよう[7] Excelとの連携②
BricsCAD VBAを使ってみよう[8] Excelとの連携②-2
での検討内容を元に、連番の改定版を検討しました。

1,改定の概要

 1,連続描画の方法

目視確認しながら連続して任意の位置に図形を描画する手段として、
クリック位置に描画し、その図形を移動するか、COPYBASEしてPASTECLIPすることが考えれます。
結果として、COPYBASEしてPASTECLIPする方法を選択しました。

BricsCAD VBAを使ってみよう[7] Excelとの連携②で用いた方法の、
Do~Loopで、画層「CkBoundary」内に境界が作成されSelectionSets「REGION」のオブジェクトのカウントが「0」でない場合(つまりREGIONが作成された場合)はLoopを抜け、境界が作成さない場合はカウントは「0」のままでLoop内としています。終了はESCキーです。・・・・

と同様に、「PASTECLIP」したオブジェクトの有無で判定するようにしました。
繰り返し描画のための座標値は、開始時は画面中央、2回目以降は「PASTECLIP」したオブジェクトの「REGION」を作成しその中心座標を取得します。(常に画面中央でもいいのいですが、ひょっこりはんみたいに出てきますんで・・・)

 2,VBAの選択

ExcelのVBEにコードを記述し、ExcelのWorkSheetで作成しています。

BricsCADのVBAで、UserFormを用いて検討していましたが、途中で上記に変えました。(Excelで複数データーを読み込んで連続処理することを基本の目的としているため)
ちなみに、WIn32APIは必須ですが、UserFormを用いる場合、UserFormのコード内に記述するとエラーになります。標準モジュールを作成しその中にWIn32APIを記述します。

 3,Excelのbookを開いた時の自動実行

今回からは、事前に作図用のBricsCADが開かれていることが前提です。

ExcelのBookを開いたときに、BricsCADの作図用画層の確認と作成を事前に行うようにしました。(毎回作図実行時に確認する必要は無いため)

連番描画用のRenban画層と、PASTECLIP判定用のPASTECLIP画層が、Workbook起動後に自動で作成されました。

2,連続作図用に改定したVBAコード

,連番用のワークシートを作成します

Worksheetは、以下の構成にて作成しています。
(B5)と(B6)セルは入力規制でドロップダウンで選択できるようにしました。
実行ボタンは、フォームコントロールのボタンです。

WorkBookの画面を小さくすれば、十分実用的です。(個人的見解ですが)

2,Excelのbookを開いた時の自動実行のコード

まず、新規のWorkBookでは、ExcelVBE画面で、ツール→参照設定 でBricsCAD APPとBricsCAD Dbを設定します。(実は、VBAコードを作成中にエラーで気づきました^^)


今回から、BricsCAD V21 を使用してます。

Excelのbookを開いた時に、自動実行させるコードの記述個所は、

ThisWorkbookを選択し、GeneralをWorkbookに変えます。

すると、自動的にWorkbook_Open()のsubプロシージャが作成されますので、その中にbookを開いた時に、自動実行させるコードを記述します。

自動実行のコード

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 addLyr As String, LayCol As Integer
    ''連番用画層名
    addLyr = Cells(2, 2).Value
    ''画層色を指定
    LayCol = 7
    Dim LayObj As AcadLayer
    Dim NwLayObj As AcadLayer
    Dim CkLyr As Boolean
    CkLyr = False
    ''同じ画層名が有るかチェック
    For Each LayObj In BcadDoc.Layers
        If LayObj.Name = addLyr Then
            CkLyr = True
            Exit For
        End If
    Next
    If CkLyr = False Then
        ''画層がない場合は作成する
        Set NwLayObj = BcadDoc.Layers.Add(addLyr)
        NwLayObj.Color = LayCol
    End If

   ''PASTECLIP用画層名
    addLyr = Cells(3, 2).Value
    ''画層色を指定
    LayCol = 4
    CkLyr = False
    ''同じ画層名が有るかチェック
    For Each LayObj In BcadDoc.Layers
        If LayObj.Name = addLyr Then
            CkLyr = True
            Exit For
        End If
    Next
    If CkLyr = False Then
        ''画層がない場合は作成する
        Set NwLayObj = BcadDoc.Layers.Add(addLyr)
        NwLayObj.Color = LayCol
    End If

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

End Sub

コードの概要

Bookを開いたときに、まず初めにBricsCADが開かれているかを判定します。

PASTECLIP判定用画層の確認と作成で、連番用の画層とPASTECLIP用の画層を作成します。

画層名はWorksheetから読み込んでいますので、任意の名前を付けれます。
画層色はここで、色番号で指定しています。

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

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

Option Explicit

'===Win32API宣言(64bit)===
'キー情報関数
Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
'Sleep関数
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)

Sub SerialNumber()

''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

''【現在の画層名を取得】
    Dim CurLyr As String
    CurLyr = BcadDoc.ActiveLayer.Name

'' 画層作成用
    Dim LyrName As String, LayCol As String

'' 連番画層名取得
    Dim NoLyr As String
    NoLyr = Cells(2, 2).Value

'''連番用補助画層名
    Dim PastLyr As String
    PastLyr = Cells(3, 2).Text

''連番文字高さ
    Dim NoHi As Integer
    NoHi = Cells(4, 2).Value

''連番囲い
    Dim kakoi As String
    kakoi = Cells(5, 2).Value

''連番桁揃え
    Dim keta As String
    keta = Cells(6, 2).Value
 
'' 開始連番を取得
    Dim STnum As Integer
    STnum = Cells(7, 2).Value

''【図形スナップモード】
    Dim OSM As Integer
''現在の図形スナップモードを取得
    OSM = BcadDoc.GetVariable("OSMODE")
''図形スナップモードをOFF
    BcadDoc.SetVariable "OSMODE", 0

''初回起動判定用フラグ
    Dim STFlg As Boolean
    STFlg = True

''ESCキー判定用フラグ
    Dim EscFlg As Boolean
    EscFlg = False

''===========================================
''              【作図実行】
''===========================================

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

''作図中心座標
Dim Pt() As Double
Dim Centpt() As Double

'' 作図繰り返し
ReturnLine:

''開始時は画面中央の座標を取得する
    If STFlg = True Then
            Pt() = BcadDoc.GetVariable("VIEWCTR")
            STFlg = False
    End If

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

''連番を記入

        ''桁揃え
        Dim strString As String
        If keta = "01" Then
            strString = Format(STnum, "00")
        ElseIf keta = "001" Then
            strString = Format(STnum, "000")
        Else
            strString = STnum
        End If

        Dim objText As AcadText
        Set objText = BcadDoc.ModelSpace.AddText(strString, Pt, NoHi)
        objText.Alignment = acAlignmentMiddleCenter
        objText.TextAlignmentPoint = Pt
        ''桁数と文字幅の調整
        If Len(STnum) = 2 Then
            objText.ScaleFactor = 0.8
        ElseIf Len(STnum) = 3 Then
            objText.ScaleFactor = 0.7
        ElseIf Len(STnum) = 4 Then
            objText.ScaleFactor = 0.6
        End If
        
        BcadDoc.SendCommand "SELECT" & vbCr & "L" & vbCr

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

''連番囲いを作図
    Dim myCircle As AcadCircle
    Dim objPoly As AcadPolyline
    Call DrawKakoi(Pt, NoHi, kakoi, BcadDoc, myCircle, objPoly)

''文字と囲いを選択
        BcadDoc.SendCommand "SELECT" & vbCr & "Last" & vbCr & _
                                "ADD" & vbCr & "L" & vbCr & vbCr
''連番にズーム
        BcadDoc.Application.ZoomCenter Pt, NoHi * 4
        Sleep 50

''COPYBASE
        BcadDoc.SendCommand "COPYBASE" & vbCr & Pt(0) & "," & Pt(1) & vbCr
        BcadDoc.SendCommand "ERASE" & vbCr

''PASTECLIP判定用SelectionSets

On Error Resume Next

Dim RenObj As AcadSelectionSet
    ''同じ選択セットが有れば削除
    BcadDoc.SelectionSets("Renban").Delete

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

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

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

BcadDoc.SendCommand "PASTECLIP" & vbCr

Dim SelCnt As Integer

Do

    Sleep 30

    If GetAsyncKeyState(vbKeyEscape) Then
    
        ''ESCキーでループを抜けて終了する
        EscFlg = True: Exit Do

    Else

        ''囲い図形を選択セットに格納
        RenObj.Select acSelectionSetAll, , , FilterType, FilterData

        ''選択セット内のオブジェクト数を取得
        SelCnt = RenObj.Count

        ''PASTECLIPされた場合
        If SelCnt <> 0 Then
            Dim PastObj As AcadEntity
            Set PastObj = RenObj.Item(0)

        ''PASTECLIPした囲い図形にREGIONを作成
            Dim RegObj As Variant
            RegObj = BcadDoc.ModelSpace.AddRegion(PastObj)
    
        ''PASTECLIPした囲い図形を削除
            RenObj.Item(0).Erase

        ''REGIONの選択条件を設定
            FilterType(0) = 0
            FilterData(0) = "REGION"
            FilterType(1) = 8
            FilterData(1) = "PASTECLIP"
    
        ''REGIONを選択セットに格納
            RenObj.Select acSelectionSetAll, , , FilterType, FilterData

        ''REGIONの中心座標を取得
            Centpt = RenObj.Item(1).Centroid

        ''作図座標に格納
            Pt(0) = Centpt(0): Pt(1) = Centpt(1): Pt(2) = Centpt(2)

         ''REGIONを削除
            RenObj.Item(1).Erase
        
        ''画層を"NoLyr"に変更する
        BcadDoc.SetVariable "CLAYER", NoLyr
        ''PASTECLIPした座標に連番囲い図形を作図
        Call DrawKakoi(Pt, NoHi, kakoi, BcadDoc, myCircle, objPoly)

        Exit Do
        
        End If

    End If

Loop

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

''Esc終了時はエラー処理後終了する
If EscFlg = True Then GoTo ErrLine

''次のデーターへカウントアップ
    STnum = STnum + 1
    Cells(7, 2).Value = STnum

''作図繰り返し
    GoTo ReturnLine

ErrLine:

    ''画層を元に戻す
    BcadDoc.SetVariable "CLAYER", CurLyr
    ''図形スナップモードを元に戻す
    BcadDoc.SetVariable "OSMODE", OSM
    Err.Clear
    On Error GoTo 0
    Set RenObj = Nothing
    Set objText = Nothing
    Set myCircle = Nothing
    Set objPoly = Nothing
    Set BcadApp = Nothing
    Set BcadDoc = Nothing
    Exit Sub

End Sub

Private Sub DrawKakoi(Centpt As Variant, NoHi As Integer, kakoi As String, _
    BcadDoc As BricscadApp.AcadDocument, myCircle As AcadCircle, objPoly As AcadPolyline)

Dim Ps As Variant

    ''連番囲いを作図
    If kakoi = "〇" Then
        Set myCircle = BcadDoc.ModelSpace.AddCircle(Centpt, NoHi)
                
    ElseIf kakoi = "△" Then
        ReDim Ps(0 To 11) As Double
            ''左下の座標
            Ps(0) = Centpt(0) - NoHi * 1.73: Ps(1) = Centpt(1) - NoHi: Ps(2) = Centpt(2)
            ''上の座標
            Ps(3) = Centpt(0): Ps(4) = Centpt(1) + NoHi * 2: Ps(5) = Centpt(2)
            ''右下の座標
            Ps(6) = Centpt(0) + NoHi * 1.73: Ps(7) = Centpt(1) - NoHi: Ps(8) = Centpt(2)
            ''左下の座標
            Ps(9) = Centpt(0) - NoHi * 1.73: Ps(10) = Centpt(1) - NoHi: Ps(11) = Centpt(2)
            ''3Dポリライン作図
            Set objPoly = BcadDoc.ModelSpace.AddPolyline(Ps)
            ''ポリラインを閉じる
            objPoly.Closed = False

    ElseIf kakoi = "□" Then
        ReDim Ps(0 To 14) As Double
            ''左下の座標
            Ps(0) = Centpt(0) - NoHi * 1: Ps(1) = Centpt(1) - NoHi: Ps(2) = Centpt(2)
            ''左上の座標
            Ps(3) = Centpt(0) - NoHi * 1: Ps(4) = Centpt(1) + NoHi: Ps(5) = Centpt(2)
            ''上の座標
            Ps(6) = Centpt(0) + NoHi * 1: Ps(7) = Centpt(1) + NoHi: Ps(8) = Centpt(2)
            ''右下の座標
            Ps(9) = Centpt(0) + NoHi * 1: Ps(10) = Centpt(1) - NoHi: Ps(11) = Centpt(2)
            ''左下の座標
            Ps(12) = Centpt(0) - NoHi * 1: Ps(13) = Centpt(1) - NoHi: Ps(14) = Centpt(2)
            ''3Dポリライン作図
            Set objPoly = BcadDoc.ModelSpace.AddPolyline(Ps)
            ''ポリラインを閉じる
            objPoly.Closed = False

    ElseIf kakoi = "五角" Then
        ReDim Ps(0 To 17) As Double
            ''1番目の座標
            Ps(0) = Centpt(0) - NoHi * 0.727: Ps(1) = Centpt(1) - NoHi: Ps(2) = Centpt(2)
            ''2番目の座標
            Ps(3) = Centpt(0) - NoHi * 1.176: Ps(4) = Centpt(1) + NoHi * 0.382: Ps(5) = Centpt(2)
            ''3番目の座標
            Ps(6) = Centpt(0): Ps(7) = Centpt(1) + NoHi * 1.236: Ps(8) = Centpt(2)
            ''4番目の座標
            Ps(9) = Centpt(0) + NoHi * 1.176: Ps(10) = Centpt(1) + NoHi * 0.382: Ps(11) = Centpt(2)
            ''5番目の座標
            Ps(12) = Centpt(0) + NoHi * 0.727: Ps(13) = Centpt(1) - NoHi: Ps(14) = Centpt(2)
            ''1番目の座標
            Ps(15) = Centpt(0) - NoHi * 0.727: Ps(16) = Centpt(1) - NoHi: Ps(17) = Centpt(2)
            ''3Dポリライン作図
            Set objPoly = BcadDoc.ModelSpace.AddPolyline(Ps)
            ''ポリラインを閉じる
            objPoly.Closed = False
            
    ElseIf kakoi = "六角" Then
        ReDim Ps(0 To 20) As Double
            ''1番目の座標
            Ps(0) = Centpt(0) - NoHi * 0.577: Ps(1) = Centpt(1) - NoHi: Ps(2) = Centpt(2)
            ''2番目の座標
            Ps(3) = Centpt(0) - NoHi * 1.154: Ps(4) = Centpt(1): Ps(5) = Centpt(2)
            ''3番目の座標
            Ps(6) = Centpt(0) - NoHi * 0.577: Ps(7) = Centpt(1) + NoHi: Ps(8) = Centpt(2)
            ''4番目の座標
            Ps(9) = Centpt(0) + NoHi * 0.577: Ps(10) = Centpt(1) + NoHi: Ps(11) = Centpt(2)
            ''5番目の座標
            Ps(12) = Centpt(0) + NoHi * 1.154: Ps(13) = Centpt(1): Ps(14) = Centpt(2)
            ''6番目の座標
            Ps(15) = Centpt(0) + NoHi * 0.577: Ps(16) = Centpt(1) - NoHi: Ps(17) = Centpt(2)
            ''1番目の座標
            Ps(18) = Centpt(0) - NoHi * 0.577: Ps(19) = Centpt(1) - NoHi: Ps(20) = Centpt(2)
            ''3Dポリライン作図
            Set objPoly = BcadDoc.ModelSpace.AddPolyline(Ps)
            ''ポリラインを閉じる
            objPoly.Closed = False
            
    End If

End Sub

Private Sub Chek_LyrName(LyrName As String, LayCol As String, _
                            BcadDoc As BricscadApp.AcadDocument)

    Dim LayObj As AcadLayer
    Dim NwLayObj As AcadLayer
    Dim CkLyr As Boolean
    CkLyr = False
    ''同じ画層名が有るかチェック
    For Each LayObj In BcadDoc.Layers
        If LayObj.Name = LyrName Then
            CkLyr = True
            Exit For
        End If
    Next
    If CkLyr = False Then
        ''画層がない場合は作成する
        Set NwLayObj = BcadDoc.Layers.Add(LyrName)
        NwLayObj.Color = LayCol
    End If
    
    Sleep 300
    
End Sub


 

この、SerialNumber() を Worksheetのフォームコントロールのボタンに登録します。

コードの概要

初回時は、画面中央座標を取得して作図基点とする

連番画層「Renban」に、連番の文字を描画

連番文字を選択

画層を「PASTECLIP」に変更して、Polylineで連番囲い図形を描画

連番文字と囲い図形を選択し、COPYBASE

COPYBASE後、連番と囲い図形を削除
この時、「PASTECLIP」画層内のPolyline図形が空になる

PASTECLIP判定用SelectionSetsを定義
オブジェクトは、”REGION” 、画層は、”PASTECLIP”

PASTECLIPコマンドを実行
一旦削除したPolyline図形がPASTECLIP画層内にPASTECLIPされるまで、Do~Loop内で待機する。

(終了する場合は、ESCキー)

PASTECLIPされた時、PASTECLIPしたPolyline図形にREGIONを作成し、中心座標を取得する。
この中心座標を次回の作図基点とする。
PASTECLIPしたPolyline図形を削除し、「PASTECLIP」画層内のPolyline図形を空にする

REGIONを削除する。

画層を「Renban」に変更して、Polylineで連番囲い図形を再度描画する。

連番をカウントアップし、ESCキー終了まで連続描画する。

 

検討したコードの活用

今回は、〇以外にPolylineで作成する図形で、△・▢・五角・六角形を検討しましたが、この内、特に四角形は、木造・RC等の建築では結構多用します。
今回のVBAのコードを元に、RECTANGの連続描画を検討しました。

 

次回は、こちらです。
BricsCAD VBAを使ってみよう[11] Excelとの連携②-4

 

coffee break

VBAを用いた自動作図の手段として
①BricsCADVBA、もしくはUserFormを使用
②ExcelVBAのWorkSheet、もしくはUserFormを使用
では、ExcelVBAを使用しWorkSheetで設定する場合が、個人的には触りやすいのですが、検討したコードは、色々と再利用できますので、特にどれかの方法だけでしか使えないないと言うことでもありません。どこかの箇所が、何かのご参考になれば幸いです。

 

BricsCAD VBAを使ってみよう INDEX

BricsCAD VBAを使ってみよう[1] VBAのインストール

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

BricsCAD VBAを使ってみよう[3] UserFormその2
「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 V20(64bit)
Office2019(64bit)
◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇

Visited 69 times, 1 visit(s) today