1

図面内のブロックを数えるために、Autocad で VBA を使用しています。インターネットを介したいくつかの検索といくつかの試行により、次のコードを完成させ、任意の図面内のすべてのブロック、またはレイヤーまたは選択したブロックをカウントすることができました。

 Sub BlockCount_Test()
    dispBlockCount "COUNT_ALL"
    dispBlockCount "COUNT_BY_LAYER"
    dispBlockCount "COUNT_BY_FILTER"
End Sub
Sub dispBlockCount(ByVal strAction As String)
On Error Resume Next
Dim objBlkSet As AcadSelectionSet
Dim objBlkRef As AcadBlockReference
Dim strBlkNames() As String
Dim iGpCode(0) As Integer
Dim vDataVal(0) As Variant
Dim iSelMode As Integer
Dim iBlkCnt As Integer
iGpCode(0) = 0
vDataVal(0) = "INSERT"
iSelMode = 0  '|-- Selection Modes (0 = Select All, 1 = Select On Screen) --|
Set objBlkSet = getSelSet(iGpCode, vDataVal, iSelMode)
If objBlkSet.Count <> 0 Then
Select Case strAction
Case "COUNT_ALL"
    ReDim strBlkNames(objBlkSet.Count - 1)
    iBlkCnt = 0
    For Each objBlkRef In objBlkSet
        strBlkNames(iBlkCnt) = objBlkRef.Name
        iBlkCnt = iBlkCnt + 1
    Next
    MsgBox getUniqBlockCount(strBlkNames), , "Count All"
Case "COUNT_BY_LAYER"
    Dim objCadEnt As AcadEntity
    Dim vBasePnt As Variant
    ThisDrawing.Utility.GetEntity objCadEnt, vBasePnt, "Pick a block reference:"
    If Err.Number <> 0 Then
        MsgBox "No block references selected."
        objBlkSet.Delete
        Exit Sub
    Else
        If objCadEnt.ObjectName = "AcDbBlockReference" Then
            Dim objCurBlkRef As AcadBlockReference
            Dim strLyrName As String
            iBlkCnt = 0
            Set objCurBlkRef = objCadEnt
            strLyrName = objCurBlkRef.Layer
            For Each objBlkRef In objBlkSet
                If StrComp(objBlkRef.Layer, strLyrName, vbTextCompare) = 0 Then
                    ReDim Preserve strBlkNames(iBlkCnt)
                    strBlkNames(iBlkCnt) = objBlkRef.Name
                    iBlkCnt = iBlkCnt + 1
                End If
            Next
           MsgBox getUniqBlockCount(strBlkNames), , "Count by Layer"
        Else
            ThisDrawing.Utility.prompt "The selected object is not a block reference."
        End If
    End If
Case "COUNT_BY_FILTER"
    Dim strFilter As String
    iBlkCnt = 0
    strFilter = ThisDrawing.Utility.GetString(False, "Enter a filter option:")
    If strFilter <> "" Then
        For Each objBlkRef In objBlkSet
            If UCase(objBlkRef.Name) Like UCase(strFilter) Then
                ReDim Preserve strBlkNames(iBlkCnt)
                strBlkNames(iBlkCnt) = objBlkRef.Name
                iBlkCnt = iBlkCnt + 1
            End If
        Next
        MsgBox getUniqBlockCount(strBlkNames), , "Count by Filter"
    Else
        ThisDrawing.Utility.prompt "Search criteria should not be empty."
    End If
Case Else
    ThisDrawing.Utility.prompt "Invalid action mode."
End Select
Else
    ThisDrawing.Utility.prompt "No block references were found."
End If
objBlkSet.Delete
If Err.Number <> 0 Then
    ThisDrawing.Utility.prompt Err.Description
End If
End Sub

Function getSelSet(ByRef iGpCode() As Integer, vDataVal As Variant, iSelMode As Integer) As AcadSelectionSet
Dim objSSet As AcadSelectionSet
Set objSSet = ThisDrawing.SelectionSets.Add("EntSet")
Select Case iSelMode
Case 0
    objSSet.Select acSelectionSetAll, , , iGpCode, vDataVal
Case 1
ReSelect:
    objSSet.SelectOnScreen iGpCode, vDataVal
    If objSSet.Count = 0 Then
        Dim iURep As Integer
        iURep = MsgBox("No entities selected, Do you want to select again?", _
        vbYesNo, "Select Entity")
        If iURep = 6 Then GoTo ReSelect
        objSSet.Delete
        Set getSelSet = Nothing
        Exit Function
    End If
Case Else
    ThisDrawing.Utility.prompt "Invalid selection mode...."
End Select
Set getSelSet = objSSet
End Function

