设为首页收藏本站
开启辅助访问 切换到宽版

SolidWorks机械工程师网——最大的SolidWorks学习平台

 找回密码
 立即注册

QQ登录

只需一步，快速开始

SolidWorks机械工程师网——最大的SolidWorks学习平台»学习社区 › SolidWorks开发与拓展应用 › SolidWorks二次开发（宏，VBA） › 宏添加自定义属性 日期时间 代码不能运行
返回列表 发新帖
查看: 5193|回复: 8
打印 上一主题 下一主题

宏添加自定义属性 日期时间 代码不能运行

  [复制链接]
dyb9166

3

主题

40

帖子

56

金币

侠客

Rank: 3Rank: 3Rank: 3

积分
364

最佳新人活跃会员宣传达人
跳转到指定楼层
楼主
 楼主| 发表于 2023-4-27 08:55:24 | 只看该作者 |只看大图 回帖奖励 |倒序浏览 |阅读模式

   经典图书
如图，求大神指点，，如何能跑起来

无标题.png
分享到:  QQ好友和群QQ好友和群 QQ空间QQ空间 腾讯微博腾讯微博 腾讯朋友腾讯朋友
收藏收藏2 转播转播 分享教程|习题|模型|技巧 点赞点赞 拍砖拍砖
SolidWorks机械工程师网
提示：建议使用谷歌浏览器浏览本网站！如单击这里下载！否则，可能无法下载附件文件！（支持大多数版本的谷歌浏览器，支持360和QQ浏览器的极速模式，即谷歌内核模式，使用IE和Edge浏览器，浏览个别网页以及下载文件时，会误报“***不安全”，此时需要单击“继续访问此不安全站点(不推荐)”才可以继续下载，另外，本网站不含任何不安全的文件，已联系微软公司解决，纯属IE和Edge浏览器误报）
回复

使用道具 举报

dyb9166

3

主题

40

帖子

56

金币

侠客

Rank: 3Rank: 3Rank: 3

积分
364

最佳新人活跃会员宣传达人
推荐
 楼主| 发表于 2023-4-28 09:05:56 | 只看该作者
tg000057 发表于 2023-4-27 22:14
把引号改号改成chr(34)试下，另外，提示下：
上图不如上代码，直接把代码复制出来测试的应该有不少人做， ...

Dim swApp As Object
Sub main()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim Part As SldWorks.PartDoc
Dim vCustInfoNameArr2, vCustInfoName2 As Variant
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set Part = swModel

'删除所有属性
vCustInfoNameArr2 = swModel.GetCustomInfoNames
If Not IsEmpty(vCustInfoNameArr2) Then
For Each vCustInfoName2 In vCustInfoNameArr2
swModel.DeleteCustomInfo vCustInfoName2
Next
End If
CurCFGname = Part.GetConfigurationNames
CurCFGnameCount = Part.GetConfigurationCount
For i = 0 To CurCFGnameCount - 1
Set CusPropMgr = Part.Extension.CustomPropertyManager(CurCFGname(i))
Vnamearr = CusPropMgr.GetNames
If Not IsEmpty(Vnamearr) Then
For Each Vnamearr2 In Vnamearr
Part.DeleteCustomInfo2 CurCFGname(i), Vnamearr2
Next
End If
Next

'设置单位为"自定义"
    swModel.Extension.SetUserPreferenceInteger 263, 0, 4        '设置单位为"自定"
    swModel.Extension.SetUserPreferenceInteger 259, 0, 3        '最后一个值，1毫克，2克，3千克，4镑
    swModel.Extension.SetUserPreferenceInteger 258, 0, 2        '长度
    swModel.Extension.SetUserPreferenceInteger 260, 0, 6        '体积
    swModel.ClearSelection2 True
    swModel.Save '存档




'展开长宽
Dim swFeature As SldWorks.Feature
Dim FeatName As String
Dim FeatType As String
Set swFeature = swModel.FirstFeature
While Not swFeature Is Nothing '遍历零件FeatureManager并获取特征和属性
FeatName = swFeature.Name '获取特征名称
FeatType = swFeature.GetTypeName '获取特征属性
If FeatType = "CutListFolder" Then
swFeature.Name = "切割清单项目" '修改名称
End If
Set swFeature = swFeature.GetNextFeature
Wend
'swModel.AddCustomInfo3 "", "长", swCustomInfoText, """SW-边界框长度@@@切割清单项目@零件.SLDPRT""" 'VB语法，两个引号组成一个引号
'swModel.AddCustomInfo3 "", "宽", swCustomInfoText, """SW-边界框宽度@@@切割清单项目@零件.SLDPRT"""

