This macro exports all the information into the output text file in the following format:
Option Explicit
Const currentDir As String = "D:\"
' Dim swApp As SldWorks.SldWorks
Sub main()
Dim filePath As String
filePath = currentDir & "abc.txt"
Dim fileNmb As Integer
fileNmb = FreeFile
Open filePath For Output As #fileNmb
Print #fileNmb, "anything"
Close #fileNmb
End Sub
批量读取零件切割清单，将读取到的信息输出到文本文件。
Option Explicit
Const currentDir As String = "D:\崔胜利\凯帝隆\湖北武穴锂宝\solidworks\"
Const matDB As String = "C:/ProgramData/SolidWorks/SOLIDWORKS 2022/自定义材料/凯帝隆.sldmat"
Dim swApp As SldWorks.SldWorks
Dim filePath As String
Dim fileNmb As Integer
Sub main()
Dim fs(155) As String
fs(0) = "e0301-P0321"
fs(1) = "e0301-P0322"
fs(2) = "e0501-P0504"
fs(3) = "e0501-P0505"
fs(4) = "e0502ab-P0507"
fs(5) = "m0202ab-v0201"
fs(6) = "M0205-v0202"
fs(7) = "m0302-r0302"
fs(8) = "m0304-r0303"
fs(9) = "M0306-r0304"
fs(10) = "M0308-v0301ab"
fs(11) = "M0312-v0202"
fs(12) = "M0315a-v0303&04&05&06"
fs(13) = "M0315b-v0303&04&05&06"
fs(14) = "M0318-v0307&08&09&10&11"
fs(15) = "M0402-r0402"
fs(16) = "M0404-v0401"
fs(17) = "M0406-v0403ab"
fs(18) = "M0410-v0404"
fs(19) = "M0415-v0404&e0501"
fs(20) = "M0417-v0405"
fs(21) = "M0419-v0406"
fs(22) = "M0421-v0407&08&e0501"
fs(23) = "P0101ab-v0101ab"
fs(24) = "P0102ab-v0601"
fs(25) = "P0103ab-v0102ab"
fs(26) = "P0104ab-v0602"
fs(27) = "P0105ab-v0103ab"
fs(28) = "P0106ab-v0603"
fs(29) = "p0201a-m0202a"
fs(30) = "p0201b-m0202b"
fs(31) = "P0202-r0203"
fs(32) = "p0203-r0301"
fs(33) = "p0204-M0205"
fs(34) = "P0205-v0202&r0201ab"
fs(35) = "p0301-m0302"
fs(36) = "p0302-m0304"
fs(37) = "p0303-M0306"
fs(38) = "p0304-m0308"
fs(39) = "p0305-M0312"
fs(40) = "P0306-r0308"
fs(41) = "P0307-v0302"
fs(42) = "P0308-v0302&r0309ab"
fs(43) = "p0309a-M0315a"
fs(44) = "p0309b-M0315b"
fs(45) = "P0310-v0303&p0323"
fs(46) = "P0311-v0304&p0323"
fs(47) = "P0312-v0305&r0201ab&r0202ab&r0305&06&07&m0205"
fs(48) = "P0313-r0401"
fs(49) = "P0314a-r0311ab"
fs(50) = "P0314b-r0311cd"
fs(51) = "p0315ab-M0318"
fs(52) = "P0316-v0307&r0310ab"
fs(53) = "P0317-v0308&r0201ab"
fs(54) = "P0318-v0309&e0301&e0501&r0201ab&r0202ab&r0203&r0404&05&06&r0308&m0302&m0205"
fs(55) = "P0319-p0324"
fs(56) = "P0320-p0324"
fs(57) = "P0321-e0301"
fs(58) = "P0322-e0301&r0310ab"
fs(59) = "p0323"
fs(60) = "P0323-m0315ab"
fs(61) = "p0324"
fs(62) = "P0324-m0318"
fs(63) = "p0401-M0402"
fs(64) = "p0402-M0404"
fs(65) = "p0403-M0406"
fs(66) = "p0404-M0410"
fs(67) = "P0405-r0403"
fs(68) = "P0407-v0606"
fs(69) = "p0408-M0415"
fs(70) = "p0409-M0417&r0411"
fs(71) = "p0410-M0419"
fs(72) = "p0411-M0421"
fs(73) = "P0412-r0412"
fs(74) = "P0413-m0415"
fs(75) = "P0414-r0408"
fs(76) = "P0415-r0309ab"
fs(77) = "P0416-r0409"
fs(78) = "P0417-r0410"
fs(79) = "P0418-v0409"
fs(80) = "P0501-r0302"
fs(81) = "P0502-r0303"
fs(82) = "P0503-v0604"
fs(83) = "P0504-e0501"
fs(84) = "P0505-r0504"
fs(85) = "P0506-e0502ab"
fs(86) = "P0507-v0605"
fs(87) = "p0701ab-v0701&m0202a&m0202b&m0205"
fs(88) = "p0702ab-v0701&m0318"
fs(89) = "p0703ab-v0702&m0302&m0304&m0306&m0308&m0312&m0402&m0404&m0406&m0410&m0417&m0419"
fs(90) = "p0901-r0201ab&r0202ab&v0308&e0301&e0501&r0410&r0501&r0502&r0503&v0701&v0702&v0801&v0802&v0803&p0323&p0324&m0421"
fs(91) = "r0201a-p0201a"
fs(92) = "r0201b-p0201b"
fs(93) = "r0201入口集箱"
fs(94) = "r0202ab-P0202"
fs(95) = "r0203-P0204"
fs(96) = "r0301-p0301"
fs(97) = "r0302-p0302"
fs(98) = "r0303-p0303"
fs(99) = "r0304-p0304"
fs(100) = "r0305&06&07-p0305"
fs(101) = "r0308-p0307"
fs(102) = "r0309a-P0309a"
fs(103) = "r0309b-P0309b"
fs(104) = "r0310a-p0314a"
fs(105) = "r0310b-p0314b"
fs(106) = "r0311abcd-P0315ab"
fs(107) = "r0401-P0401"
fs(108) = "r0402-P0402"
fs(109) = "r0403-P0403"
fs(110) = "r0404&05&06-P0404"
fs(111) = "r0407-P0408"
fs(112) = "r0408-P0409"
fs(113) = "r0409-P0410"
fs(114) = "r0410-P0411"
fs(115) = "r0411-P0415"
fs(116) = "r0412-P0418"
fs(117) = "r0501-P0501"
fs(118) = "r0502-P0502"
fs(119) = "r0503-P0503"
fs(120) = "r0504-P0506"
fs(121) = "v0101ab-p0102ab"
fs(122) = "v0102ab-p0104ab"
fs(123) = "v0103ab-p0106ab"
fs(124) = "v0201-p0203"
fs(125) = "v0202-P0205"
fs(126) = "v0301ab-p0306"
fs(127) = "v0302-p0308"
fs(128) = "v0303-p0310"
fs(129) = "v0304-p0311"
fs(130) = "v0305-p0312"
fs(131) = "v0306-p0313"
fs(132) = "v0307-P0316"
fs(133) = "v0308-P0317"
fs(134) = "v0309-P0318"
fs(135) = "v0310-P0319"
fs(136) = "v0311-P0320"
fs(137) = "v0402-P0405"
fs(138) = "v0403ab-P0407"
fs(139) = "v0404-P0412"
fs(140) = "v0405-P0413"
fs(141) = "v0406-P0414"
fs(142) = "v0407-P0416"
fs(143) = "v0408-P0417"
fs(144) = "V0601-r0308&r0310ab"
fs(145) = "V0602-r0309ab"
fs(146) = "V0603-r0201ab&r0203&r0304&r0412"
fs(147) = "V0604-r0401&r0402&r0403"
fs(148) = "V0605-r0309ab&r0407"
fs(149) = "V0606-r0407"
fs(150) = "v0701-p0701ab"
fs(151) = "v0701-p0702ab"
fs(152) = "v0702-p0703ab"
fs(153) = "罐车-p0101ab"
fs(154) = "罐车-p0103ab"
fs(155) = "罐车-p0105ab"
Set swApp = Application.SldWorks
filePath = currentDir & "list.txt"
fileNmb = FreeFile
Open filePath For Output As #fileNmb
Dim i As Integer
Dim filename As String
Print #fileNmb, "零件名" & vbTab & "spec" & vbTab & "mat" & vbTab & "length" & vbTab & "quan"
For i = 0 To UBound(fs)
filename = fs(i)
Call PrintCutListOfFile(filename)
Next
Close #fileNmb
End Sub
Sub PrintCutListOfFile(filename As String)
Dim path As String
path = currentDir & filename & ".SLDPRT"
' Open
Dim swPart As SldWorks.PartDoc
Dim longstatus As Long, longwarnings As Long
Set swPart = swApp.OpenDoc6(path, 1, 0, "", longstatus, longwarnings)
Dim swModel As SldWorks.ModelDoc2
Set swModel = swPart
Dim vCutLists As Variant
vCutLists = GetCutLists(swModel)
Call ColorizeCutLists(vCutLists, filename)
' Close Document
swApp.CloseDoc swPart.GetPathName
Set swPart = Nothing
Set swModel = Nothing
End Sub
Sub ColorizeCutLists(vCutLists As Variant, filename As String)
Dim i As Integer
For i = 0 To UBound(vCutLists)
Dim swCutList As SldWorks.Feature
Set swCutList = vCutLists(i)
Dim swCutListPrpMgr As SldWorks.CustomPropertyManager
Set swCutListPrpMgr = swCutList.CustomPropertyManager
Dim outp As String
outp = GetCutListItemString(swCutListPrpMgr)
Print #fileNmb, filename & vbTab & outp
Next
End Sub
Function GetCutLists(model As SldWorks.ModelDoc2) As Variant
Dim swFeat As SldWorks.Feature
Dim swCutLists() As SldWorks.Feature
Set swFeat = model.FirstFeature
While Not swFeat Is Nothing
If swFeat.GetTypeName2 <> "HistoryFolder" Then
ProcessFeature swFeat, swCutLists
TraverseSubFeatures swFeat, swCutLists
End If
Set swFeat = swFeat.GetNextFeature
Wend
GetCutLists = swCutLists
End Function
Sub TraverseSubFeatures(parentFeat As SldWorks.Feature, cutLists() As SldWorks.Feature)
Dim swChildFeat As SldWorks.Feature
Set swChildFeat = parentFeat.GetFirstSubFeature
While Not swChildFeat Is Nothing
ProcessFeature swChildFeat, cutLists
Set swChildFeat = swChildFeat.GetNextSubFeature()
Wend
End Sub
Sub ProcessFeature(feat As SldWorks.Feature, cutLists() As SldWorks.Feature)
If feat.GetTypeName2() = "SolidBodyFolder" Then
Dim swBodyFolder As SldWorks.BodyFolder
Set swBodyFolder = feat.GetSpecificFeature2
swBodyFolder.UpdateCutList
ElseIf feat.GetTypeName2() = "CutListFolder" Then
If Not Contains(cutLists, feat) Then
If (Not cutLists) = -1 Then
ReDim cutLists(0)
Else
ReDim Preserve cutLists(UBound(cutLists) + 1)
End If
Set cutLists(UBound(cutLists)) = feat
End If
End If
End Sub
Function Contains(arr As Variant, item As Object) As Boolean
Dim i As Integer
For i = 0 To UBound(arr)
If arr(i) Is item Then
Contains = True
Exit Function
End If
Next
Contains = False
End Function
Function GetCutListItemString(srcPrpMgr As SldWorks.CustomPropertyManager) As String
Dim length As String
length = GetProperty(srcPrpMgr, "长度")
Dim spec As String
spec = GetProperty(srcPrpMgr, "DESCRIPTION")
Dim mat As String
mat = GetProperty(srcPrpMgr, "MATERIAL")
Dim quan As String
quan = GetProperty(srcPrpMgr, "QUANTITY")
GetCutListItemString = spec & vbTab & mat & vbTab & length & vbTab & quan
End Function
Function GetProperty(srcPrpMgr As SldWorks.CustomPropertyManager, prpName As String) As String
Dim prpVal As String
Dim prpResVal As String
srcPrpMgr.Get5 prpName, False, prpVal, prpResVal, False
GetProperty = prpResVal
End Function
