能否通过swdm实现获取零件外形尺寸

各位社友晚上好，上次论坛有位高人分享了一个非常好用的工具——excel VBA 批量更改solidworks 属性及名字工具
其中读取属性分普通版和高速版两种模式，其中高速版使用的是swdm-api进行操作文件

后来又在论坛搜索到闷大的帖子——在檔案管理而言, SWDM-API 與 SW-API 的分別，闷大在帖中展现的两种处理速度差异非常明显


这个对比非常强有力的展示了SWDM-API的优势，现excel VBA 批量更改solidworks 属性及名字工具中有个工具是读取零件外形尺寸，


我想把原作者的SW-API的方式修改为SWDM-API的方式，不知这种想法是否可以实现，望大家不吝赐教，谢谢各位


以下是模仿读取属性高速版代码修改的打开文件的代码（licenskey在此用xxxx做隐藏），但是到蓝色位置的时，得到Part和SelMgr均为空值


因本人是API小白，仅有一份强烈的好奇心，所以对下面代码的合理性与准确性没什么概念，请大家予以指正

1. Dim swDM As SwDMApplication
   
2. Dim swDoc As SwDMDocument12
   
3. Dim mOpenErrors As SwDmDocumentOpenError
   
4. Dim swCfgMgr As SwDMConfigurationMgr
   
5. Dim objClassfac As SwDMClassFactory
   
6. Dim vCustPropNameArr As Variant
   
7. Const SWDMLicenseKey = "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx<span style="line-height: 1.5;">"</span>

复制代码

接上-------------------------------------
Sub red_XYZ()

On Error Resume Next
Dim SelMgr As Object
Dim Part As Object
Dim FileName As String
Dim ColumnNumber As Integer
Dim PropName As String
Dim cx As Integer
Dim xy As Integer
Dim cz As Integer
Dim cw As Integer
Dim Mx As Integer
Dim nErrors As Long
Dim nWarnings As Long
Dim ix As Double
Dim boolstatus As Long
Dim longstatus As Long

HeaderRow = 2
RowNumber = 3
ColumnNumber = 6
PropName = Cells(HeaderRow, ColumnNumber)
'------------------------------------------------↓检查表头中是否有x、y、z
m_x = Cells(2, 2).End(xlToRight).Column
cx = 0
cy = 0
cz = 0
        While Len(PropName) > 0 '直到读完表头
        If cx > 0 And cy > 0 And cz > 0 Then ColumnNumber = m_x
            If PropName = "外形_L" Then
            cx = ColumnNumber
            End If

            If PropName = "外形_W" Then
            cy = ColumnNumber
            End If
            If PropName = "外形_H" Then
            cz = ColumnNumber
            End If

            If PropName = "规格" Then
            cw = ColumnNumber
            End If

            ColumnNumber = ColumnNumber + 1 '下一栏
            PropName = Cells(HeaderRow, ColumnNumber)

        Wend '回到>直到读完表头
If cx = 0 Then
Cells(2, 2).End(xlToRight).Offset(0, 1) = "外形_L"
cx = Cells(2, 2).End(xlToRight).Column
End If

If cy = 0 Then
Cells(2, 2).End(xlToRight).Offset(0, 1) = "外形_W"
cy = Cells(2, 2).End(xlToRight).Column
End If

If cz = 0 Then
Cells(2, 2).End(xlToRight).Offset(0, 1) = "外形_H"
cz = Cells(2, 2).End(xlToRight).Column
End If
'------------------------------------------------↑检查表头中是否有x、y、z

Set objClassfac = CreateObject("SwDocumentMgr.SwDMClassFactory")
Set swDM = objClassfac.GetApplication(SWDMLicenseKey) '启动SWDM

'Set swApp = CreateObject("SldWorks.Application") '启动SW

RowNumber = HeaderRow + 1
PathName = Cells(RowNumber, 2)  '读取第一个路径的值
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到读完路径栏
FileName = Cells(RowNumber, 3) & "." & Cells(RowNumber, 4)
If UCase(Right(FileName, 3)) = "PRT" Then
Set swDoc = swDM.GetDocument(PathName & FileName, 1, False, mOpenErrors)
'Set Part = swApp.ActiveDoc

' Set swModel = swApp.OpenDoc6(PathName + FileName, 1, 0, "", nErrors, nWarnings)

Set Part = swDoc
Set SelMgr = Part.SelectionManager

'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

If Cells(1, 5) = "1" Then

boolstatus = Part.Extension.SelectByID2("平板型式1", "BODYFEATURE", 0, 0, 0, False, 0, Nothing, 0)
Part.ClearSelection2 True
longstatus = Part.SetBendState(2)
boolstatus = Part.EditRebuild3()
End If
'//////////////

Corners = Part.GetPartBox(True)
Y = Round(Abs(Corners(4) - Corners(1)) * 1000, 1) 'Y
Z = Round(Abs(Corners(5) - Corners(2)) * 1000, 1) 'Z
X = Round(Abs(Corners(3) - Corners(0)) * 1000, 1) 'X

If X < Y Then ix = X: X = Y: Y = ix
If Y < Z Then ix = Y: Y = Z: Z = ix
If X < Y Then ix = X: X = Y: Y = ix
Cells(RowNumber, cx) = X
Cells(RowNumber, cy) = Y
Cells(RowNumber, cz) = Z
If Cells(RowNumber, cw) <> X & "×" & Y & "×" & Z Then Cells(RowNumber, cw) = X & "×" & Y & "×" & Z
swApp.CloseDoc PathName & FileName '关闭工程图
Cells(RowNumber, 2).Select
Cells(RowNumber, 2).Interior.Color = RGB(255, 255, 127)

End If
RowNumber = RowNumber + 1 '下一列
PathName = Cells(RowNumber, 2)
Wend
MsgBox "零件外形尺寸读取完成"

End Sub

找了好久，这个管用吗？试试！谢谢了！