'图号分离
swApp.ActiveDoc.ActiveView.FrameState = 1
Set CurCFG = Part.GetActiveConfiguration()
ConfName = CurCFG.Name
Name = swApp.ActiveDoc.GetTitle()
c = Replace(Name, " ", "")
b = Len(c)
e = Right(c, 7)
If e = ".SLDPRT" Or e = ".SLDASM" Or e = ".sldprt" Or e = ".sldasm" Then
f = Left(c, b - 7)
Else
f = c
End If
k = Len(f)
kk = LenB(StrConv(f, vbFromUnicode))
If k = kk Then '纯数字的情况
s = ""
t = f
Else
If kk / k = 2 Then  '纯汉字的情况
t = ""
s = f
Else
For i = 1 To k
If Asc(Mid$(f, i, 1)) < 0 Then
w = i '确定第一个汉字的位置
Exit For
End If
Next
If w = 1 Then                '名称+代号的情况
s = Left(f, kk - k)
t = Right(f, k - (kk - k))
Else                         '代号+名称的情况
s = Right(f, k - w + 1)
t = Left(f, w - 1)
End If
End If
End If
'swModel.AddCustomInfo3 "", "图号", swCustomInfoText, t
'swModel.AddCustomInfo3 "", "名称", swCustomInfoText, s

'删除以下值
blnretval = swModel.DeleteCustomInfo2("", "成型规格")
blnretval = swModel.DeleteCustomInfo2("", "材质")
blnretval = swModel.DeleteCustomInfo2("", "钣金厚度")
blnretval = swModel.DeleteCustomInfo2("", "质量")
blnretval = swModel.DeleteCustomInfo2("", "体积")
blnretval = swModel.DeleteCustomInfo2("", "表面积")
blnretval = swModel.DeleteCustomInfo2("", "表面处理")
blnretval = swModel.DeleteCustomInfo2("", "数量")
blnretval = swModel.DeleteCustomInfo2("", "工序1")
blnretval = swModel.DeleteCustomInfo2("", "工序2")
blnretval = swModel.DeleteCustomInfo2("", "工序3")
blnretval = swModel.DeleteCustomInfo2("", "工序4")
blnretval = swModel.DeleteCustomInfo2("", "工序5")
blnretval = swModel.DeleteCustomInfo2("", "备注")
blnretval = swModel.DeleteCustomInfo2("", "折弯半径")
blnretval = swModel.DeleteCustomInfo2("", "K因子")
blnretval = swModel.DeleteCustomInfo2("", "型材长度")

'设置属性,赋默认值
swModel.AddCustomInfo3 "", "图号", swCustomInfoText, t
swModel.AddCustomInfo3 "", "名称", swCustomInfoText, s
blnretval = swModel.AddCustomInfo3("", "材质", swCustomInfoText, """SW-Material""")
blnretval = swModel.AddCustomInfo3("", "钣金厚度", swCustomInfoText, """厚度@钣金""")
blnretval = swModel.AddCustomInfo3("", "质量", swCustomInfoText, """SW-Mass""")
blnretval = swModel.AddCustomInfo3("", "体积", swCustomInfoText, """SW-Volume""")
blnretval = swModel.AddCustomInfo3("", "表面积", swCustomInfoText, """SW-SurfaceArea""")
blnretval = swModel.AddCustomInfo3("", "表面处理", swCustomInfoText, "")
blnretval = swModel.AddCustomInfo3("", "数量", swCustomInfoText, "1")
blnretval = swModel.AddCustomInfo3("", "工序1", swCustomInfoText, "2D激光")
blnretval = swModel.AddCustomInfo3("", "工序2", swCustomInfoText, "折弯")
blnretval = swModel.AddCustomInfo3("", "工序3", swCustomInfoText, "氩焊")
blnretval = swModel.AddCustomInfo3("", "工序4", swCustomInfoText, "")
blnretval = swModel.AddCustomInfo3("", "工序5", swCustomInfoText, "")
blnretval = swModel.AddCustomInfo3("", "备注", swCustomInfoText, "")
blnretval = swModel.AddCustomInfo3("", "折弯半径", swCustomInfoText, """D1@钣金""")
blnretval = swModel.AddCustomInfo3("", "K因子", swCustomInfoText, """D2@钣金""")
swModel.AddCustomInfo3 "", "展开长", swCustomInfoText, """SW-边界框长度@@@切割清单项目@零件.SLDPRT"""
swModel.AddCustomInfo3 "", "展开宽", swCustomInfoText, """SW-边界框宽度@@@切割清单项目@零件.SLDPRT"""
blnretval = swModel.AddCustomInfo3("", "型材长度", swCustomInfoText, "")
blnretval = swModel.AddCustomInfo3("", "设计", swCustomInfoText, "段永波")
blnretval = swModel.AddCustomInfo3("", "制图", swCustomInfoText, "段永波")
blnretval = swModel.AddCustomInfo3("", "设计日期", swCustomInfoText, """SW-Created Date""")
blnretval = swModel.AddCustomInfo3("", "绘图日期", swCustomInfoText, "$PRP:SW-Last Saved Date")


