加载线型

jLm · 发表于 2004-5-14 12:58:12

谁能告诉我如何将ThisDrawing中的线型表与线型名称的列表或Excel电子表格进行比较，并加载尚未在ThisDrawing中的线型表？我正在处理我的第一个VBA例程，所以你可能不得不为我哑口无言。谢谢

本帖以下内容被隐藏保护；需要你回复后，才能看到！

游客，如果您要查看本帖隐藏内容请回复

Trev · 发表于 2004-5-16 23:52:12

我可能会避开excel或任何外部列表等。你的第一个VBA项目。
以下示例摘自acad开发人员帮助文件。
它的基本功能是:从acad.lin文件中加载特定线型(在本例中为“中心”)。

Sub Example_Load()
    ' This example attempts to load the linetype "CENTER" from
    ' the acad.lin file. If the linetype already exists, then
    ' a message is displayed.
    
    Dim linetypeName As String
    linetypeName = "CENTER"
    
    ' Load "CENTER" line type from acad.lin file
    On Error Resume Next    ' trap any load errors
    ThisDrawing.Linetypes.Load linetypeName, "acad.lin"
    
    ' If the name already exists, then notify user
    If Err.Description = "Duplicate record name" Then
        MsgBox "A line type named '" & linetypeName & "' already exists.", , "Load Example"
    End If
    
End Sub

以下代码将列出当前图形中加载的所有线型。
但是，没有办法知道当前/默认的线型文件是什么。
(至少据我所知没有，或者至少有一堆代码来比较线型结构和线型文件等。等等。等等等等。除非真的需要。)
当前图形中的线型列表将放入名为ListBox1的列表框中。因此，您需要创建一个具有该名称的listbaox的表单，或者更改为您选择的名称。

copy

 
Sub ListLinetypes()
    Dim objLinetype As AcadLineType
    Dim iCounter As Integer
    Dim i As Variant
    Dim MyList() As String
    iCounter = 0
    For Each objLinetype In ThisDrawing.Linetypes
'   check if linetype comes from an xref linetype name will contain "|"
        If InStrRev(objLinetype.Name, "|") = 0 Then
            ReDim Preserve MyList(iCounter)
            MyList(iCounter) = objLinetype.Name
            iCounter = iCounter + 1
        End If
    Next
'   sort list order, calls the SortArray function
    SortArray MyList
'   put the sorted list in the ListBox
    For i = LBound(MyList) To UBound(MyList)
        ListBox1.AddItem MyList(i)
    Next
End Sub

以下代码用于对列表进行排序。
将代码放入模块中。

copy


Option Explicit
'begin array sort
Public Sub SortArray(StringArray() As String)
    Dim loopOuter As Integer
    Dim loopInner As Integer
    Dim i As Integer
    For loopOuter = UBound(StringArray) To _
      LBound(StringArray) Step -1
        For loopInner = 0 To loopOuter - 1
            If UCase(StringArray(loopInner)) > _
              UCase(StringArray(loopInner + 1)) Then
                Swap StringArray(loopInner), _
                  StringArray(loopInner + 1)
            End If
        Next loopInner
    Next loopOuter
End Sub
Private Sub Swap(a As String, b As String)
    Dim c As String: c = a: a = b: b = c
End Sub
'End array sort

因此，您可能想尝试的基本任务是。
创建包含2个列表框的窗体。其中一个可以包含图形中当前加载的所有线型。第二个列表框可以包含选定线型文件中可用的线型列表。
为简单起见，您可能希望在默认线型文件中编码。
然后添加一个按钮，以从可用列表中加载要加载到图形中的选定线型。则该线型应出现在当前线型列表中。
接下来，您可能希望添加另一个按钮，打开“选择文件”对话框，浏览并选择您选择的线型文件。
希望一切都有意义，都有好处。

加载线型

发表回复

精选推荐