QQ登录

只需一步,快速开始

登录 立即注册

在EXCEL修改SW零件尺寸-宏的練習

[复制链接]
查看: 584|回复: 5
ryouss 发表于 2019-7-8 09:34:36
參考

capture-8.gif


  1. '~~~~~~~~~~~~~~~~~~ 2019/07/06 V19070601 ~~~
  2. ' 操作:
  3. '   1. 開 EXCEL文件.
  4. '   2. 開 SW零件.
  5. '   3. 執行 ReadSwDimensionInSldPrt().
  6. '   4. 在EXCEL修改尺寸.
  7. '
  8. ' 功能:
  9. '   1. 讀取SW零件的全部尺寸,寫到 Excel.
  10. '   2. 在Excel變動尺寸后,修改SW的零件尺寸.
  11. '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  12.   Dim SwApp As Object
  13.   Dim boolStatus As Boolean
  14.   Dim swFeat As Object ', swSubFeat As Object
  15.   Dim swDispDim As Object, SwDim As Object
  16.   Dim Str
  17.   Dim oDic
  18.   Dim oArr1, oArr2
  19.   
  20. Private Sub ReadSwDimensionInSldPrt()
  21.   '讀取SW的全部尺寸
  22.     Set SwApp = Application.SldWorks
  23.     Set Part = SwApp.ActiveDoc
  24.     Set oDic = CreateObject("Scripting.Dictionary")
  25. '*** Get active sheet in Excel
  26.     Set xl = GetObject(, "Excel.Application")
  27. With xl.ActiveSheet
  28.     Set swFeat = Part.FirstFeature
  29.     kk = 1
  30.     Do While Not swFeat Is Nothing
  31.         Debug.Print "  " + swFeat.Name
  32.         'Set swSubFeat = swFeat.GetFirstSubFeature
  33.         Set swDispDim = swFeat.GetFirstDisplayDimension
  34.         Do While Not swDispDim Is Nothing
  35.             'Set swAnn = swDispDim.GetAnnotation
  36.             Set SwDim = swDispDim.GetDimension
  37.             Str = SwDim.FullName '特徵樹名稱
  38.             oArr = Split(Str, "@")
  39.             Str = oArr(0) & "@" & oArr(1)
  40.             oDic(Str) = SwDim.GetSystemValue2("")
  41.             Set swDispDim = swFeat.GetNextDisplayDimension(swDispDim)
  42.             Debug.Print Str, oDic(Str) ', 符號相當於按Tab鍵
  43.             kk = kk + 1
  44.         Loop
  45.         Set swFeat = swFeat.GetNextFeature
  46.     Loop
  47.     oArr1 = oDic.keys: oArr2 = oDic.Items
  48.     .cells(1, 1) = "Serial number": .cells(1, 2) = "Array staging": .cells(1, 3) = "Dimension name"
  49.     .cells(1, 4) = "Feature name": .cells(1, 5) = "Dimension value"
  50.     For kk = 2 To UBound(oArr1) + 2
  51.         .cells(kk, 1) = kk - 2
  52.         .cells(kk, 2) = "=" & """Arr(""" & " & " & .cells(kk, 1) & " & " & """)="""
  53.         .cells(kk, 3) = "'" & Chr(34) & oArr1(kk - 2) & Chr(34)
  54.         .cells(kk, 4) = Split(oArr1(kk - 2), "@")(1) '(1)僅讀取特徵名
  55.         .cells(kk, 5) = oArr2(kk - 2)
  56.     Next kk
  57. nn = .Range("C65536").End(3).Row 'End(3)==>End(xlUp)
  58. Stop '暫停修改Excel之尺寸後,再按RUN執行鍵
  59. Set Part = SwApp.ActiveDoc
  60. '依據Excel變動值修改到sw零件
  61. For mm = 2 To nn
  62.     Size_name = Mid(.cells(mm, 3), 2, Len(.cells(mm, 3)) - 2)
  63.     Part.Parameter(Size_name).SystemValue = .cells(mm, 5)
  64. Next mm
  65. End With
  66. boolStatus = Part.EditRebuild3()
  67. MsgBox "Part size modification ends" '零件尺寸修改結束
  68. End Sub
复制代码










楼主  ryouss 发表于 2019-7-9 10:02:56
宏在SW的背景執行,也可以直接編寫在EXCEL執行!

capture-9.gif
James924 发表于 2019-7-9 16:23:47
这个本质是尺寸的超链接吗?
楼主  ryouss 发表于 2019-7-9 16:54:15
整個重點就是應用宏,讀取SW零件的全部尺寸,寫到 Excel.
tianma 发表于 2019-7-15 23:00:01
挺好,谢谢分享
http://fans.SolidWorks.com.cn/blog/?387
dubailiu 发表于 2019-9-11 14:30:17
感谢分享!
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

Archiver|手机版|小黑屋|京ICP备11009482号-2  

400 - 818 - 3535 (中国地区咨询电话) | 达索析统(上海)信息技术有限公司北京分公司

京ICP备11009482号-2 | 电话:01065362288

北京市朝阳区建国路79号华贸中心2号写字楼707-709室,邮编:100025

GMT+8, 2019-10-24 03:08 , Processed in 0.149302 second(s), 39 queries .

Copyright © 2002-2018 Dassault Systèmes - All rights reserved

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