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

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

 找回密码
 立即注册

QQ登录

只需一步，快速开始

SolidWorks机械工程师网——最大的SolidWorks学习平台»学习社区 › SolidWorks开发与拓展应用 › SolidWorks二次开发（宏，VBA） › 求助！工程图里零件或装配体的属性写入到工程图自定义属 ...
返回列表 发新帖
查看: 3253|回复: 4
打印 上一主题 下一主题

求助！工程图里零件或装配体的属性写入到工程图自定义属性

  [复制链接]
fl3513

1

主题

71

帖子

359

金币

长老

Rank: 6Rank: 6Rank: 6

积分
1516

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

   经典图书
@wetiuer @Allate 版主
网上找到的宏，有窗体，可不可以改写成没有窗体直接运行的
'Registry Settings import
Public Sub UserForm_Initialize()

Dim stChecked1 As String
stChecked1 = GetSetting("Solidworks", "ropertyRaf", "Description")

If stChecked1 = "true" Then
CheckBox1.Value = True
End If


Dim stChecked2 As String
stChecked2 = GetSetting("Solidworks", "ropertyRaf", "Revision")

If stChecked2 = "true" Then
CheckBox2.Value = True
End If

End Sub

'CheckBox Description
Public Sub CheckBox1_Click()
If CheckBox1.Value = True Then
Call SaveSetting("Solidworks", "ropertyRaf", "Description", "true")
Else
Call SaveSetting("Solidworks", "ropertyRaf", "Description", "false")
End If
End Sub

'Checkbox Revision
Private Sub CheckBox2_Click()
If CheckBox2.Value = True Then
Call SaveSetting("Solidworks", "ropertyRaf", "Revision", "true")
Else
Call SaveSetting("Solidworks", "ropertyRaf", "Revision", "false")
End If
End Sub

'Copy Button
Private Sub Copy_click()
Dim swApp As SldWorks.SldWorks
Dim oDwg As SldWorks.DrawingDoc
Dim swView As SldWorks.View
Dim sName As String
Dim sValue As String
Dim lType As Long
Dim bRetVal As Boolean
Dim strFilename As String
Dim strDoRebuild As String

On Error Resume Next

Set swApp = CreateObject("SldWorks.Application")
Set oDwg = swApp.ActiveDoc
If (oDwg Is Nothing) Or (oDwg.GetType <> swDocDRAWING) Then
        MsgBox "Open a drawing first!.", vbCritical, "SOLIDWORKS"
        Unload PROPERTY
    Exit Sub
End If

Set swView = oDwg.GetFirstView
Set swView = swView.GetNextView
strFilename = swView.ReferencedDocument.GetPathName
If (swView Is Nothing) Then
        MsgBox "lace a view first!.", vbCritical, "SOLIDWORKS"
        Unload PROPERTY
    Exit Sub
End If


If CheckBox1.Value = True Then
sName = "Description"
sValue = swView.ReferencedDocument.CustomInfo2("", sName)
lType = swView.ReferencedDocument.GetCustomInfoType3("", sName)
bRetVal = oDwg.DeleteCustomInfo2("", sName)
bRetVal = oDwg.AddCustomInfo3("", sName, lType, sValue)
Else
End If

If CheckBox2.Value = True Then
sName = "Revision"
sValue = swView.ReferencedDocument.CustomInfo2("", sName)
lType = swView.ReferencedDocument.GetCustomInfoType3("", sName)
bRetVal = oDwg.DeleteCustomInfo2("", sName)
bRetVal = oDwg.AddCustomInfo3("", sName, lType, sValue)
Else
End If

oDwg.ForceRebuild
strDoRebuild = MsgBox("Values copy successfully ", vbOKOnly)

Set swView = Nothing
Set oDwg = Nothing
Set swApp = Nothing


Unload PROPERTY
End Sub

V1.ZIP

（36.37 KB, 下载次数: 145 ）

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

使用道具 举报

beslee

1

主题

28

帖子

176

金币

侠客

Rank: 3Rank: 3Rank: 3

积分
296
QQ
沙发
发表于 2023-4-22 11:55:57 | 只看该作者
亲，插入的时候，用代码格式，就不会出笑脸了
SolidWorks机械工程师网
提示：建议使用谷歌浏览器浏览本网站！如单击这里下载！否则，可能无法下载附件文件！（支持大多数版本的谷歌浏览器，支持360和QQ浏览器的极速模式，即谷歌内核模式，使用IE和Edge浏览器，浏览个别网页以及下载文件时，会误报“***不安全”，此时需要单击“继续访问此不安全站点(不推荐)”才可以继续下载，另外，本网站不含任何不安全的文件，已联系微软公司解决，纯属IE和Edge浏览器误报）
回复 支持 反对

