各位老师,帮忙给看看是哪里的问题
老师,您好:我在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编辑过]