直線とポリラインのみですが、長さを取得する用向きが有りましたので作成しました。

今回もExcelVBAで、WorkSheetをｺﾝﾄﾛｰﾙ画面に使用しています。

計測する線をクリックして、長さの値をExcelに取得していきます。

クリック位置に連番を付けて、Excelに計測値とクリック位置の座標を残します。（確認でスクロールできるようにしようと思っていますが未処理です）

 １，ＶＢＡコードの概要

GetEntityメソッドで取得します。

Call BcadDoc.Utility.GetEntity(objEnt, GetPt, “図形を選択:終了ESC “)
objEnt：選択した図形AcDbPolyline、AcDbLineを返します
GetPt,：ピックボックス選択での座標値（のため図形直上の点ではありません）

今回は、補助連番用のSubNo画層は事前に作成しておきます。
図面作図単位は㎜で、取得した値をｍに換算しています。
線色はbylayerとし、計測済みは線色を変えれるようにしました。

２，長さ計測用のプロシージャ

Option Explicit

''Win32API宣言(64bit)
''スレッドの一時待機
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
''どのキーが押されたのかを取得
Declare PtrSafe Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long
''クラス名またはキャプションタイトルからウィンドウハンドルを取得
Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
    (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
''フォアグラウンドウィンドウのハンドルを取得。
Declare PtrSafe Function GetForegroundWindow Lib "user32" () As Long
''指定されたウィンドウのハンドルからキャプションタイトルを取得。
Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
''指定されたウィンドウを最前面に移動。
Declare PtrSafe Function SetForegroundWindow Lib "user32" (ByVal hwnd As LongPtr) As Long

Sub GetLength()

''NUMLOCK用
Dim WshShell
Set WshShell = CreateObject("WScript.Shell")
''【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, SubNoLyr As String
''補助連番画層名を変数に格納
SubNoLyr = Cells(2, 2).Text
''補助連番文字高を変数に格納
Dim SubNoHi As Long
SubNoHi = Cells(3, 2).Value
''計測後の線色変更
Dim Chcol As Boolean
Chcol = ActiveSheet.CheckBox1.Value
Dim Colno As Integer
Colno = Cells(5, 4).Value
''文字の変数を宣言
Dim objText As AcadText
''図形スナップモードの変数を宣言
Dim OSM As Integer
OSM = BcadDoc.GetVariable("OSMODE")
''クワッドの変数の宣言と値の格納
Dim QDP As Integer
QDP = BcadDoc.GetVariable("QUADDISPLAY")
''RTの変数の宣言と値の格納
Dim RTP As Integer
RTP = BcadDoc.GetVariable("ROLLOVERTIPS")

''現在の画層名を変数に格納
CurLyr = BcadDoc.ActiveLayer.Name

'' BricsCADのキャプションの変数の宣言と値の格納
    Dim BcadCapt As String
    BcadCapt = BcadDoc.Application.Caption
'' Excelのキャプションの変数の宣言と値の格納
    Dim xlApp As String
    xlApp = Excel.Application.Caption
'' Excelのハンドルの変数の宣言と値の格納
    Dim XLhWnd As Long
    XLhWnd = FindWindow(vbNullString, xlApp)

''====================================
''========== 【長さを取得】===========
''====================================

'' 計測カウント用の変数を宣言
Dim GetCnt As Integer
'' カウント開始Noを取得
GetCnt = Cells(6, 2).Text
'' BricsCADの画面をアクティブ
AppActivate BcadCapt
''クワッドを無効にする
BcadDoc.SetVariable "QUADDISPLAY", -1 * QDP
''RTを無効にする
BcadDoc.SetVariable "ROLLOVERTIPS", 0
'' OSMODEを無効にする
'BcadDoc.SetVariable "OSMODE", 0

Dim objEnt As AcadEntity
Dim GetPt As Variant
Dim objLen As Double

Do

On Error Resume Next
Call BcadDoc.Utility.GetEntity(objEnt, GetPt, "図形を選択:終了ESC ")
''ESCキーの場合は終了
If GetAsyncKeyState(vbKeyEscape) Then
        GoTo ErrLine
''図形選択の場合
ElseIf GetPt <> "" Then
    ''直線もしくはポリラインのみ計測
    If objEnt.EntityName = "AcDbLine" Or objEnt.EntityName = "AcDbPolyline" Then
        ''長さを取得
        objLen = objEnt.Length
        ''計測済み図形を色変更する場合
        If Chcol = True Then objEnt.Color = Colno

        ''画層を"SubNo"に変更する
        BcadDoc.SetVariable "CLAYER", SubNoLyr
        ''補助連番を記入する
        Set objText = BcadDoc.ModelSpace.AddText(GetCnt, GetPt, SubNoHi)
        objText.Alignment = acAlignmentMiddleCenter
        objText.TextAlignmentPoint = GetPt

        ''Excelへ面積値を記入する
        Dim DataRow As Integer
        DataRow = GetCnt + 7
        Cells(DataRow, 1).Value = GetCnt
        Cells(DataRow, 2).Value = Format(objLen / 1000)
        Cells(DataRow, 2).NumberFormatLocal = "0.00"
        ''クリックした座標値を残す
        Cells(DataRow, 3).Value = GetPt(0)
        Cells(DataRow, 4).Value = GetPt(1)
        'Cells(DataRow, 5).Value = objEnt.EntityName
        ''計測カウントをカウントアップする
        GetCnt = GetCnt + 1
        Cells(6, 2).Value = GetCnt
    End If
End If

Loop

ErrLine:
    ''画層を元に戻す
        BcadDoc.SetVariable "CLAYER", CurLyr
    ''図形スナップモードを元に戻す
        'BcadDoc.SetVariable "OSMODE", OSM
    ''クワッドの設定を元に戻す
        BcadDoc.SetVariable "QUADDISPLAY", QDP
    ''RTの設定を元に戻す
        BcadDoc.SetVariable "QUADDISPLAY", RTP
    Sleep 300
    ''Excelの画面をアクティブ
        Call BcadActive(WshShell, XLhWnd, xlApp)
        Set WshShell = Nothing
        Err.Clear
        On Error GoTo 0
        Set objText = Nothing
        Set BcadDoc = Nothing
        Set BcadApp = Nothing
        
        Exit Sub

End Sub

Public Function BcadActive(WshShell, XLhWnd As Long, xlApp As String) As Boolean

''フォアグランドのタイトル
    Dim FGtitle As String
''現在フォアグラウンドになっているウィンドウハンドルを取得
    Dim FGHwnd As Long
    FGHwnd = GetForegroundWindow
''フォアグラウンドのタイトルバーテキストを格納
    FGtitle = String(100, Chr(0))
    GetWindowText FGHwnd, FGtitle, Len(FGtitle)
    ''フォアグランドタイトルがExcelではない場合
    If FGtitle <> xlApp Then
        ''フォアグランドタイトルをExcelにする
        SetForegroundWindow (XLhWnd)
        ''「ALT+TAB」キーストロークを送りExcelを最前面にする
        Application.SendKeys "%{tab}", True
        ''NUMLOCK
        WshShell.SendKeys "{NUMLOCK}"
    Else
        AppActivate xlApp
    End If

End Function

Sub DataClear()

If Cells(6, 2).Value > 1 Then
    ''取得データーを全てクリア
    Dim LastDataRow As Long
    LastDataRow = Cells(Rows.Count, 1).End(xlUp).Row
    ActiveSheet.Range(Rows(8), Rows(LastDataRow)).ClearContents
    Cells(6, 2).Value = 1
    Range("A8").Activate
End If
    
End Sub

 

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

GetLengthを長さ計測ボタンに、DataClearをクリアボタンにマクロ登録して使用します。

 

coffee break

Windows10（64bit）からWindows11（64bit）へアップグレードしましたので、現在の作業環境は以下です。
Windows11（64bit）
BricsCAD pro V21（64bit）
Office2019（64bit）

Windows11へのアップグレードは、まだ当分いいかと思っていましたが、いつの間にやらダウンロード済みになり、起動時にアップグレードのキャンセルが分からなく、成り行きで、ごくごくごくっと自然にWindows11へアップグレードされました＞＜；

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

BricsCAD VBAを使ってみよう[14]　Excelとの連携②-7　長さ計測
「Excel VBA to BricsCAD」Get Length

BricsCAD VBAを使ってみよう[15]　Excelとの連携②-8　画層状態ｺﾝﾄﾛｰﾙ
「Excel VBA to BricsCAD」layer contr

以下検討中です。

◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇
「この特集記事の内容につきましては、
こちらの環境のみの検討結果です。
動作保証は出来かねますため、ご参考
資料としてお扱いください。
Windows11（64bit）
BricsCAD pro V21（64bit）
Office2019（64bit）
◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