使用道具 举报

fl3513

1

主题

71

帖子

359

金币

长老

Rank: 6Rank: 6Rank: 6

积分
1516

最佳新人活跃会员热心会员宣传达人
板凳
 楼主| 发表于 2023-4-22 12:25:27 | 只看该作者

   经典图书
谢谢，第一次不熟悉，重新发一下
  1. 'Registry Settings import
  2. Public Sub UserForm_Initialize()

  4. Dim stChecked1 As String
  5. stChecked1 = GetSetting("Solidworks", "PropertyRaf", "Description")

  7. If stChecked1 = "true" Then
  8. CheckBox1.Value = True
  9. End If


  12. Dim stChecked2 As String
  13. stChecked2 = GetSetting("Solidworks", "PropertyRaf", "Revision")

  15. If stChecked2 = "true" Then
  16. CheckBox2.Value = True
  17. End If

  19. End Sub

  21. 'CheckBox Description
  22. Public Sub CheckBox1_Click()
  23. If CheckBox1.Value = True Then
  24. Call SaveSetting("Solidworks", "PropertyRaf", "Description", "true")
  25. Else
  26. Call SaveSetting("Solidworks", "PropertyRaf", "Description", "false")
  27. End If
  28. End Sub

  30. 'Checkbox Revision
  31. Private Sub CheckBox2_Click()
  32. If CheckBox2.Value = True Then
  33. Call SaveSetting("Solidworks", "PropertyRaf", "Revision", "true")
  34. Else
  35. Call SaveSetting("Solidworks", "PropertyRaf", "Revision", "false")
  36. End If
  37. End Sub

  39. 'Copy Button
  40. Private Sub Copy_click()
  41. Dim swApp As SldWorks.SldWorks
  42. Dim oDwg As SldWorks.DrawingDoc
  43. Dim swView As SldWorks.View
  44. Dim sName As String
  45. Dim sValue As String
  46. Dim lType As Long
  47. Dim bRetVal As Boolean
  48. Dim strFilename As String
  49. Dim strDoRebuild As String

  51. On Error Resume Next

  53. Set swApp = CreateObject("SldWorks.Application")
  54. Set oDwg = swApp.ActiveDoc
  55. If (oDwg Is Nothing) Or (oDwg.GetType <> swDocDRAWING) Then
  56.         MsgBox "Open a drawing first!.", vbCritical, "SOLIDWORKS"
  57.         Unload PROPERTY
  58.     Exit Sub
  59. End If

  61. Set swView = oDwg.GetFirstView
  62. Set swView = swView.GetNextView
  63. strFilename = swView.ReferencedDocument.GetPathName
  64. If (swView Is Nothing) Then
  65.         MsgBox "Place a view first!.", vbCritical, "SOLIDWORKS"
  66.         Unload PROPERTY
  67.     Exit Sub
  68. End If


  71. If CheckBox1.Value = True Then
  72. sName = "Description"
  73. sValue = swView.ReferencedDocument.CustomInfo2("", sName)
  74. lType = swView.ReferencedDocument.GetCustomInfoType3("", sName)
  75. bRetVal = oDwg.DeleteCustomInfo2("", sName)
  76. bRetVal = oDwg.AddCustomInfo3("", sName, lType, sValue)
  77. Else
  78. End If

  80. If CheckBox2.Value = True Then
  81. sName = "Revision"
  82. sValue = swView.ReferencedDocument.CustomInfo2("", sName)
  83. lType = swView.ReferencedDocument.GetCustomInfoType3("", sName)
  84. bRetVal = oDwg.DeleteCustomInfo2("", sName)
  85. bRetVal = oDwg.AddCustomInfo3("", sName, lType, sValue)
  86. Else
  87. End If

  89. oDwg.ForceRebuild
  90. strDoRebuild = MsgBox("Values copy successfully :)", vbOKOnly)

  92. Set swView = Nothing
  93. Set oDwg = Nothing
  94. Set swApp = Nothing


  97. Unload PROPERTY
  98. End Sub

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

使用道具 举报

fl3513

1

主题

71

帖子

359

金币