Function getUniqBlockCount(ByRef strBlkNames() As String) As String
Dim strUniqBlkNames() As String
Dim iBlkCount() As Integer
Dim iArIdx1, iArIdx2 As Integer
iArIdx1 = 0: iArIdx2 = 0
For iArIdx1 = LBound(strBlkNames) To UBound(strBlkNames)
    If iArIdx1 = 0 Then
        ReDim strUniqBlkNames(iArIdx2)
        strUniqBlkNames(iArIdx2) = strBlkNames(iArIdx1)
        iArIdx2 = iArIdx2 + 1
    End If
    Dim iUnqArIdx As Integer
    Dim blUniq As Boolean
    blUniq = True
    For iUnqArIdx = LBound(strUniqBlkNames) To UBound(strUniqBlkNames)
        If StrComp(strBlkNames(iArIdx1), strUniqBlkNames(iUnqArIdx), vbTextCompare) = 0 Then
            blUniq = False
            Exit For
        End If
    Next
    If blUniq Then
        ReDim Preserve strUniqBlkNames(iArIdx2)
        strUniqBlkNames(iArIdx2) = strBlkNames(iArIdx1)
        iArIdx2 = iArIdx2 + 1
    End If
Next
iArIdx1 = 0: iArIdx2 = 0
For iArIdx1 = LBound(strUniqBlkNames) To UBound(strUniqBlkNames)
    For iArIdx2 = LBound(strBlkNames) To UBound(strBlkNames)
        If StrComp(strBlkNames(iArIdx2), strUniqBlkNames(iArIdx1), vbTextCompare) = 0 Then
            ReDim Preserve iBlkCount(iArIdx1)
            iBlkCount(iArIdx1) = iBlkCount(iArIdx1) + 1
        End If
    Next
Next
For iUnqArIdx = LBound(iBlkCount) To UBound(iBlkCount)
    strUniqBlkNames(iUnqArIdx) = strUniqBlkNames(iUnqArIdx) & vbTab & vbTab & vbTab & iBlkCount(iUnqArIdx) & vbCrLf
Next
Dim strTitle, strBlkCount As String
strBlkCount = Join(strUniqBlkNames)
strTitle = "Block Name" & vbTab & vbTab & "Count" & vbCrLf
strTitle = strTitle & String(14, "-") & vbTab & vbTab & String(8, "-") & vbCrLf
getUniqBlockCount = strTitle & strBlkCount
End Function

私の目的は、これらのブロック番号を取得し、Excel シートと特定のシートとセルに自動的に挿入することです。誰かがこの問題の解決策を見つけるのを手伝ってくれますか? どうにかしてExcelシートを呼び出すことができましたが、現在、ブロック数を正しい位置に配置する方法がわかりません。つまり、コード内のカウントから取得したテーブルに表示されるように、それらをリストに入れたいとしましょう。どうすればこれを達成できますか?

PS私はここにいるのは初めてです。さらに情報が必要な場合は、解決策を見つけるために必要な情報を喜んで追加します.

よろしくお願いしますジョージア

4

2 に答える 2

2

私自身はAutoCadVBAを使用していませんが、質問の単純な性質に基づいて、これは外出先で役立つ可能性があると思います。

新しいExcelアプリケーションを作成する場合：

Dim oApp_Excel as Excel.Application
Dim oBook as Excel.workbook

Set oApp_Excel = CreateObject("EXCEL.APPLICATION")
set oBook = oApp_Excel.workbooks.add

oBook.sheets("<Name>").cells(<Counter>, <Column_Number>).value = <BlockNr (based on counter)> 
oBook.SaveAs(<Path>) 
oBook.close
oApp_Excel.quit

set oBook = nothing

値は任意のセルまたはフォームに配置できます。これらはExcelVBAの基本です。もう1つの方法は、最初に（現在のコードで）配列にBlockNumbersをロードしてから、値を入力することです。このようにして、範囲を動的に設定し、配列から範囲にすべてのデータを一度にロードできます。私があなたの質問を誤解しなかったこと、そして私の返事があなたの目的に役立つことを願っています。

于 2012-06-27T09:00:35.297 に答える
1

'新しい Excel インスタンスを作成します。ExcelApp = CreateObject("Excel.Application") を設定します。

If err <> 0 Then
    MsgBox "Could not start Excel!", vbExclamation, "Warning"
    End
Else
    excelApp.Visible = True
    excelApp.ScreenUpdating = False

    'Add a new workbook and set the objects.
    Set wkbObj = excelApp.Workbooks.Add(1)
    Set shtObj = excelApp.Worksheets(1)

    shtObj.Name = "Measured Polylines"

    With shtObj.Range("A1:D1")
        .Font.Bold = True
        .Autofilter
    End With
于 2015-02-17T05:44:15.187 に答える