前回の
BricsCAD VBAを使ってみよう[8] Excelとの連携②-2
からの続篇です。
BricsCAD VBAを使ってみよう[6]~[8]では、Excelとの連携を検討しました。
何百何千とデーターを扱う場合ではExcelとの連携は有用ですが、それほどのデーター量でもなく、図面内で表を作成して処理したい場合もあります。
今回は、TABLEの自動作成と、取得した値のTABLEへの自動入力を検討しました。
BricsCAD VBAを使ってみよう[7] Excelとの連携②
のEXCELへの値の入力を、CAD画面のTABLEへの入力にしました。


概要
画層を自動作成します。

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

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

試される場合は、図で左下の四角形が1000㎜角の四角形ですので、似たようなサイズの図形でお試しください。
作図単位は㎜で、面積を㎡に換算しています。

1,面積取得用のVBA

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

【3項目】をサブルーチンにしています。
Sub GetArea_Table()
【画層の有無をチェックし、無ければ作成】
Call Chek_LyrName
【TABLEを取得】
Call Get_table()
【TABLEが無ければ作成】
Call Creat_table()
-BOUNDARYで境界作成
SelectionSetsでREGIONをから面積を取得
TABLEに連番と面積値を入力
End Sub
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
BcadCapt = ThisDrawing.Application.Caption
Dim CurLyr As String, LyrName As String
CurLyr = ThisDrawing.ActiveLayer.Name
LyrName = "Table": LyrCol = "7"
Call Chek_LyrName(LyrName, LyrCol)
LyrName = "SubNumber": LyrCol = "4"
Call Chek_LyrName(LyrName, LyrCol)
LyrName = "CkBoudary": LyrCol = "1"
Call Chek_LyrName(LyrName, LyrCol)
LyrName = "Hatch": LyrCol = "3"
Call Chek_LyrName(LyrName, LyrCol)
OSM = ThisDrawing.GetVariable("OSMODE")
ThisDrawing.SetVariable "OSMODE", 0
Dim ssetObj As AcadSelectionSet
Dim BoundObj As AcadSelectionSet
Call Get_table(SelCnt, ssetObj, MyTable, CurLyr, OSM)
''Boundaryで作成されるオブジェクトタイプをリージョンにする
HPBRet = ThisDrawing.GetVariable("HPBOUNDRETAIN")
ThisDrawing.SetVariable "HPBOUNDRETAIN", 1
HPB = ThisDrawing.GetVariable("HPBOUND")
''0:リージョンを作成 , 1:ポリラインを作成
ThisDrawing.SetVariable "HPBOUND", 0
ThisDrawing.SetVariable "OSMODE", 0
RetVal = MyTable.GetCellValue(i, 0)
''========== 【境界作成で面積値を取得】==============
ThisDrawing.SetVariable "CLAYER", LyrName
pt = ThisDrawing.Utility.GetPoint(, "図形内をクリック:終了ESCキー")
ThisDrawing.SendCommand "_.-BOUNDARY " & vbCr & vbCr & _
pt(0) & "," & pt(1) & vbCr & vbCr
ThisDrawing.SelectionSets("boundobj").Delete
Set BoundObj = ThisDrawing.SelectionSets.Add("boundaryobj")
Set BoundObj = ThisDrawing.SelectionSets.Item("boundaryobj")
Dim FilterType(1) As Integer
Dim FilterData(1) As Variant
''図形を選択セットに格納(フィルタ:画面全体、画層、ラインタイプ)
BoundObj.Select acSelectionSetAll, , , FilterType, FilterData
''境界が作成されなかった場合は図形内クリックに戻す
ObjArea = BoundObj.Item(0).Area
ThisDrawing.SetVariable "CLAYER", LyrName
ThisDrawing.SendCommand "-BHATCH " & "P" & vbCr & "ANSI31" & vbCr & "100" & vbCr _
& "0" & vbCr & pt(0) & "," & pt(1) & vbCr & vbCr
ThisDrawing.SetVariable "CLAYER", LyrName
Set objText = ThisDrawing.ModelSpace.AddText(GetCnt - 1, pt, 100)
objText.Alignment = acAlignmentMiddleCenter
objText.TextAlignmentPoint = pt
If RowsCnt - DataRow < 2 Then
Call MyTable.InsertRows(DataRow, 300, 1)
Call MyTable.SetAlignment(acDataRow, acMiddleCenter)
Call MyTable.SetTextHeight(acDataRow, 80)
Call MyTable.SetCellValue(DataRow, 0, Format(GetCnt - 1))
Call MyTable.SetCellValue(DataRow, 1, Format(ObjArea / 1000000, "0.00"))
Area = MyTable.GetCellValue(i, 1)
TotalArea = TotalArea + Area
Call MyTable.SetCellValue(TotalRow, 1, Format(TotalArea, "0.00"))
ThisDrawing.SetVariable "CLAYER", CurLyr
ThisDrawing.SetVariable "OSMODE", OSM
ThisDrawing.SetVariable "HPBOUNDRETAIN", HPBRet
ThisDrawing.SetVariable "HPBOUND", HPB
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
ThisDrawing.SelectionSets("TableObj").Delete
Set ssetObj = ThisDrawing.SelectionSets.Add("TableObj")
Set ssetObj = ThisDrawing.SelectionSets.Item("TableObj")
FilterData(0) = "ACAD_TABLE"
ssetObj.Select acSelectionSetAll, , , FilterType, FilterData
Call Creat_table(MyTable, ssetObj, CurLyr, OSM)
Set MyTable = ssetObj.Item(0)
Private Sub Creat_table(ByRef MyTable As AcadTable, ByVal ssetObj As AcadSelectionSet, _
ByVal CurLyr As String, ByVal OSM As Integer)
ThisDrawing.SetVariable "CLAYER", "Table"
pt = ThisDrawing.Utility.GetPoint(, "TABLEの挿入位置をクリック:")
ThisDrawing.SetVariable "CLAYER", CurLyr
ThisDrawing.SetVariable "OSMODE", OSM
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
Private Sub Chek_LyrName(ByVal LyrName As String, ByVal LyrCol As String)
Dim NwLayObj As AcadLayer
For Each LayObj In ThisDrawing.Layers
If LayObj.Name = LyrName Then
Set NwLayObj = ThisDrawing.Layers.Add(LyrName)
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
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その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)
◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