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

投稿日時: 投稿者:

前回の
BricsCAD VBAを使ってみよう[6]　Excelとの連携①
からの続篇です。

今回は、ExcelVBAでBricsCADと連携する場合を検討しました。
ExcelのVBE画面は、日本語表記の見慣れた画面で処理がしやすいですね。

１，基本設定

1-1，ExcelVBEでの設定

初めに、BricsCADのタイプライブラリを使えるように、ExcelのVBE画面で参照設定を行います。

ツール→参照設定

 

「BricscadApp Type Library 20.0」と「BricscadDbApp Type Library 20.0
」の２か所をチェックし登録します。

1-2，BricsCADを宣言します。

標準モジュールを作成し、ＶＢＡコードを記述します。

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

開いているBricsCADを取得する場合
Set BcadApp = GetObject(, “BricscadApp.AcadApplication”)
新規にBricsCADのインスタンスを生成する場合
Set BcadApp = CreateObject(“BricscadApp.AcadApplication”)

ここでBcadApp、BcadDoc は変数名です。分かり易い名称を付けてください。

1-3，ThisDrawingをBcadDoc にします。

例えば、
Set objPoly = BcadDoc.ModelSpace.AddPolyline(*)
Set objText = BcadDoc.ModelSpace.AddText(*, *, *)
の様に、ThisDrawingをBcadDocに変更します。

これで、BricsCAD VBAを使ってみよう[6]　Excelとの連携①のときのBricsVCADVBAと同じように、ExcelVBA内でBricsCADVBAを使用できます。

詳細は、「面積取得用のＶＢＡ」を参照ください。

２，エクセルシートにデーター取得

２-1，面積取得用シート

概要

CAD画面で図形内をクリックして、その図形の面積値のデーターをExcelのセルに残します。

【面積取得】のボタンをクリックしてスタート
面積を取得する図形内をクリック
10行目から、図形選択順に連番（クリック位置）、面積（㎡）、クリック座標値を残します。
再開時は連番の続きから再開します。

クリックした座標を残す目的は、例えばあとで丸囲い連番等を別途付ける場合にスクロールしながら記入したりする時に使用するためです（今回は追加していません）

Excelの場合ユーザーフォームも使用できますが、シートのセルを用いて設定して、VBAをボタンに登録すればサクッと使えます。

設定内容

設定部分の内容は、

①画層の作成

補助連番とＢＯＵＮＤＡＲＹ及びハッチングの場合はハッチング用の画層を作成します。

特にＢＯＵＮＤＡＲＹ用の画層「CkBoundary」は、必須です。
SendCommand で-BOUNDARYコマンドを使用しています。
Do～Loopで、画層「CkBoundary」内に境界が作成されSelectionSetsで「REGION」のオブジェクトのカウントが「0」でない場合はLoopを抜け、境界が作成さない場合はカウント「0」でLoop内としています。終了はESCキーです。

面積取得

作図単位は㎜で、面積を㎡に換算しています。

3，面積取得用のVBA

 

Option Explicit

''Win32API宣言(64bit)
'スレッド一時待機関数
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)


Sub GetAreaByBoundary()

''【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, BundLyr As String, HatLyr As String, SubNoLyr As String, LyrName As String
''画層色の変数を宣言
Dim BundLyrCol As String, HatLyrCol As String, SubNoLyrCol As String, LyrCol As String
''図形スナップモードの変数を宣言
Dim OSM As Integer
OSM = BcadDoc.GetVariable("OSMODE")

''===【計測用画層の確認と作成】===

''現在の画層名を取得
CurLyr = BcadDoc.ActiveLayer.Name

''補助連番画層名を変数に格納
SubNoLyr = Cells(2, 2).Text
''画層色を変数に格納
SubNoLyrCol = Cells(3, 2).Text
If HatLyrCol = "" Then HatLyrCol = 7
''文字高を変数に格納
Dim SubNoHi As Long
SubNoHi = Cells(4, 2).Value

