以前に
BricsCAD VBAを使ってみよう[3] UserFormその２
で検討した、連番【初号機】では、クリック後に連番を描画するため、位置とサイズが事前に確認できず、後で位置をずらす必要が生じる場合が多く操作性が今一でした。
クリックした位置に連番を描画します。
そこで、改訂版の連番【２号機】を検討しました。
マウスカーソルに連番がくっついた状態で、スクロールや拡大縮小して、位置やサイズを目視確認しながら連番の描画位置をクリックします。
Excelとの連携を検討しました、Excel VBA を用いた
BricsCAD VBAを使ってみよう[7] Excelとの連携②
BricsCAD VBAを使ってみよう[8] Excelとの連携②-2
での検討内容を元に、連番の改定版を検討しました。
1，改定の概要
１，連続描画の方法
目視確認しながら連続して任意の位置に図形を描画する手段として、
クリック位置に描画し、その図形を移動するか、COPYBASEしてPASTECLIPすることが考えれます。
結果として、COPYBASEしてPASTECLIPする方法を選択しました。
BricsCAD VBAを使ってみよう[7] Excelとの連携②で用いた方法の、
Do～Loopで、画層「CkBoundary」内に境界が作成されSelectionSetsで「REGION」のオブジェクトのカウントが「0」でない場合（つまりREGIONが作成された場合）はLoopを抜け、境界が作成さない場合はカウントは「0」のままでLoop内としています。終了はESCキーです。・・・・
と同様に、「PASTECLIP」したオブジェクトの有無で判定するようにしました。
繰り返し描画のための座標値は、開始時は画面中央、２回目以降は「PASTECLIP」したオブジェクトの「REGION」を作成しその中心座標を取得します。（常に画面中央でもいいのいですが、ひょっこりはんみたいに出てきますんで・・・）
２，ＶＢＡの選択
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の画面を小さくすれば、十分実用的です。(個人的見解ですが)
２，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内で待機する。
（終了する場合は、ＥＳＣキー）
↓
PASTECLIPされた時、PASTECLIPしたPolyline図形にREGIONを作成し、中心座標を取得する。
この中心座標を次回の作図基点とする。
PASTECLIPしたPolyline図形を削除し、「PASTECLIP」画層内のPolyline図形を空にする
↓
REGIONを削除する。
↓
画層を「Renban」に変更して、Polylineで連番囲い図形を再度描画する。
↓
連番をカウントアップし、ＥＳＣキー終了まで連続描画する。
検討したコードの活用
今回は、〇以外にPolylineで作成する図形で、△・▢・五角・六角形を検討しましたが、この内、特に四角形は、木造・ＲＣ等の建築では結構多用します。
今回のVBAのコードを元に、RECTANGの連続描画を検討しました。
次回は、こちらです。
BricsCAD VBAを使ってみよう[11] Excelとの連携②-4
coffee break
ＶＢＡを用いた自動作図の手段として
①BricsCADVBA、もしくはUserFormを使用
②ExcelVBAのWorkSheet、もしくはUserFormを使用
では、ExcelVBAを使用しWorkSheetで設定する場合が、個人的には触りやすいのですが、検討したコードは、色々と再利用できますので、特にどれかの方法だけでしか使えないないと言うことでもありません。どこかの箇所が、何かのご参考になれば幸いです。
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）
◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