Part.EditRebuild3
swModel.Save
Set swApp = Application.SldWorks
End Sub
SolidWorks机械工程师网
提示：建议使用谷歌浏览器浏览本网站！如单击这里下载！否则，可能无法下载附件文件！（支持大多数版本的谷歌浏览器，支持360和QQ浏览器的极速模式，即谷歌内核模式，使用IE和Edge浏览器，浏览个别网页以及下载文件时，会误报“***不安全”，此时需要单击“继续访问此不安全站点(不推荐)”才可以继续下载，另外，本网站不含任何不安全的文件，已联系微软公司解决，纯属IE和Edge浏览器误报）
回复 支持 1 反对 0

使用道具 举报

jwsjws

2

主题

26

帖子

236

金币

侠客

Rank: 3Rank: 3Rank: 3

积分
385
QQ
板凳
发表于 2023-4-27 10:28:35 | 只看该作者

   经典图书
顶一下，坐等高手！
SolidWorks机械工程师网
回复 支持 反对

使用道具 举报

wjbg2019

9

主题

331

帖子

729

金币

VIP特别用户组

Rank: 30Rank: 30Rank: 30Rank: 30Rank: 30Rank: 30

积分
3524

最佳新人活跃会员热心会员宣传达人灌水之王突出贡献
地板
发表于 2023-4-27 15:28:24 | 只看该作者
strcrd = Chr(36) + "PRP" + Chr(58) + Chr(34) + "SW-Created Date" + Chr(34) '创建日期
strlsd = Chr(36) + "PRP" + Chr(58) + Chr(34) + "SW-Last Saved Date" + Chr(34) '最后保存日期
strlsb = Chr(36) + "PRP" + Chr(58) + Chr(34) + "SW-Last Saved By" + Chr(34) '最后保存人员
你可以参考这个，代码中不能出现  $   (给我几个金币！！！)

评分

参与人数 1威望 +2 金币 +10 贡献 +2 收起 理由
Allate + 2 + 10 + 2 代码中应该能出现$，关键是引号需要转义

查看全部评分

SolidWorks机械工程师网
回复 支持 反对

使用道具 举报

wjbg2019

9

主题

331

帖子

729

金币

VIP特别用户组

Rank: 30Rank: 30Rank: 30Rank: 30Rank: 30Rank: 30

积分
3524

最佳新人活跃会员热心会员宣传达人灌水之王突出贡献
5#
发表于 2023-4-27 15:30:09 | 只看该作者

   经典案例图书
还有，下次直接发代码，不要发图片，打字很累的！！！！
SolidWorks机械工程师网
回复 支持 反对

使用道具 举报

tg000057

40

主题

389

帖子

4435

金币

传奇

Rank: 8Rank: 8

积分
10281

最佳新人活跃会员热心会员宣传达人灌水之王突出贡献
6#
发表于 2023-4-27 22:14:52 | 只看该作者
把引号改号改成chr(34)试下，另外，提示下：
上图不如上代码，直接把代码复制出来测试的应该有不少人做，但是对图片敲代码出来测试的，估计不多！
SolidWorks机械工程师网
回复 支持 反对

使用道具 举报

pp6913

2

主题

33

帖子

209

金币

侠客

Rank: 3Rank: 3Rank: 3

积分
340
QQ
7#
发表于 2023-4-29 11:56:40 | 只看该作者

   经典案例图书
SolidWorks机械工程师网，顶一下。
SolidWorks机械工程师网
回复 支持 反对

使用道具 举报

沧州钣金制造商

1

主题

20

帖子

146

金币

侠客

Rank: 3Rank: 3Rank: 3

积分
268

最佳新人活跃会员宣传达人
8#
发表于 2023-10-4 02:38:35 | 只看该作者
dyb9166 发表于 2023-4-28 09:05
Dim swApp As Object
Sub main()
Dim swApp As SldWorks.SldWorks

问题是否解决  
SolidWorks机械工程师网
回复 支持 反对

使用道具 举报

rex2023

0

主题

136

帖子

135

金币

堂主

Rank: 4

积分
563

最佳新人活跃会员热心会员宣传达人灌水之王
9#
发表于 2023-10-9 11:52:05 | 只看该作者
SolidWorks机械工程师网，顶一下。
SolidWorks机械工程师网
回复 支持 反对

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

SOLIDWORKS 2023 机械设计从入门到精通

手机版|小黑屋| GMT+8, 2025-7-19 03:38 , Processed in 0.311132 second(s), 26 queries , Memcache On.

SolidWorks机械工程师网 ( 鲁ICP备14025122号-2 ) 鲁公网安备 37028502190335号

声明：本网言论纯属发表者个人意见，与本网立场无关。
如涉版权，可发邮件： admin@swbbsc.com

快速回复 返回顶部 返回列表