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

BricsCAD VBAを使ってみよう[6]～[8]では、Excelとの連携を検討しました。
何百何千とデーターを扱う場合ではExcelとの連携は有用ですが、それほどのデーター量でもなく、図面内で表を作成して処理したい場合もあります。

今回は、TABLEの自動作成と、取得した値のTABLEへの自動入力を検討しました。

BricsCAD VBAを使ってみよう[7]　Excelとの連携②
のEXCELへの値の入力を、CAD画面のTABLEへの入力にしました。

概要

画層を自動作成します。

新規の開始時に画面の任意の個所をクリックしてTABLEを挿入。
挿入位置はTABEL右上。
開始時のデーター入力行は２行にしています。

続けて、面積を計測する図形内をクリック。
連番を付けながらTABLEに取得した面積値を入力します。
中断後継続開始時には、連番の続きから始まり、行が足らなくなると順次追加します。

試される場合は、図で左下の四角形が1000㎜角の四角形ですので、似たようなサイズの図形でお試しください。

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

１，面積取得用のVBA

今回は、BricsCADVBAで作成しています。

【３項目】をサブルーチンにしています。

Sub GetArea_Table()
【画層の有無をチェックし、無ければ作成】
Call Chek_LyrName
【TABLEを取得】
Call Get_table()
【TABLEが無ければ作成】
Call Creat_table()
-BOUNDARYで境界作成
SelectionSetsでREGIONをから面積を取得
TABLEに連番と面積値を入力
End Sub

Option Explicit

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

Sub GetArea_Table()

'' BricsCADのキャプションを取得
Dim BcadCapt As String
BcadCapt = ThisDrawing.Application.Caption
'' BricsCADの画面をアクティブ
AppActivate BcadCapt

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

''画層名の変数を宣言
Dim CurLyr As String, LyrName As String
''現在の画層名を取得
CurLyr = ThisDrawing.ActiveLayer.Name
''画層色の変数を宣言
Dim LyrCol As String
''画層名がない場合は作成
''【テ－ブル用】
LyrName = "Table": LyrCol = "7"
Call Chek_LyrName(LyrName, LyrCol)
''【連番用】
LyrName = "SubNumber": LyrCol = "4"
Call Chek_LyrName(LyrName, LyrCol)
''【BOUNDARY用】
LyrName = "CkBoudary": LyrCol = "1"
Call Chek_LyrName(LyrName, LyrCol)
''【ハッチング用】
LyrName = "Hatch": LyrCol = "3"
Call Chek_LyrName(LyrName, LyrCol)

Sleep 300

''図形スナップモードの変数を宣言
Dim OSM As Integer
OSM = ThisDrawing.GetVariable("OSMODE")
'' OSMODEを無効にする
ThisDrawing.SetVariable "OSMODE", 0

Dim ssetObj As AcadSelectionSet
Dim BoundObj As AcadSelectionSet
Dim MyTable As AcadTable
Dim objText As AcadText
Dim SelCnt As Integer
SelCnt = 0

''現在のTABLEの取得(無ければ作成)
Call Get_table(SelCnt, ssetObj, MyTable, CurLyr, OSM)

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

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

'' 計測カウント用の変数を宣言
Dim GetCnt As Integer
'' 開始Noを取得
GetCnt = 2
    Dim i As Integer
    Dim RetVal As Variant
    Dim RowsCnt As Integer
    RowsCnt = MyTable.Rows
    
    For i = 3 To RowsCnt
        RetVal = MyTable.GetCellValue(i, 0)
        If RetVal = "" Then
            Exit For
        Else
            GetCnt = RetVal + 2
        End If
    Next

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

Do

On Error Resume Next