长老

Rank: 6Rank: 6Rank: 6

积分
1516

最佳新人活跃会员热心会员宣传达人
地板
 楼主| 发表于 2023-4-22 19:46:59 | 只看该作者
谢谢，第一次发帖，不熟悉
  1. 'Registry Settings import
  2. Public Sub UserForm_Initialize()

  4. Dim stChecked1 As String
  5. stChecked1 = GetSetting("Solidworks", "PropertyRaf", "Description")

  7. If stChecked1 = "true" Then
  8. CheckBox1.Value = True
  9. End If


  12. Dim stChecked2 As String
  13. stChecked2 = GetSetting("Solidworks", "PropertyRaf", "Revision")

  15. If stChecked2 = "true" Then
  16. CheckBox2.Value = True
  17. End If

  19. End Sub

  21. 'CheckBox Description
  22. Public Sub CheckBox1_Click()
  23. If CheckBox1.Value = True Then
  24. Call SaveSetting("Solidworks", "PropertyRaf", "Description", "true")
  25. Else
  26. Call SaveSetting("Solidworks", "PropertyRaf", "Description", "false")
  27. End If
  28. End Sub

  30. 'Checkbox Revision
  31. Private Sub CheckBox2_Click()
  32. If CheckBox2.Value = True Then
  33. Call SaveSetting("Solidworks", "PropertyRaf", "Revision", "true")
  34. Else
  35. Call SaveSetting("Solidworks", "PropertyRaf", "Revision", "false")
  36. End If
  37. End Sub

  39. 'Copy Button
  40. Private Sub Copy_click()
  41. Dim swApp As SldWorks.SldWorks
  42. Dim oDwg As SldWorks.DrawingDoc
  43. Dim swView As SldWorks.View
  44. Dim sName As String
  45. Dim sValue As String
  46. Dim lType As Long
  47. Dim bRetVal As Boolean
  48. Dim strFilename As String
  49. Dim strDoRebuild As String

  51. On Error Resume Next

  53. Set swApp = CreateObject("SldWorks.Application")
  54. Set oDwg = swApp.ActiveDoc
  55. If (oDwg Is Nothing) Or (oDwg.GetType <> swDocDRAWING) Then
  56.         MsgBox "Open a drawing first!.", vbCritical, "SOLIDWORKS"
  57.         Unload PROPERTY
  58.     Exit Sub
  59. End If

  61. Set swView = oDwg.GetFirstView
  62. Set swView = swView.GetNextView
  63. strFilename = swView.ReferencedDocument.GetPathName
  64. If (swView Is Nothing) Then
  65.         MsgBox "Place a view first!.", vbCritical, "SOLIDWORKS"
  66.         Unload PROPERTY
  67.     Exit Sub
  68. End If


  71. If CheckBox1.Value = True Then
  72. sName = "Description"
  73. sValue = swView.ReferencedDocument.CustomInfo2("", sName)
  74. lType = swView.ReferencedDocument.GetCustomInfoType3("", sName)
  75. bRetVal = oDwg.DeleteCustomInfo2("", sName)
  76. bRetVal = oDwg.AddCustomInfo3("", sName, lType, sValue)
  77. Else
  78. End If

  80. If CheckBox2.Value = True Then
  81. sName = "Revision"
  82. sValue = swView.ReferencedDocument.CustomInfo2("", sName)
  83. lType = swView.ReferencedDocument.GetCustomInfoType3("", sName)
  84. bRetVal = oDwg.DeleteCustomInfo2("", sName)
  85. bRetVal = oDwg.AddCustomInfo3("", sName, lType, sValue)
  86. Else
  87. End If

  89. oDwg.ForceRebuild
  90. strDoRebuild = MsgBox("Values copy successfully :)", vbOKOnly)

  92. Set swView = Nothing
  93. Set oDwg = Nothing
  94. Set swApp = Nothing


  97. Unload PROPERTY
  98. End Sub

复制代码


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

使用道具 举报

Ayinyue

4

主题

142

帖子

469

金币

长老

Rank: 6Rank: 6Rank: 6

积分
1495

最佳新人活跃会员热心会员宣传达人灌水之王
5#
发表于 2023-7-6 22:58:48 | 只看该作者

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

使用道具 举报

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

本版积分规则

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

手机版|小黑屋| GMT+8, 2025-7-16 21:09 , Processed in 0.446501 second(s), 24 queries , Memcache On.

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

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

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