''画層名がない場合は作成
LyrName = SubNoLyr: LyrCol = SubNoLyrCol
Call Chek_LyrName(LyrName, LyrCol, BcadDoc)

''BOUNDARY用画層名を変数に格納
BundLyr = Cells(6, 2).Text
''画層色を変数に格納
BundLyrCol = Cells(7, 2).Text
If HatLyrCol = "" Then HatLyrCol = 7
''画層名がない場合は作成
LyrName = BundLyr: LyrCol = BundLyrCol
Call Chek_LyrName(LyrName, LyrCol, BcadDoc)

''===【ハッチング用画層の確認と作成】===
Dim ChHat As Boolean
ChHat = ActiveSheet.CheckBox1.Value

If ChHat = True Then
    ''ハッチング用画層名を変数に格納
    HatLyr = Cells(2, 4).Text
    ''画層色を変数に格納
    HatLyrCol = Cells(3, 4).Text
    If HatLyrCol = "" Then HatLyrCol = 7
    ''画層名がない場合は作成
    LyrName = HatLyr: LyrCol = HatLyrCol
    Call Chek_LyrName(LyrName, LyrCol, BcadDoc)
    
    ''ハッチングパターン名
    Dim Hatpat As String
    Hatpat = Cells(4, 4).Text
    ''ハッチング尺度
    Dim HatSca As String
    HatSca = Cells(5, 4).Text
    ''ハッチング角度
    Dim HatAng As String
    HatAng = Cells(6, 4).Text
End If

''画層作成時用Sleep
Sleep 300

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

''========== 【境界作成で面積を取得】==============

''Boundaryで作成されるオブジェクトタイプをリージョンにする
Dim HPBRet As Integer
HPBRet = BcadDoc.GetVariable("HPBOUNDRETAIN")
''0:OFF , 1:ON
BcadDoc.SetVariable "HPBOUNDRETAIN", 1
Dim HPB As Integer
HPB = BcadDoc.GetVariable("HPBOUND")
''0:リージョンを作成 , 1:ポリラインを作成
BcadDoc.SetVariable "HPBOUND", 0

'' 計測カウント用の変数を宣言
Dim GetCnt As Integer
'' カウント開始Noを取得
GetCnt = Cells(8, 2).Text

Dim ssetObj As AcadSelectionSet
Dim objText As AcadText

'' BricsCADの画面をアクティブ
AppActivate BcadCapt
'' OSMODEを無効にする
BcadDoc.SetVariable "OSMODE", 0

Do

On Error Resume Next