ReturnLine:

    ''画層を"CkBoundary"に変更
    LyrName = "CkBoudary"
    ThisDrawing.SetVariable "CLAYER", LyrName

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

        GoTo ErrLine

    End If

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

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

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

    If SelCnt = 0 Then
        ''境界が作成されなかった場合は図形内クリックに戻す
        GoTo ReturnLine
    Else
        ''boundary実行時目視確認用Sleep
        Sleep 300
        
        ''面積値を取得する
        Dim ObjArea As Double
        ObjArea = BoundObj.Item(0).Area
        
        ''面積値を取得後に作成した境界を削除する
        BoundObj.Item(0).Erase
        
        ''画層を"Hatch"に変更する
        LyrName = "Hatch"
        ThisDrawing.SetVariable "CLAYER", LyrName
        ''ハッチング
        ThisDrawing.SendCommand "-BHATCH " & "P" & vbCr & "ANSI31" & vbCr & "100" & vbCr _
                            & "0" & vbCr & pt(0) & "," & pt(1) & vbCr & vbCr

        ''画層を"SubNumber"に変更する
        LyrName = "SubNumber"
        ThisDrawing.SetVariable "CLAYER", LyrName
        ''連番を記入する
        Set objText = ThisDrawing.ModelSpace.AddText(GetCnt - 1, pt, 100)
        objText.Alignment = acAlignmentMiddleCenter
        objText.TextAlignmentPoint = pt
        
    End If

    ''Tableへ面積値を記入する
    Dim DataRow As Integer
    DataRow = GetCnt
    Dim TotalRow As Integer
    TotalRow = RowsCnt - 1
    
    ''データ行を自動追加
    If RowsCnt - DataRow < 2 Then
    TotalRow = DataRow + 1
    Call MyTable.InsertRows(DataRow, 300, 1)
                    ''（挿入行,行の高さ,行数）
    Call MyTable.SetAlignment(acDataRow, acMiddleCenter)
    Call MyTable.SetTextHeight(acDataRow, 80)
    End If

    ''連番と面積値を記入
    Call MyTable.SetCellValue(DataRow, 0, Format(GetCnt - 1))
    Call MyTable.SetCellValue(DataRow, 1, Format(ObjArea / 1000000, "0.00"))
    
     ''連番と面積値を記入
     Dim Area As Double
     Dim TotalArea As Double
     TotalArea = 0
     For i = 2 To GetCnt
        Area = MyTable.GetCellValue(i, 1)
        TotalArea = TotalArea + Area
    Next
    Call MyTable.SetCellValue(TotalRow, 1, Format(TotalArea, "0.00"))
    
    ''計測カウントをカウントアップする
    GetCnt = GetCnt + 1

    MyTable.Update

Loop

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

End Sub

Private Sub Get_table(ByRef SelCnt As Integer, _
    ByVal ssetObj As AcadSelectionSet, ByRef MyTable As AcadTable, _
    ByVal CurLyr As String, ByVal OSM As Integer)

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

On Error Resume Next
    ''同じ選択ｾｯﾄが有れば削除
    ThisDrawing.SelectionSets("TableObj").Delete
    Set ssetObj = ThisDrawing.SelectionSets.Add("TableObj")
    'エラートラップ
        If Err Then
            Set ssetObj = ThisDrawing.SelectionSets.Item("TableObj")
            Err.Clear
            ssetObj.Clear
        End If
    
    FilterType(0) = 0
    FilterData(0) = "ACAD_TABLE"

    ssetObj.Select acSelectionSetAll, , , FilterType, FilterData
    SelCnt = ssetObj.Count

    If SelCnt = 0 Then
        Call Creat_table(MyTable, ssetObj, CurLyr, OSM)
    Else
        Set MyTable = ssetObj.Item(0)
    End If

Set ssetObj = Nothing

End Sub

Private Sub Creat_table(ByRef MyTable As AcadTable, ByVal ssetObj As AcadSelectionSet, _
                        ByVal CurLyr As String, ByVal OSM As Integer)

    ''画層を"Table"に変更する
    ThisDrawing.SetVariable "CLAYER", "Table"
    
    On Error Resume Next
    
    Dim pt() As Double
    pt = ThisDrawing.Utility.GetPoint(, "TABLEの挿入位置をクリック:")
    If Err Then
        Set ssetObj = Nothing
        ''画層を元に戻す
        ThisDrawing.SetVariable "CLAYER", CurLyr
        ''図形スナップモードを元に戻す
        ThisDrawing.SetVariable "OSMODE", OSM
        Err.Clear
        On Error GoTo 0
    End If
    
    Dim MyModelSpace As AcadModelSpace
    Set MyModelSpace = ThisDrawing.ModelSpace

    Set MyTable = MyModelSpace.AddTable(pt, 5, 2, 300, 600)
    ''(挿入座標,行数,列数,行の高さ,列の幅)
    Call MyTable.SetAlignment(acDataRow, acMiddleCenter)
    Call MyTable.SetTextHeight(acTitleRow, 100)
    Call MyTable.SetTextHeight(acHeaderRow, 80)
    Call MyTable.SetTextHeight(acDataRow, 80)
    
    Call MyTable.SetCellValue(0, 0, "面積")
    Call MyTable.SetCellValue(1, 0, "NO")
    Call MyTable.SetCellValue(1, 1, "㎡")
    Call MyTable.SetCellValue(4, 0, "合計")

    Set MyModelSpace = Nothing
    
End Sub

Private Sub Chek_LyrName(ByVal LyrName As String, ByVal LyrCol As String)

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

 

以下続く・・・・

 

coffee break

CADのTABLEも、VBAで値の自動入力や抽出ができ、サクッと図面内で完結したい場合は便利です。

今回は、設定値をすべて固定値にしていますので、UserFormで設定し実行するような使い方が現実的です。

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）
◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