VBA线型加载问题

houlinbo

怎样防止线型的重复加载？对我来说很难，谢谢指教！

PS122

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

houlinbo

可以加上说明吗？

PS122

'符号后面的不是说明？老大，你编程吗？

winabcd

2楼的，那个帮助文件中的程序例子你试过没有，运行结果与所给说明好象不一致，而且程序没有完善的出错处理。

mccad

2. Sub Example_Load()
3.        ' 该示例尝试从acad.lin文件中加载 "CENTER" 线型。如果该线型已经存在，则显示提示。
4.       
5.        Dim linetypeName As String
6.        linetypeName = "center"
7.       
8.        ' 从acad.lin文件中加载 "CENTER"线型
9.        On Error Resume Next       ' 捕获任何出错信息
10.        ThisDrawing.Linetypes.Load linetypeName, "acad.lin"
11.       
12.        ' 如果该名称已经存在，则提醒用户
13.        If Err.Number = -2145386405 Then
14.                MsgBox "名称为“" & linetypeName & "”的线型已经存在。", , "明经通道VBA线型加载示例"
15.        End If
16.       
17. End Sub

Sub Example_Load()        ' 该示例尝试从acad.lin文件中加载 "CENTER" 线型。如果该线型已经存在，则显示提示。               Dim linetypeName As String        linetypeName = "center"               ' 从acad.lin文件中加载 "CENTER"线型        On Error Resume Next       ' 捕获任何出错信息        ThisDrawing.Linetypes.Load linetypeName, "acad.lin"               ' 如果该名称已经存在，则提醒用户        If Err.Number = -2145386405 Then                MsgBox "名称为“" & linetypeName & "”的线型已经存在。", , "明经通道VBA线型加载示例"        End If        End Sub

houlinbo

2楼的，你的程序行不通，麻烦你再和mccad老师的对比一下，同样谢谢你！

houlinbo

感谢郑老师

fuday123

''''各位老兄，看看下面的是否合适，以dashed线型为利
Dim i As Integer
Dim dashedlineexist As Boolean '''''判断是否存在的标志，如果存在，就激活为当前的线型，否则就添加该线型

dashedlineexist = False ''''先设定其不存在，如果存在就把它设成true


For i = 0 To ThisDrawing.Linetypes.Count - 1
If ThisDrawing.Linetypes.Item(i).Name = "DASHED" Then
ThisDrawing.ActiveLinetype = ThisDrawing.Linetypes.Item(i)
MsgBox "DASHED线型已经存在"
dashedlineexist = True
End If
Next i


If dashedlineexist = False Then ''''如果不存在就添加

Dim dashedline As AcadLineType
ThisDrawing.Linetypes.Load "DASHED", "acad.lin"
Set dashedline = ThisDrawing.Linetypes.Item(ThisDrawing.Linetypes.Count - 1) ''''找最后一个

ThisDrawing.ActiveLinetype = dashedline End If

兰州人

好帖，在判断图层和线性的装载时，用error比要比用循环实用。