SolidWorks >> Makra >> WItam, czy ktoś wie jak module Elementy Spawane znalezdz odpowiednie element listy cietych.
Odpowiedz
Autor Wypowiedź
2015-09-17, 15:20
Pomógł 0 raz(y).
 Witam



Mam taki problem.



Mam zaznaczony element wyciągniecie, potem wlaczam makro i chce aby to makro dla zaznaczonego elementu dodało mi w liście cietych elementów jakąś słasciwosc.



Pozdrawiam

Janusz Zaba
 
2015-09-18, 07:36
Pomógł 0 raz(y).
 Czy naprawdę nie ma możliwości sprawdzić który element jest powiązany z która własnościa z listy elementów ciętych.
 
2015-09-18, 14:53
Pomógł 0 raz(y).
 'SolidWorks API Help
'Get Solid Bodies from Cut List Folders and Get Custom Properties Example (VBA)
'This example shows how to get the solid bodies from cut list folders and how to get the custom properties for the solid bodies.



Option Explicit



Dim swApp As SldWorks.SldWorks

Dim swPart As SldWorks.ModelDoc2

Dim swFeat As SldWorks.Feature

Dim Indent As Long



Sub GetFeatureCustomProps(thisFeat As SldWorks.Feature)

Dim CustomPropMgr As SldWorks.CustomPropertyManager

Set CustomPropMgr = thisFeat.CustomPropertyManager

Dim vCustomPropNames As Variant

vCustomPropNames = CustomPropMgr.GetNames

If Not IsEmpty(vCustomPropNames) Then

Dim NameFmt As String

NameFmt = "!" & String(30, "@")

Dim TypeFmt As String

TypeFmt = "!" & String(6, "@")

Dim ValFmt As String

ValFmt = "!" & String(80, "@")

Dim ResValFmt As String

ResValFmt = "!" & String(40, "@")

Debug.Print String(Indent + 3, " ") & "Cut List Custom Properties :"

Dim i As Long

For i = LBound(vCustomPropNames) To UBound(vCustomPropNames)

Dim CustomPropName As String

CustomPropName = vCustomPropNames(i)

Debug.Print Format(String(Indent + 6, " ") & CustomPropName, NameFmt);

Dim CustomPropType As String

CustomPropType = CustomPropMgr.GetType(CustomPropName)

Dim CustomPropVal As String

Dim CustomPropResolvedVal As String

CustomPropMgr.Get2 CustomPropName, CustomPropVal, CustomPropResolvedVal

Debug.Print Format(CustomPropVal, ValFmt);

Debug.Print Format(CustomPropResolvedVal, ResValFmt)

Next i

End If

End Sub

Sub DoTheWork(thisFeat As SldWorks.Feature, ParentName As String)

Static InBodyFolder As Boolean

Static BodyFolderType(5) As String

Static BeenHere As Boolean

Dim bAllFeatures As Boolean

Dim bCutListCustomProps As Boolean



If Not BeenHere Then

BodyFolderType(0) = "dummy"

BodyFolderType(1) = "swSolidBodyFolder"

BodyFolderType(2) = "swSurfaceBodyFolder"

BodyFolderType(3) = "swBodySubFolder"

BodyFolderType(4) = "swWeldmentSubFolder"

BodyFolderType(5) = "swWeldmentCutListFolder"

InBodyFolder = False

BeenHere = True

bAllFeatures = False

bCutListCustomProps = False

End If





'Comment out next line to print information for just BodyFolders

'bAllFeatures = True 'True to print information about all features

'Comment out next line if do not want cut list's custom properties

bCutListCustomProps = True 'True to print cut list's custom property information

Dim FeatType As String

FeatType = thisFeat.GetTypeName



If (FeatType = "SolidBodyFolder") And (ParentName = "Root Feature") Then

InBodyFolder = True

End If



If (FeatType "SolidBodyFolder") And (ParentName = "Root Feature") Then

InBodyFolder = False

End If

If (InBodyFolder = False) And (FeatType = "CutListFolder") Then 'Only consider the CutListFolders that are under the SolidBodyFolder

Exit Sub 'Skip the second occurrence of the CutListFolders during the feature traversal

End If



If (InBodyFolder = False) And (FeatType = "SubWeldFolder") Then 'Only consider the SubWeldFolder that are under the SolidBodyFolder

Exit Sub 'Skip the second occurrence of the SubWeldFolders during the feature traversal

End If



Dim IsBodyFolder As Boolean

If FeatType = "SolidBodyFolder" Or _
FeatType = "SurfaceBodyFolder" Or _
FeatType = "CutListFolder" Or _
FeatType = "SubWeldFolder" Or _
FeatType = "SubAtomFolder" Then

IsBodyFolder = True

Else

IsBodyFolder = False

End If



Dim FeatNameFmt As String

FeatNameFmt = "!" & String(42, "@")



If (FeatType = "FtrFolder") And (InStr(1, thisFeat.Name, "___EndTag___", 0) > 0) Then 'This is the folder End Tag

Indent = Indent - 3