ReturnLine:

    ''画層を"CkBoundary"に変更
    BcadDoc.SetVariable "CLAYER", BundLyr

    '' 計測図形内をクリック
    Dim pt() As Double
    pt = BcadDoc.Utility.GetPoint(, "図形内をクリック:終了ESCキー")
    If Err Then
        GoTo ErrLine
    End If

    ''-BOUNDARYで境界を作成する
    BcadDoc.SendCommand "_.-BOUNDARY " & vbCr & vbCr & _
                                pt(0) & "," & pt(1) & vbCr & vbCr
    ''同じ選択ｾｯﾄが有れば削除
    BcadDoc.SelectionSets("boundobj").Delete
    Set ssetObj = BcadDoc.SelectionSets.Add("boundobj")
    'エラートラップ
        If Err Then
            Set ssetObj = BcadDoc.SelectionSets.Item("boundobj")
            Err.Clear
            ssetObj.Clear
        End If
    
    Dim FilterType(1) As Integer
    Dim FilterData(1) As Variant
    FilterType(0) = 0
    FilterData(0) = "REGION"
    FilterType(1) = 8
    FilterData(1) = BundLyr

    ''図形を選択セットに格納(フィルタ：画面全体、画層、ラインタイプ)
    ssetObj.Select acSelectionSetAll, , , FilterType, FilterData

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

    If SelCnt = 0 Then
        ''図形内クリックに戻す
        GoTo ReturnLine
    Else
        ''目視確認用Sleep
        Sleep 300
        
        ''面積を取得する
        Dim ObjArea As Double
        ObjArea = ssetObj.Item(0).Area
        
        ''作成した境界を削除する
        ssetObj.Item(0).Erase
        
        ''ハッチング
        If ChHat = True Then
        ''画層を"HatLyr"に変更する
        BcadDoc.SetVariable "CLAYER", HatLyr
        BcadDoc.SendCommand "-BHATCH " & "P" & vbCr & Hatpat & vbCr & HatSca & vbCr _
                            & HatAng & vbCr & pt(0) & "," & pt(1) & vbCr & vbCr
        
        ''画層を"SubNoLyr"に変更する
        BcadDoc.SetVariable "CLAYER", SubNoLyr
        ''補助連番を記入する
        Set objText = BcadDoc.ModelSpace.AddText(GetCnt, pt, SubNoHi)
        objText.Alignment = acAlignmentMiddleCenter
        objText.TextAlignmentPoint = pt

        End If
        
    End If

    ''Excelへ面積値を記入する
    Dim DataRow As Integer
    DataRow = GetCnt + 9
    Cells(DataRow, 1).Value = GetCnt
    Cells(DataRow, 2).Value = Format(ObjArea / 1000000)
    Cells(DataRow, 2).NumberFormatLocal = "0.000"
    ''クリックした座標値を残す
    Cells(DataRow, 3).Value = pt(0)
    Cells(DataRow, 4).Value = pt(1)
    
    ''計測カウントをカウントアップする
    GetCnt = GetCnt + 1
    Cells(8, 2).Value = GetCnt

Loop

ErrLine:
''画層を元に戻す
        BcadDoc.SetVariable "CLAYER", CurLyr
    ''図形スナップモードを元に戻す
        BcadDoc.SetVariable "OSMODE", OSM
    ''Boundary境界設定を元に戻す
        BcadDoc.SetVariable "HPBOUNDRETAIN", HPBRet
        BcadDoc.SetVariable "HPBOUND", HPB
        Err.Clear
        On Error GoTo 0
        Set objText = Nothing
        Set ssetObj = Nothing
        Set BcadDoc = Nothing
        Set BcadApp = Nothing
        
        Exit Sub

End Sub

