#2
HVB62021-03-04 16:41
回复 楼主 WhistleMan
|
我在CAD中加入了个VB,想要实现一个批量操作,但是一直没成功,麻烦各位老师给看下哪个地方有问题。
只有本站会员才能查看附件,请 登录
代码如下:
程序代码:
Sub ChangeDrawingNumb()
Dim curFileName As String
Dim curFileName1 As String
Dim changeResult As String
Dim objPath As String
Dim objName As String
Dim objBlkName As String
Dim lyName As String
Dim xlApp As Excel.Application
Dim xlsheet As Excel.Worksheet
Dim dwgInfo(0 To 9) As String
Dim i As Integer
Dim h As Integer
Dim xlspath As String
objBlkName = "TUHAO"
curFileName = openfile
curFileName1 = curFileName
n = 0
For i = 1 To Len(curFileName1)
If (Mid$(curFileName1, i, 1) = "\") Then '修改路径
Mid$(curFileName1, i, 1) = "/"
n = i
End If
Next i
xlspath = Left(curFileName1, n)
objPath = Path(xlspath)
UserForm1.show
On Error Resume Next
Set xlApp = GetObject(, "excel. application")
If Err <> 0 Then
Set xlApp = CreateObject("excel. application")
End If
xlApp.Visible = True
xlApp.Workbooks.Open curFileName
If Left(Err.Description, 4) = " 无法找到 " Then
MsgBox Err.Description
End
ElseIf Err.Description = " 应用程序定义或对象定义错误 " Then
xlApp.Workbooks(objName).Activate
End If
Set xlsheet = xlApp.ActiveWorkbook.Worksheets("sheet1")
dwgInfo(0) = xlsheet.Cells(1, 1).Offset(1, 0) 'CAD 文件名初使化
n = 0
h = 0
With xlsheet.Cells(1, 1)
While dwgInfo(0) <> "" 'Len(dwgInfo(0))<= 3
h = h + 1
i = 0
dwgInfo(0) = .Offset(h, i)
For i = 1 To 9
dwgInfo(i) = .Offset(h, i)
Next i
' 匹配文件定义为 驱动器 :\ 目录 \*站号 *.dwg 格式
curFileName = objPath + "*" + dwgInfo(0) + "*.dwg" ' 检查文件 _dwginfo(0) 是否空文件
If dwgInfo(0) <> "" Then ' 检查是否找到指定文件,若找到 则进行查找修改,否则标注无匹配文件
If Len(Dir(curFileName)) > 0 Then
curFileName = objPath + Dir(curFileName) ' 在 cad 中打开 dwg 文件 _ dwginfo(0)
AutoCAD.Documents.Open curFileName ' 修改 TuHao 块值
changeResult = ChangeAtt(objBlkName, dwgInfo(1), dwgInfo(2), dwgInfo(3), dwgInfo(4), dwgInfo(5), dwgInfo(6), dwgInfo(7), dwgInfo(8), dwgInfo(9))
.Offset(h, 10).Value = changeResult
ZoomAll
ThisDrawing.Save
ThisDrawing.Close
n = n + 1
Else
changeResult = " 此目录下没有相匹配的CAD文件"
.Offset(h, 10).Value = changeResult
End If
End If
Wend
End With
MsgBox " 修改图号完毕,您共修改了" & n & " 个图文件"
Set xlsheet = Nothing
Set xlApp = Nothing
End Sub
谢谢各位大佬
[此贴子已经被作者于2021-2-19 22:17编辑过]