咨询下各位通过VBA宏实现读取三维零件.PRT或者装配文件.asm格式的文档获取文档属性和写入文档属性时,涉及多个文档读写时感觉慢,读取59个零件的属性(零件号、名称)用了1分30秒,写入59个零件(零件号)属性用了4分钟,这个速度正常么?
以下是读写的代码:
Sub ReadPrpExcel() '读取文档属性
Set swApp = CreateObject("SldWorks.Application") '启动SW
ReadFilesCount = 0
HeaderRow = 2
RowNumber = HeaderRow + 1
PathName = Cells(RowNumber, 1) '读取第一个路径的值
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到读完路径栏
Filename = Cells(RowNumber, 2)
If UCase(Right(Filename, 3)) = "PRT" Then swFileTYpe = 1
If UCase(Right(Filename, 3)) = "ASM" Then swFileTYpe = 2
If UCase(Right(Filename, 3)) = "DRW" Then swFileTYpe = 3
Set swDoc = Nothing
If Dir(PathName & Filename) <> "" Then
Set swDoc = swApp.OpenDoc(PathName & Filename, swFileTYpe) '开启文档
End If
If Not swDoc Is Nothing Then
ColumnNumber = 4
PropName = Cells(HeaderRow, ColumnNumber)
While Not (PropName = "" Or PropName = 0 Or IsEmpty(PropName)) '直到读完表头
PropValue = swDoc.CustomInfo2("默认", PropName) '获取属性
Sheet1.Cells(RowNumber, ColumnNumber) = PropValue
ColumnNumber = ColumnNumber + 1 '下一栏
PropName = Cells(HeaderRow, ColumnNumber)
Wend '回到>直到读完表头
swApp.CloseDoc PathName & Filename
Cells(RowNumber, 1).Interior.Color = RGB(200, 255, 200)
ReadFilesCount = ReadFilesCount + 1
End If
RowNumber = RowNumber + 1 '下一列
PathName = Cells(RowNumber, 1)
Wend '回到>直到读完路径栏
MsgBox "读取了 " & ReadFilesCount & " 个文档的属性!"
End Sub
Sub WritePrp() '写入文档属性
Set swApp = CreateObject("SldWorks.Application") '启动SW
SavedFilesCount = 0
HeaderRow = 2
RowNumber = 2
RowNumber = HeaderRow + 1
PathName = Cells(RowNumber, 1) '读取第一个路径的值
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到读完路径栏
Filename = Cells(RowNumber, 2)
If UCase(Right(Filename, 3)) = "PRT" Then swFileTYpe = 1
If UCase(Right(Filename, 3)) = "ASM" Then swFileTYpe = 2
If UCase(Right(Filename, 3)) = "DRW" Then swFileTYpe = 3
Set swDoc = Nothing
If Dir(PathName & Filename) <> "" Then
Set swDoc = swApp.OpenDoc(PathName & Filename, swFileTYpe) '开启文档
End If
If Not swDoc Is Nothing Then
ColumnNumber = 4
PropName = Cells(HeaderRow, ColumnNumber)
While Not (PropName = "" Or PropName = 0 Or IsEmpty(PropName)) '直到读完表头
PropValue = Cells(RowNumber, ColumnNumber)
swDoc.DeleteCustomInfo2 "默认", PropName '删除属性
swDoc.AddCustomInfo3 "默认", PropName, 30, PropValue '新增属性
ColumnNumber = ColumnNumber + 1 '下一栏
PropName = Cells(HeaderRow, ColumnNumber)
Wend '回到>直到读完表头
Dim lErrors As Long
Dim lWarnings As Long
SaveOk = swDoc.Save3(1, lErrors, lWarnings)
swApp.CloseDoc PathName & Filename '关闭
If SaveOk Then
Cells(RowNumber, 1).Interior.Color = RGB(255, 255, 127)
SavedFilesCount = SavedFilesCount + 1
End If
End If
RowNumber = RowNumber + 1 '下一列
PathName = Cells(RowNumber, 1)
Wend '回到>直到读完路径栏
MsgBox "更新了 " & SavedFilesCount & " 个文档的属性!"
End Sub
|