-
Notifications
You must be signed in to change notification settings - Fork 0
/
Assem 2 DXF v3.txt
627 lines (419 loc) · 19.9 KB
/
Assem 2 DXF v3.txt
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
Enum SheetMetalOptions_e
ExportFlatPatternGeometry = 1
IncludeHiddenEdges = 2
ExportBendLines = 4
IncludeSketches = 8
MergeCoplanarFaces = 16
ExportLibraryFeatures = 32
ExportFormingTools = 64
ExportBoundingBox = 2048
End Enum
Const SKIP_EXISTING_FILES As Boolean = False
Const OUT_NAME_TEMPLATE As String = "DXFs\<_FileName_>_<_FeatureName_>_<_ConfName_>_<$CLPRP:Description>.dxf"
Const FLAT_PATTERN_OPTIONS As Integer = SheetMetalOptions_e.ExportBendLines + SheetMetalOptions_e.ExportFlatPatternGeometry
Dim swApp As SldWorks.SldWorks
Set swApp = Application.SldWorks
Sub main()
Set swApp = Application.SldWorks
try_:
On Error GoTo catch_
Dim swModel As SldWorks.ModelDoc2
Set swModel = swApp.ActiveDoc
If swModel Is Nothing Then
Err.Raise vbError, "", "Please open assembly or part document"
End If
If swModel.GetType() = swDocumentTypes_e.swDocASSEMBLY Then
Dim swAssy As SldWorks.AssemblyDoc
Set swAssy = swModel
swAssy.ResolveAllLightWeightComponents True
Dim vComps As Variant
vComps = GetDistinctSheetMetalComponents(swAssy)
Dim i As Integer
For i = 0 To UBound(vComps)
Dim swComp As SldWorks.Component2
Set swComp = vComps(i)
ProcessSheetMetalModel swAssy, swComp.GetModelDoc2(), swComp.ReferencedConfiguration
Next
ElseIf swModel.GetType() = swDocumentTypes_e.swDocPART Then
Dim swPart As SldWorks.PartDoc
Set swPart = swApp.ActiveDoc
ProcessSheetMetalModel swPart, swPart, swPart.ConfigurationManager.ActiveConfiguration.Name
Else
Err.Raise vbError, "", "Only assembly and part documents are supported"
End If
swApp.SendMsgToUser2 "Operation completed", swMessageBoxIcon_e.swMbInformation, swMessageBoxBtn_e.swMbOk
GoTo finally_
catch_:
swApp.SendMsgToUser2 Err.Description, swMessageBoxIcon_e.swMbStop, swMessageBoxBtn_e.swMbOk
finally_:
End Sub
Function GetDistinctSheetMetalComponents(assy As SldWorks.AssemblyDoc) As Variant
Dim vComps As Variant
vComps = assy.GetComponents(False)
Dim i As Integer
Dim swSheetMetalComps() As SldWorks.Component2
For i = 0 To UBound(vComps)
Dim swComp As SldWorks.Component2
Set swComp = vComps(i)
If False = swComp.IsSuppressed() Then
If Not ContainsComponent(swSheetMetalComps, swComp) Then
If IsSheetMetalComponent(swComp) Then
If (Not swSheetMetalComps) = -1 Then
ReDim swSheetMetalComps(0)
Else
ReDim Preserve swSheetMetalComps(UBound(swSheetMetalComps) + 1)
End If
Set swSheetMetalComps(UBound(swSheetMetalComps)) = swComp
End If
End If
End If
Next
If (Not swSheetMetalComps) = -1 Then
GetDistinctSheetMetalComponents = Empty
Else
GetDistinctSheetMetalComponents = swSheetMetalComps
End If
End Function
Function IsSheetMetalComponent(comp As SldWorks.Component2) As Boolean
Dim vBodies As Variant
vBodies = comp.GetBodies3(swBodyType_e.swSolidBody, Empty)
If Not IsEmpty(vBodies) Then
Dim i As Integer
For i = 0 To UBound(vBodies)
Dim swBody As SldWorks.Body2
Set swBody = vBodies(i)
If False <> swBody.IsSheetMetal() Then
IsSheetMetalComponent = True
Exit Function
End If
Next
End If
IsSheetMetalComponent = False
End Function
Function ContainsComponent(comps As Variant, swComp As SldWorks.Component2) As Boolean
Dim i As Integer
For i = 0 To UBound(comps)
Dim swThisComp As SldWorks.Component2
Set swThisComp = comps(i)
If swThisComp.GetPathName() = swComp.GetPathName() And swThisComp.ReferencedConfiguration = swComp.ReferencedConfiguration Then
ContainsComponent = True
Exit Function
End If
Next
ContainsComponent = False
End Function
Function ComposeOutFileName(template As String, rootModel As SldWorks.ModelDoc2, sheetMetalModel As SldWorks.ModelDoc2, conf As String, flatPatternFeat As SldWorks.Feature, cutListFeat As SldWorks.Feature) As String
Dim regEx As Object
Set regEx = CreateObject("VBScript.RegExp")
regEx.Global = True
regEx.IgnoreCase = True
regEx.Pattern = "<[^>]*>"
Dim regExMatches As Object
Set regExMatches = regEx.Execute(template)
Dim i As Integer
Dim outFileName As String
outFileName = template
For i = regExMatches.Count - 1 To 0 Step -1
Dim regExMatch As Object
Set regExMatch = regExMatches.Item(i)
Dim tokenName As String
tokenName = Mid(regExMatch.Value, 2, Len(regExMatch.Value) - 2)
outFileName = Left(outFileName, regExMatch.FirstIndex) & ResolveToken(tokenName, rootModel, sheetMetalModel, conf, flatPatternFeat, cutListFeat) & Right(outFileName, Len(outFileName) - (regExMatch.FirstIndex + regExMatch.Length))
Next
ComposeOutFileName = ReplaceInvalidPathSymbols(GetFullPath(rootModel, outFileName))
End Function
Function ReplaceInvalidPathSymbols(path As String) As String
Const REPLACE_SYMB As String = "_"
Dim res As String
res = Right(path, Len(path) - Len("X:\"))
Dim drive As String
drive = Left(path, Len("X:\"))
Dim invalidSymbols As Variant
invalidSymbols = Array("/", ":", "*", "?", """", "<", ">", "|")
Dim i As Integer
For i = 0 To UBound(invalidSymbols)
Dim invalidSymb As String
invalidSymb = CStr(invalidSymbols(i))
res = Replace(res, invalidSymb, REPLACE_SYMB)
Next
ReplaceInvalidPathSymbols = drive + res
End Function
Function ResolveToken(token As String, rootModel As SldWorks.ModelDoc2, sheetMetalModel As SldWorks.ModelDoc2, conf As String, flatPatternFeat As SldWorks.Feature, cutListFeat As SldWorks.Feature) As String
Const FILE_NAME_TOKEN As String = "_FileName_"
Const ASSM_FILE_NAME_TOKEN As String = "_AssmFileName_"
Const FEAT_NAME_TOKEN As String = "_FeatureName_"
Const CONF_NAME_TOKEN As String = "_ConfName_"
Const PRP_TOKEN As String = "$PRP:"
Const CUT_LIST_PRP_TOKEN As String = "$CLPRP:"
Const ASM_PRP_TOKEN As String = "$ASSMPRP:"
Select Case LCase(token)
Case LCase(FILE_NAME_TOKEN)
ResolveToken = GetFileNameWithoutExtension(sheetMetalModel.GetPathName)
Case LCase(FEAT_NAME_TOKEN)
ResolveToken = flatPatternFeat.Name
Case LCase(CONF_NAME_TOKEN)
ResolveToken = conf
Case LCase(ASSM_FILE_NAME_TOKEN)
If rootModel.GetPathName() = "" Then
Err.Raise vbError, "", "Assembly must be saved to use " & ASSM_FILE_NAME_TOKEN
End If
ResolveToken = GetFileNameWithoutExtension(rootModel.GetPathName())
Case Else
Dim prpName As String
If Left(token, Len(PRP_TOKEN)) = PRP_TOKEN Then
prpName = Right(token, Len(token) - Len(PRP_TOKEN))
ResolveToken = GetModelPropertyValue(sheetMetalModel, conf, prpName)
ElseIf Left(token, Len(ASM_PRP_TOKEN)) = ASM_PRP_TOKEN Then
prpName = Right(token, Len(token) - Len(ASM_PRP_TOKEN))
ResolveToken = GetModelPropertyValue(rootModel, rootModel.ConfigurationManager.ActiveConfiguration.Name, prpName)
ElseIf Left(token, Len(CUT_LIST_PRP_TOKEN)) = CUT_LIST_PRP_TOKEN Then
prpName = Right(token, Len(token) - Len(CUT_LIST_PRP_TOKEN))
ResolveToken = GetPropertyValue(cutListFeat.CustomPropertyManager, prpName)
Else
Err.Raise vbError, "", "Unrecognized token: " & token
End If
End Select
End Function
Function GetModelPropertyValue(model As SldWorks.ModelDoc2, confName As String, prpName As String) As String
Dim prpVal As String
Dim swCustPrpMgr As SldWorks.CustomPropertyManager
Set swCustPrpMgr = model.Extension.CustomPropertyManager(confName)
prpVal = GetPropertyValue(swCustPrpMgr, prpName)
If prpVal = "" Then
Set swCustPrpMgr = model.Extension.CustomPropertyManager("")
prpVal = GetPropertyValue(swCustPrpMgr, prpName)
End If
GetModelPropertyValue = prpVal
End Function
Function GetPropertyValue(custPrpMgr As SldWorks.CustomPropertyManager, prpName As String) As String
Dim resVal As String
custPrpMgr.Get2 prpName, "", resVal
GetPropertyValue = resVal
End Function
Function GetFileNameWithoutExtension(path As String) As String
GetFileNameWithoutExtension = Mid(path, InStrRev(path, "\") + 1, InStrRev(path, ".") - InStrRev(path, "\") - 1)
End Function
Function GetCutListFeatures(model As SldWorks.ModelDoc2) As Variant
GetCutListFeatures = GetFeaturesByType(model, "CutListFolder")
End Function
Function GetFlatPatternFeatures(model As SldWorks.ModelDoc2) As Variant
GetFlatPatternFeatures = GetFeaturesByType(model, "FlatPattern")
End Function
Sub ProcessSheetMetalModel(rootModel As SldWorks.ModelDoc2, sheetMetalModel As SldWorks.ModelDoc2, conf As String)
Dim vCutListFeats As Variant
vCutListFeats = GetCutListFeatures(sheetMetalModel)
If Not IsEmpty(vCutListFeats) Then
Dim vFlatPatternFeats As Variant
vFlatPatternFeats = GetFlatPatternFeatures(sheetMetalModel)
If Not IsEmpty(vFlatPatternFeats) Then
Dim swProcessedCutListsFeats() As SldWorks.Feature
Dim i As Integer
For i = 0 To UBound(vFlatPatternFeats)
Dim swFlatPatternFeat As SldWorks.Feature
Dim swFlatPattern As SldWorks.FlatPatternFeatureData
Set swFlatPatternFeat = vFlatPatternFeats(i)
Set swFlatPattern = swFlatPatternFeat.GetDefinition
Dim swFixedEnt As SldWorks.Entity
Set swFixedEnt = swFlatPattern.FixedFace2
Dim swBody As SldWorks.Body2
If TypeOf swFixedEnt Is SldWorks.Face2 Then
Dim swFixedFace As SldWorks.Face2
Set swFixedFace = swFixedEnt
Set swBody = swFixedFace.GetBody
ElseIf TypeOf swFixedEnt Is SldWorks.Edge Then
Dim swFixedEdge As SldWorks.Edge
Set swFixedEdge = swFixedEnt
Set swBody = swFixedEdge.GetBody
ElseIf TypeOf swFixedEnt Is SldWorks.Vertex Then
Dim swFixedVert As SldWorks.Vertex
Set swFixedVert = swFixedEnt
Set swBody = swFixedVert.GetBody
End If
Dim swCutListFeat As SldWorks.Feature
Set swCutListFeat = FindCutListFeature(vCutListFeats, swBody)
If Not swCutListFeat Is Nothing Then
Dim isUnique As Boolean
If (Not swProcessedCutListsFeats) = -1 Then
isUnique = True
ElseIf Not ContainsSwObject(swProcessedCutListsFeats, swCutListFeat) Then
isUnique = True
Else
isUnique = False
End If
If isUnique Then
If (Not swProcessedCutListsFeats) = -1 Then
ReDim swProcessedCutListsFeats(0)
Else
ReDim Preserve swProcessedCutListsFeats(UBound(swProcessedCutListsFeats) + 1)
End If
Set swProcessedCutListsFeats(UBound(swProcessedCutListsFeats)) = swCutListFeat
Dim outFileName As String
outFileName = ComposeOutFileName(OUT_NAME_TEMPLATE, rootModel, sheetMetalModel, conf, swFlatPatternFeat, swCutListFeat)
If Not SKIP_EXISTING_FILES Or Not FileExists(outFileName) Then
ExportFlatPattern sheetMetalModel, swFlatPatternFeat, outFileName, FLAT_PATTERN_OPTIONS, conf
End If
End If
Else
Err.Raise vbError, "", "Failed to find cut-list for flat pattern " & swFlatPatternFeat.Name
End If
Next
Else
Err.Raise vbError, "", "No flat pattern features found"
End If
Else
Err.Raise vbError, "", "No cut-list items found"
End If
End Sub
Function FileExists(filePath As String) As Boolean
FileExists = Dir(filePath) <> ""
End Function
Function FindCutListFeature(vCutListFeats As Variant, body As SldWorks.Body2) As SldWorks.Feature
Dim i As Integer
For i = 0 To UBound(vCutListFeats)
Dim swCutListFeat As SldWorks.Feature
Set swCutListFeat = vCutListFeats(i)
Dim swBodyFolder As SldWorks.BodyFolder
Set swBodyFolder = swCutListFeat.GetSpecificFeature2
Dim vBodies As Variant
vBodies = swBodyFolder.GetBodies
If ContainsSwObject(vBodies, body) Then
Set FindCutListFeature = swCutListFeat
End If
Next
End Function
Function ContainsSwObject(vArr As Variant, obj As Object) As Boolean
If Not IsEmpty(vArr) Then
Dim i As Integer
For i = 0 To UBound(vArr)
Dim swObj As Object
Set swObj = vArr(i)
If swApp.IsSame(swObj, obj) = swObjectEquality.swObjectSame Then
ContainsSwObject = True
Exit Function
End If
Next
End If
ContainsSwObject = False
End Function
Function GetFeaturesByType(model As SldWorks.ModelDoc2, typeName As String) As Variant
Dim swFeats() As SldWorks.Feature
Dim swFeat As SldWorks.Feature
Set swFeat = model.FirstFeature
Do While Not swFeat Is Nothing
If typeName = "CutListFolder" And swFeat.GetTypeName2() = "SolidBodyFolder" Then
Dim swBodyFolder As SldWorks.BodyFolder
Set swBodyFolder = swFeat.GetSpecificFeature2
swBodyFolder.UpdateCutList
End If
ProcessFeature swFeat, swFeats, typeName
Set swFeat = swFeat.GetNextFeature
Loop
If (Not swFeats) = -1 Then
GetFeaturesByType = Empty
Else
GetFeaturesByType = swFeats
End If
End Function
Sub ProcessFeature(thisFeat As SldWorks.Feature, featsArr() As SldWorks.Feature, typeName As String)
If thisFeat.GetTypeName2() = typeName Then
If (Not featsArr) = -1 Then
ReDim featsArr(0)
Set featsArr(0) = thisFeat
Else
Dim i As Integer
For i = 0 To UBound(featsArr)
If swApp.IsSame(featsArr(i), thisFeat) = swObjectEquality.swObjectSame Then
Exit Sub
End If
Next
ReDim Preserve featsArr(UBound(featsArr) + 1)
Set featsArr(UBound(featsArr)) = thisFeat
End If
End If
Dim swSubFeat As SldWorks.Feature
Set swSubFeat = thisFeat.GetFirstSubFeature
While Not swSubFeat Is Nothing
ProcessFeature swSubFeat, featsArr, typeName
Set swSubFeat = swSubFeat.GetNextSubFeature
Wend
End Sub
Sub ExportFlatPattern(part As SldWorks.PartDoc, flatPattern As SldWorks.Feature, outFilePath As String, opts As SheetMetalOptions_e, conf As String)
Dim swModel As SldWorks.ModelDoc2
Set swModel = part
Dim error As ErrObject
Dim hide As Boolean
try_:
On Error GoTo catch_
If False = swModel.Visible Then
hide = True
swModel.Visible = True
End If
swApp.ActivateDoc3 swModel.GetPathName(), False, swRebuildOnActivation_e.swDontRebuildActiveDoc, 0
swModel.FeatureManager.EnableFeatureTree = False
swModel.FeatureManager.EnableFeatureTreeWindow = False
swModel.ActiveView.EnableGraphicsUpdate = False
Dim curConf As String
curConf = swModel.ConfigurationManager.ActiveConfiguration.Name
If curConf <> conf Then
If False = swModel.ShowConfiguration2(conf) Then
Err.Raise vbError, "", "Failed to activate configuration"
End If
End If
Dim outDir As String
outDir = Left(outFilePath, InStrRev(outFilePath, "\"))
CreateDirectories outDir
Dim modelPath As String
modelPath = part.GetPathName
If modelPath = "" Then
Err.Raise vbError, "", "Part document must be saved"
End If
If False <> flatPattern.Select2(False, -1) Then
If False = part.ExportToDWG2(outFilePath, modelPath, swExportToDWG_e.swExportToDWG_ExportSheetMetal, True, Empty, False, False, opts, Empty) Then
Err.Raise vbError, "", "Failed to export flat pattern"
End If
Else
Err.Raise vbError, "", "Failed to select flat-pattern"
End If
swModel.ShowConfiguration2 curConf
GoTo finally_
catch_:
Set error = Err
finally_:
swModel.FeatureManager.EnableFeatureTree = True
swModel.FeatureManager.EnableFeatureTreeWindow = True
swModel.ActiveView.EnableGraphicsUpdate = True
If hide Then
swApp.CloseDoc swModel.GetTitle
End If
If Not error Is Nothing Then
Err.Raise error.Number, error.Source, error.Description, error.HelpFile, error.HelpContext
End If
End Sub
Sub CreateDirectories(path As String)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FolderExists(path) Then
Exit Sub
End If
CreateDirectories fso.GetParentFolderName(path)
fso.CreateFolder path
End Sub
Function GetFullPath(model As SldWorks.ModelDoc2, path As String)
GetFullPath = path
If IsPathRelative(path) Then
If Left(path, 1) <> "\" Then
path = "\" & path
End If
Dim modelPath As String
Dim modelDir As String
modelPath = model.GetPathName
modelDir = Left(modelPath, InStrRev(modelPath, "\") - 1)
GetFullPath = modelDir & path
End If
End Function
Function IsPathRelative(path As String)
IsPathRelative = Mid(path, 2, 1) <> ":" And Not IsPathUnc(path)
End Function
Function IsPathUnc(path As String)
IsPathUnc = Left(path, 2) = "\\"
End Function