End If

If bAllFeatures And (Not IsBodyFolder) Then

Debug.Print Format(String(Indent, " ") & thisFeat.Name, FeatNameFmt); Format(FeatType, "!" & String(18, "@"));

Dim vSuppressed As Variant

vSuppressed = thisFeat.IsSuppressed2(swThisConfiguration, Empty)

If IsEmpty(vSuppressed) Then

Debug.Print "IsSuppressed2 failed";

Else

Debug.Print Format(IIf(vSuppressed(0) = False, " ", "Suppressed"), "!" & String(15, "@"));

End If

End If

If IsBodyFolder Then

Dim BodyFolder As SldWorks.BodyFolder

Set BodyFolder = thisFeat.GetSpecificFeature2

Dim BodyCount As Long

BodyCount = BodyFolder.GetBodyCount



If (FeatType = "CutListFolder") And (BodyCount < 1) Then

Exit Sub 'When BodyCount = 0, this cut list folder is not displayed in the

'Feature Manager design Tree, so skip it

Else

Debug.Print Format(String(Indent, " ") & thisFeat.Name, FeatNameFmt); Format(FeatType, "!" & String(18, "@"));

vSuppressed = thisFeat.IsSuppressed2(swThisConfiguration, Empty)

If IsEmpty(vSuppressed) Then

Debug.Print "IsSuppressed2 failed";

Else

Debug.Print Format(IIf(vSuppressed(0) = False, " ", "Suppressed"), "!" & String(15, "@"));

End If

End If

If Not bAllFeatures Then

Debug.Print Format(String(Indent, " ") & thisFeat.Name, FeatNameFmt); Format(FeatType, "!" & String(18, "@"));

vSuppressed = thisFeat.IsSuppressed2(swThisConfiguration, Empty)

If IsEmpty(vSuppressed) Then

Debug.Print "IsSuppressed2 failed";

Else

Debug.Print Format(IIf(vSuppressed(0) = False, " ", "Suppressed"), "!" & String(15, "@"));

End If

End If

Dim BodyFolderTypeE As Long

BodyFolderTypeE = BodyFolder.Type

Debug.Print Format(BodyFolderType(BodyFolderTypeE), "!" & String(28, "@")); Format(BodyFolderTypeE, "!@@@@");



Debug.Print Format("Body Count " & BodyCount, "!" & String(15, "@"))



Dim vBodies As Variant

vBodies = BodyFolder.GetBodies

Dim i As Long

If Not IsEmpty(vBodies) Then

For i = LBound(vBodies) To UBound(vBodies)

Dim Body As SldWorks.Body2

Set Body = vBodies(i)

Debug.Print Format(String(Indent + 3, " ") & Body.Name, "!" & String(32, "@"))

Next i

End If

Else

If bAllFeatures Then

Debug.Print 'Finish off pending print line

End If

End If



If (FeatType = "CutListFolder") Then

If BodyCount > 0 Then 'When BodyCount = 0, this cut list folder is not displayed

'in the FeatureManager design tree, so skip it

If bCutListCustomProps Then

GetFeatureCustomProps thisFeat 'Comment out this line if you do not want to

'print the cut list folder's custom properties

End If

End If

End If



If (FeatType = "FtrFolder") And (InStr(1, thisFeat.Name, "___EndTag___", 0) < 1) Then 'This is the folder start marker

Indent = Indent + 3

End If

End Sub

Sub TraverseFeatures(thisFeat As SldWorks.Feature, isTopLevel As Boolean, ParentName As String)

Dim curFeat As SldWorks.Feature

Set curFeat = thisFeat

Indent = Indent + 3



While Not curFeat Is Nothing

DoTheWork curFeat, ParentName 'Do the thing that we are doing this feature traversal for



Dim subfeat As SldWorks.Feature

Set subfeat = curFeat.GetFirstSubFeature

While Not subfeat Is Nothing

TraverseFeatures subfeat, False, curFeat.Name

Dim nextSubFeat As SldWorks.Feature

Set nextSubFeat = subfeat.GetNextSubFeature

Set subfeat = nextSubFeat

Set nextSubFeat = Nothing

Wend

Set subfeat = Nothing



Dim nextFeat As SldWorks.Feature

If isTopLevel Then

Set nextFeat = curFeat.GetNextFeature

Else

Set nextFeat = Nothing

End If

Set curFeat = nextFeat

Set nextFeat = Nothing

Wend

Indent = Indent - 3

End Sub

Sub main()

Set swApp = Application.SldWorks

Set swPart = swApp.ActiveDoc

Debug.Print "File = " & swPart.GetPathName



Dim ConfigName As String

ConfigName = swPart.ConfigurationManager.ActiveConfiguration.Name

Debug.Print "Active Configuration Name = " & ConfigName



Indent = -3

Set swFeat = swPart.FirstFeature

TraverseFeatures swFeat, True, "Root Feature"

End Sub
 
Odpowiedz

PSWUG

Strefa Resellera

Publikuj

Społeczność

Ankieta

Linki

RSS
BOT