EXCEL读取文档属性速度

followsea · 发表于 2019-11-22 10:49:18

咨询下各位通过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