| 田草 于 2008-07-17 10:22 AM 发表评论: |
Function ImportWMF(P As String) '输入文件 If Dir(P) <> "" Then '判断文件是否存在 ThisDrawing.Import P, Point3D(0, 0, 0), 2 Else Prompt "程序使用的临时文件不存在,请重新运行程序!" Exit Function End If End Function |
|
| 查看所评论的日志:CAD VBA 输出WMF文件 和导入WMF文件 |
| tiancao1001 于 2008-07-16 02:58 PM 发表评论: |
Sub DeleteMenu() '读取有那些菜单 Dim i As Integer Dim i1 As Integer Dim i2 As Integer Dim index() As Long Dim DataString As String Set FSO = CreateObject("Scripting.FileSystemObject") Set FSO_File = FSO.OpenTextFile(GetPath & "menu.txt", ForReading, True) Do While Not FSO_File.AtEndOfStream DataString = FSO_File.ReadLine i = inStr_n(DataString, ",", index) If i = 0 Then i1 = Val(DataString) ElseIf i = 1 Then DataString = Left(DataString, Len(DataString) - 1) For Each TG In ThisDrawing.Application.MenuGroups For Each T In TG.Toolbars If T.Name = DataString Then T.Delete i2 = i2 + 1 If i2 = i1 Then Exit Do End If Next Next End If Loop FSO_File.Close End Sub |
|
| 查看所评论的日志:ACAD vba CreateMenu2.0 自动生成CAD工具栏 |
| tiancao1001 于 2008-07-15 05:31 PM 发表评论: |
'样条曲线转化为直线(针对上面函数转化后的样条曲线) Sub SPlineToLine() Dim E As AcadEntity Dim L As AcadLine Dim SP As AcadSpline Dim StartP As Variant Dim EndP As Variant For Each E In ThisDrawing.ModelSpace 'DoEvents 'ThisDrawing.Utility.Prompt E.ObjectName If E.ObjectName = "AcDbSpline" Then Set SP = E StartP = SP.GetFitPoint(0) EndP = SP.GetFitPoint(2) Set L = ThisDrawing.ModelSpace.AddLine(StartP, EndP) L.Layer = SP.Layer L.color = SP.color SP.Delete End If Next E End Sub |
|
| 查看所评论的日志:VBA将所有的直线转换成样条曲线 |
| 田草 于 2008-07-15 08:54 AM 发表评论: |
'创建匿名块 Function NiMingKuai(S As String) As String Dim blockObj As AcadBlock Dim n As Long NiMingKuai = S & "_0" Block: For Each blockObj In ThisDrawing.Blocks If blockObj.Name = NiMingKuai Then NiMingKuai = S & "_" & CStr(n) Prompt NiMingKuai n = n + 1 GoTo Block End If Next blockObj End Function |
|
| 查看所评论的日志:Auto CAD vba 怎样 创建匿名块 |
| yc421206 于 2008-07-14 03:09 PM 发表评论: |
Dear SIR: 連結無法下載,可否MAIL至小弟信箱。 |
|
| 查看所评论的日志:Mastering AutoCAD VBA 从入门到精通.pdf 电子版格式 |
| 田草 于 2008-07-12 09:30 AM 发表评论: |
'创建匿名组,没有则创建,有则序号加一 Function NiMingZu(S As String) As String Dim G As AcadGroup Dim n As Long For Each G In ThisDrawing.Groups If Left(G.Name, Len(S)) = S Then n = n + 1 Next NiMingZu = S & n + 1 End Function |
|
| 查看所评论的日志:vba 创建匿名组 |
| 田草 于 2008-07-12 09:23 AM 发表评论: |
'创建匿名块,没有则创建,有则序号加一 Function NiMingKuai(S As String) As String Dim B As AcadBlock Dim n As Long Dim m As Long For Each B In ThisDrawing.Blocks If Left(B.Name, Len(S)) = S Then m = Val(Mid(B.Name, Len(S) + 1)) If n <= m Then n = m + 1 End If Next NiMingKuai = S & n End Function |
|
| 查看所评论的日志:Auto CAD vba 怎样 创建匿名块 |
| tiancao1001 于 2008-07-11 11:38 PM 发表评论: |
Sub Delete_HyperLinks() On Error Resume Next Dim Hyperlinks As AcadHyperlinks Dim Hyperlink As AcadHyperlink Dim Obj As AcadEntity Dim i As Integer Dim j As Long For Each Obj In ThisDrawing.ModelSpace DoEvents Set Hyperlinks = Obj.Hyperlinks MsgBox Hyperlinks.Count i = Hyperlinks.Count For j = 0 To i - 1 Hyperlinks.item(j).Delete Next j Next
End Sub |
|
| 查看所评论的日志:CAD 对象加上超链接 |