Private Sub Chek_LyrName(ByVal LyrName As String, ByVal LyrCol As String, _
                        ByVal 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 = LyrCol
        Set NwLayObj = Nothing
    End If
    
End Sub

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

End Sub

 

コードの概要説明

①画層の作成

宣言セクションで、Sleep関数（Win32API）を宣言しています。
これは、画層作成時に複数画層を作成するとコードの処理が追い抜かれる？様ですのでsleepさせています。
画層名の有り無しは、総当たりで判定しています。

②ウインドウ操作

BricsCADのウインドウはExcelのボタンクリック時に、’BricsCADの画面をアクティブに（最前面に）します。
終了時にExcelのウインドウを最前面にはしていません。

③面積取得

作図は㎜単位のため、㎡に換算しています。

SendCommandで、-BOUNDARYコマンドを使用しています。
Do～Loopで、境界が作成されるか判定します。
システム変数は、Boundaryで作成されるオブジェクトタイプをリージョンにします。
（スプラインではリージョンになるためで、SelectionSetsでポリラインとリージョンを指定してもいいのですが、ここではリージョンに統一しました）

Do～Loopで境界が作成されたかの判定は、選択セット内のオブジェクト数を取得し「0」か「1」かで判定します。そのため作成された境界から面積を取得後に、常に選択セットを空にします。

③ハッチング

ハッチングする場合はチエックボックスで選択し、SendCommand で、-BHATCHコマンドを使用しています。

④補助連番

選択図形との関連性を持たせるため、補助連番を付けます。
記入座標は、クリック座標を使用しています。

⑤ボタン

ボタンはフォームコントロールのボタンを挿入し、右クリック→マクロの登録でVBAを登録します。

 

4，SendCommand と Do～Loop

今回、SendCommandで、-BOUNDARYコマンドを使用するにあたり、Do～Loopで境界が作成されるか判定しています。

囲い連番の件は今回は触れていませんが、付ける連番を画面で目視できて、図形周囲の任意の個所にペタッと張り付けるようなやり方をする場合はどうすればいいかです。


マウスカーソルに連番がついてる状態

連番を記入

ザクっと要点だけですが、

【連番文字】
”画層を”NoLyr”に変更する
BcadDoc.SetVariable “CLAYER”, NoLyr
Set objText = BcadDoc.ModelSpace.AddText(Renban, Npt, NoHi)
【文字を選択】
BcadDoc.SendCommand “SELECT” & vbCr & “L” & vbCr

【囲円を作図】
”画層を”PASTECLIP”に変更する
BcadDoc.SetVariable “CLAYER”, PastLyr
Set myCircle = BcadDoc.ModelSpace.AddCircle(Npt, NoHi)
【文字と囲を選択】
BcadDoc.SendCommand “SELECT” & vbCr & “P” & vbCr & _
“ADD” & vbCr & “L” & vbCr & vbCr

【COPYBASE】
BcadDoc.SendCommand “COPYBASE” & vbCr & x & “,” & y & vbCr

【選択図形を削除】
BcadDoc.SendCommand “ERASE” & vbCr

【選択セット】
Set ssetObj = BcadDoc.SelectionSets.Add(“Renban”)

Dim FilterType(1) As Integer
Dim FilterData(1) As Variant

FilterType(0) = 0
FilterData(0) = “CIRCLE”
FilterType(1) = 8
FilterData(1) = “PASTECLIP”

【PASTECLIP】
BcadDoc.SendCommand “PASTECLIP” & vbCr

Do

【図形を選択セットに格納(フィルタ：画面全体、画層、ラインタイプ)】
ssetObj.Select acSelectionSetAll, , , FilterType, FilterData
・・・・・・・・・
If SelCnt <> 0 Then

”円のCenterを取得して削除
Dim PastObj As AcadEntity
Set PastObj = ssetObj.Item(0)
Dim CentPt As Variant
CentPt = PastObj.Center
ssetObj.Item(0).Erase
Sleep 100
”画層を”NoLyr”に変更する
BcadDoc.SetVariable “CLAYER”, NoLyr
Call DrawKakoi(CentPt, NoHi, kakoi, BcadDoc, myCircle)
Sleep 300
Exit Do

End If

Loop

・・・・・・・・

内容はかなり端折っています。

loopから抜けるのは、If  Err then ではなく、
”ESCキーが押された場合
If GetAsyncKeyState(vbKeyEscape) Then
としています。
その他Sleepをちょこちょこ入れています。

ポイントは、COPYBASE、PASTECLIP　で、PASTECLIPした位置を円のCenterで取得しています。
PASTECLIP画層にCIRCLEが有るかで判定しています。
円のCenterの座標を用いて、再度連番画層に「囲い円」を作成します。
円のCenter以外に、PASTECLIPした座標の取得方法を思いつかないので、三角、四角、多角形の囲いの場合も囲い作図時に円から囲いの種類を変えて再度作図しています。。。

次回は、Excelのシートのデーターから作図を行うVBAで、チャンネル鋼（溝形鋼）の作図を検討しました。

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

 

 

coffee break

今回は、ExcelVBAでBricsCADのVBAを使用することを検討しました。
ExcelVBAでは、Excelのシートだけでサクッと作成できて楽です。
もちろんUseFormも使用できます。

変な余計な操作（例えばLoop中にｵﾌﾞｼﾞｪｸﾄｽﾅｯﾌﾟを無理やり切り替えたり）をしてLoopにはまってタスクマネージャのお世話になるような終了の場合では、Set したオブジェクト変数が残って動作不良になるようで、その場合は割り切ってPCを再起動すると元に戻ります。（おとなしく、途中で変な操作をしなければいいだけなんですが。。。）

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 V20（64bit）
Office2019（64bit）
◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