Excel 批量修改SW档案属性 (无需 SWDM-API 许可号码)

benrex

难道大佬的中文是那么不济？一再让丹哥误会了。

“换来XX的骂名”，大佬的意思是“给某人谩骂成XX”，而非“给XX谩骂”。
估计大佬是加分最松手、提供教程设限最少，学习门槛最低 的笨蛋，怎么经常被误会曲高和寡、故作神秘呢？




加上丹哥以“点评”查问，大佬只能无奈地以这种方式回答，万分抱歉。

a135798

非也！非也！是我自己没看清楚，以为大佬给人谩骂了~~

谢谢大佬回覆！

d1230456

俺笨熊非常贊同大佬的构想（集中开启和保存），否则Excel里每个按钮指令都会再执行一遍开始及保存。

俺要做这个Excel的起因是：
项目期常常需要出报价单（且时间紧迫），如果手动制作的话，费时费力；
又因为报价单常常需要以下几个关键参数：零件名称，图片，材质，重量，最大外形尺寸，数量等。
所以想修改批量修改属性达到需求。

chikai

谢谢浣熊大说出意图（当然越早说出动机就越好），原来用来辅助报价，而不是单纯用来管理属性，这样问题就出来了，就是读取到的属性值时，应读取『数式』还是『结果』（参见本帖45-56楼）。

以管理属性的角度而言，读取『数式』是必然的，但用来辅助报价，那就必须读取『结果』了，如何兼容诉求？

初步分别有两个构思都可解决的：
1. 编写一个能把註释与值对调的宏，读取属性后，复制到报价单对调一下来解决。
2. 读取属性时，值写到cell，数式写到註释（刚好与现行的相反）；另外数式与值相同就不写到註释，以减少那些刺眼的红色小三角形。

beyond83

   经典案例图书

非常感谢大佬，这么晚还给笨熊出解决方案。辛苦啦……
大佬的两个方案都非常贊，相对来讲，个人更倾向于方案1（还能兼容管理属性的功能）.
因为Excel输出的内容用于报价时，会再行复制相关内容到新的Excel进行适当的编辑，所以对调宏相对来讲可能会更符合其意图。

另：俺笨熊最初的构想是出两个Excel（一个Excel用于输出数值，一个Excel用于输出表达式），或者Excel内做两个按钮指令（一个用于输出数值，一个用于输出表达式），完全属于土法炼钢。还是大佬的方案贴合实际需求。

liubingsh

有劳测试以下“获取属性名称”的代码：
Sub GetPropNames()
Set swApp = CreateObject("SldWorks.Application")
Dim PropList() As String '属性名称阵列
Dim FilePathName As String
Dim i As Integer
HeaderRow = 2 '设定表头列（常数）
RowNumber = HeaderRow + 1 '设定内容开始列（变数）
PathName = Cells(RowNumber, 1) '读取第一个路径的值
ReDim PropList(0)
PropList(0) = "" '避免比对名称时出错
PropLeft = 4 '属性名称左端位置（常数）
PropRight = PropLeft '属性名称右端位置（变数）
PropName = Cells(HeaderRow, PropRight)
While Not (PropName = "" Or PropName = 0 Or IsEmpty(PropName)) '把表中的现有属性名称记录到属性名称阵列
  ReDim Preserve PropList(PropRight - 3)
  PropList(PropRight - 3) = PropName
  PropRight = PropRight + 1 '下一栏
  PropName = Cells(HeaderRow, PropRight)
Wend
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到读完路径栏
  Filename = Cells(RowNumber, 2)
  FileExtname = UCase(Right(Cells(RowNumber, 2), 6))
  If "SLDPRT" = FileExtname Then swFileTYpe = 1
  If "SLDASM" = FileExtname Then swFileTYpe = 2
  If "SLDDRW" = FileExtname Then swFileTYpe = 3
  If "SLDLFP" = FileExtname Then swFileTYpe = 1
  Set swDoc = swApp.OpenDoc(PathName & Filename, swFileTYpe) '开启档案
  If Not swDoc Is Nothing Then '排除无效档案
  swConfigName = Cells(RowNumber, 3)
  vCustPropNameArr = swDoc.GetCustomInfoNames2(swConfigName)
  If TypeName(vCustPropNameArr) = "String()" Then
     For Each vCustPropName In vCustPropNameArr
     inlist = False
     For Each PropItem In PropList '比对名称是否已存在
      If vCustPropName = PropItem Then inlist = True
     Next
     If Not inlist Then '不存在即加入到属性名称阵列
      ReDim Preserve PropList(UBound(PropList) + 1)
      PropList(UBound(PropList)) = vCustPropName
     End If
    Next
  End If
  Cells(RowNumber, 1).Interior.Color = RGB(200, 200, 255)
  swApp.CloseDoc PathName & Filename '关闭档案
  End If  '排除无效档案<完>
  RowNumber = RowNumber + 1 '下一列
  PathName = Cells(RowNumber, 1)
Wend '回到>直到读完路径栏
PropRight = PropLeft '属性名称右端位置（变数）
For i = 1 To UBound(PropList)
  Cells(HeaderRow, PropRight) = PropList(i)
  Cells(HeaderRow, PropRight).Font.Bold = True
  PropRight = PropRight + 1
Next
End Sub

复制代码

szy23344

   经典案例图书

谢谢大佬的代码，试用效果非常完美（可兼顾自定义属性与配置特定属性）。如下图：




PS：正在尝试修改“删除属性”的代码，一步步来，看是否可以成功。……

cky88888888

“删除属性”的代码修改，俺笨熊暂时还搞不定（俺太缺乏编程常识啦，得自行多补补课）。希望各位多多指点下啊。

pme_zl

再次感谢大佬的指点。
首先打开总装（载入到内存，不退出），然后获取名称，读取，写入属性（取消其中关闭档案代码）等，速度明显快很多；

xxl19832002

接续：但是批量图片输出保存的全部都是总装的图片，如下图：



如果关闭总装后，再执行“等轴侧图片”的话，一切正常。
俺笨熊不知道该如何修正这个异常，还望各位指导下啊。谢谢！

l159951

附上俺笨熊根据各位大佬的代码拼凑出的SW-API的批量修改属性。
SW API.xls (107 KB, 下载次数: 94)

2021-10-21 18:48 上传

点击文件名下载附件
下载积分: 金币 -1

其中有以下仍未解决：
1.“删除属性”的按钮不可用。
2.在SW打开总装的前提下，“等轴侧图片”会出现异常。
3.关于属性数值与表达式的对调宏，俺笨熊暂时也搞不定。
虽说俺笨熊的附件问题多多，但一定程度上还是可以辅助工作的。在此感谢各位的指导。
期待改进！

luejiong

试下以下删除属性的代码
Const HeaderRow = 2 '表头列
Const PropLeft = 4 '属性名称左端栏位

Sub DeleteProps()
yn = MsgBox("Once Deleted, those cannot be restored. Continue?", vbYesNo)
If yn <> 6 Then Exit Sub
Set swApp = CreateObject("SldWorks.Application")
RowNumber = HeaderRow + 1
PathName = Cells(RowNumber, 1) & "" '读取第一个路径的值
While Not (PathName = "")'直到读完路径栏
  FileName = Cells(RowNumber, 2)
  FileExtname = UCase(Right(Cells(RowNumber, 2), 6))
  If "SLDPRT" = FileExtname Then swFileTYpe = 1
  If "SLDASM" = FileExtname Then swFileTYpe = 2
  If "SLDDRW" = FileExtname Then swFileTYpe = 3
  If "SLDLFP" = FileExtname Then swFileTYpe = 1
  If Not (swFileTYpe = 3 And FileName = Cells(RowNumber - 1, 2)) Then
  Set swDoc = swApp.OpenDoc(PathName & FileName, swFileTYpe) '开启档案
  ColumnNumber = PropLeft
  PropName = Cells(HeaderRow, ColumnNumber) & ""
  While Not (PropName = "")'直到读完表头
    If Not (Left(PropName, 1) = "$" And Right(PropName, 1) = "$") Then
      swDoc.DeleteCustomInfo2 Cells(RowNumber, 3), PropName
    End If
    ColumnNumber = ColumnNumber + 1 '下一栏
    PropName = Cells(HeaderRow, ColumnNumber)
  Wend '回到>直到读完表头
  Cells(RowNumber, 1).Interior.Color = RGB(255, 50, 50)
  Else
  Cells(RowNumber, 1).Interior.Pattern = xlNoneColor
  End If
  RowNumber = RowNumber + 1 '下一列
  PathName = Cells(RowNumber, 1) & ""
Wend '回到>直到读完路径栏
End Sub

复制代码

haidafxd

谢谢大佬分享代码。此代码试用正常（不过俺笨熊有在后面加了一句“保存零件”的代码）。

sdh99080

在SW API Help中找到visible函数，说明如下：



可俺笨熊还是不知道该如何写这句代码（俺笨熊基础太凄惨啦），

miqian1011

加入QQ群
参与讨论和学习

或扫描二维码加入

这是实体的函数啊。

建议这样改：

在此句以下
Set Part = swApp.OpenDoc(PathName & Filename, 1) '开启零件

加多这2句
Dim swerr As Long
Set Part = swApp.ActivateDoc2(PathName & FileName, True, swerr)

sleepbug

   经典案例图书

跟随浣熊大的脚步, 大佬也修订了一下.

kenken16

加入QQ群
参与讨论和学习

或扫描二维码加入

预览图片会自动跟随栏位宽度做调整

wyjldx

   经典案例图书

增加了5大功能:
1. 删除零件和组合件冗余模型组态
2. 批次修改模型组态名称
3. 批量修改工程图图纸名称
4. 匯入预览图片(无需中继档案)
5. 批次输出多种格式

awdrgyjil

大佬的程式码功能非常完美。制作的图表真漂亮，赏心悦目啊。

jinjinhu

非常赞的新增功能。可否请大佬分享下4与5项新增功能的代码（俺笨熊心痒痒，自己却搞不定。只能做伸手党啦，），谢谢！
4. 匯入预览图片(无需中继档案)
5. 批次输出多种格式