Witam wszystkich,
Znowu jest szalony pytający!! 
Chciałbym wiedzieć, czy możliwe jest pobranie wartości kostki wizualizacji w makrze, aby móc przypisać je do zmiennych?
A po drugie, czy wiesz, czy można zrobić falę nazw funkcji drzewa? A może możliwa jest zmiana nazw funkcji za pomocą makra?
Dziękuję bardzo.
Witam;
Musi to być możliwe do osiągnięcia:
https://help.solidworks.com/2022/english/api/sldworksapi/SolidWorks.Interop.sldworks~SolidWorks.Interop.sldworks.IBoundingBoxFeatureData.html
Druga część, tak, możliwa jest również zmiana nazw funkcji za pomocą makra:
Przykład z użyciem słownika
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Sub main()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Dim passedOrigin As Boolean
passedOrigin = False
If Not swModel Is Nothing Then
Dim featNamesTable As Object
Dim processedFeats As Collection
Set featNamesTable = CreateObject("Scripting.Dictionary")
Set processedFeats = New Collection
featNamesTable.CompareMode = vbTextCompare 'case insensitive
Dim swFeat As SldWorks.Feature
Set swFeat = swModel.FirstFeature
While Not swFeat Is Nothing
If passedOrigin = 0 Or swFmHoleWzd = 1 Then 'Lister les elements à exclure sous la forme " And InStr(swFeat.Name, "Element a Exclure")"
If Not Contains(processedFeats, swFeat) Then
processedFeats.Add swFeat
RenameFeature swFeat, featNamesTable
End If
Dim swSubFeat As SldWorks.Feature
Set swSubFeat = swFeat.GetFirstSubFeature
While Not swSubFeat Is Nothing
If Not Contains(processedFeats, swSubFeat) Then
processedFeats.Add swSubFeat
RenameFeature swSubFeat, featNamesTable
End If
Set swSubFeat = swSubFeat.GetNextSubFeature
Wend
End If
If swFeat.GetTypeName2() = "OriginProfileFeature" Then
passedOrigin = True
End If
Set swFeat = swFeat.GetNextFeature
Wend
Else
MsgBox "Please open model"
End If
End Sub
Sub RenameFeature(feat As SldWorks.Feature, featNamesTable As Object)
Dim regEx As Object
Set regEx = CreateObject("VBScript.RegExp")
regEx.Global = True
regEx.IgnoreCase = True
regEx.Pattern = "(.+?)(\d+)$"
Dim regExMatches As Object
Set regExMatches = regEx.Execute(feat.Name)
If regExMatches.Count = 1 Then
If regExMatches(0).SubMatches.Count = 2 Then
Dim baseFeatName As String
baseFeatName = regExMatches(0).SubMatches(0)
Dim nextIndex As Integer
If featNamesTable.Exists(baseFeatName) Then
nextIndex = featNamesTable.item(baseFeatName) + 1
featNamesTable.item(baseFeatName) = nextIndex
Else
nextIndex = 1
featNamesTable.Add baseFeatName, nextIndex
End If
feat.Name = baseFeatName & nextIndex
End If
End If
End Sub
Function Contains(coll As Collection, item As Object) As Boolean
Dim i As Integer
For i = 1 To coll.Count
If coll.item(i) Is item Then
Contains = True
Exit Function
End If
Next
Contains = False
End Function
Pozdrowienia.
Dziękuję
Witam @Maclane
Przetestowałem makro, aby zmienić nazwy funkcji, działa dobrze, ale jest zbyt złożone, biorąc pod uwagę różnorodność części, które mamy.
Czy możliwe jest odzyskanie nazwy drugiej funkcji (FirstFeature dla pierwszej, jak sądzę)?
W ten sposób mogłem utworzyć zmienną, aby dokonać powrotu do funkcji (swMoveRollbackBarTo).
Oto, co majstrowałem przy DŁUGOŚCI kostki wizualizacji:
Option Explicit
Dim swApp As Object
Dim Part As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Sub main()
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
Dim swFeat As Object
Dim swFeatMgr As Object
'Suppression Cube de visualistaion existant (pour MAJ longueur)
Set Part = swApp.ActiveDoc
boolstatus = Part.Extension.SelectByID2("Cube de visualisation", "BBOXSKETCH", 0, 0, 0, False, 0, Nothing, 0)
boolstatus = Part.Extension.SelectByID2("Cube de visualisation", "BBOXSKETCH", 0, 0, 0, False, 0, Nothing, 0)
Part.EditDelete
'Création Cube de visualisation (permettant d'avoir la longueur du poteau)
Set swFeatMgr = Part.FeatureManager
Dim swFeatData As Object
Set swFeatData = swFeatMgr.CreateDefinition(swFeatureNameID_e.swFmBoundingBox)
swFeatData.IncludeHiddenBodies = False
swFeatData.IncludeSurfaces = False
swFeatData.ReferenceFaceOrPlane = 1
Set swFeat = swFeatMgr.CreateFeature(swFeatData)
Part.ClearSelection2 True
boolstatus = Part.Extension.SelectByID2("Cube de visualisation", "BBOXSKETCH", 0, 0, 0, False, 0, Nothing, 0)
Part.BlankSketch
'''-----------------------------------------------
'Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swConfigMgr As SldWorks.ConfigurationManager
Dim swConfig As SldWorks.Configuration
Dim vConfigName As Variant
Dim vConfigNameArr As Variant
Dim sSpecConfigNameArr(0) As String
Dim vSpecConfigNameArr As Variant
Dim dimValue As Variant
Dim stnameConfig As String
'Dim boolstatus As Boolean
Dim i As Integer
Dim swErrors As Long
Dim swWarnings As Long
Dim swPart As SldWorks.PartDoc
Dim tConfig() As String
Dim swModelDocExt As ModelDocExtension
Dim swCustProp As CustomPropertyManager
Dim sLongueur As String
Dim sCentreMasseY As String
Dim sValout As String
Dim sValSurf As String
Dim sValLong As String
Dim bRet As String
'''-----------------------------------------------
'on récupére le document actif
Set swModel = swApp.ActiveDoc
Set swConfigMgr = swModel.ConfigurationManager
'on récupére la configuration active
Set swConfig = swConfigMgr.ActiveConfiguration
stnameConfig = swConfig.Name
vConfigNameArr = swModel.GetConfigurationNames
Set swModelDocExt = swModel.Extension
'''-----------------------------------------------
'on boucle sur toutes les configurations
For Each vConfigName In vConfigNameArr
'on test si la configuration est différente de la configuration active et de la configuration Default
If vConfigName <> swConfig.Name And vConfigName <> "xx" Then
boolstatus = swModel.DeleteConfiguration2(vConfigName)
End If
If vConfigName <> swConfig.Name And vConfigName <> "Défaut" Then
boolstatus = swModel.DeleteConfiguration2(vConfigName)
End If
Next vConfigName
'on reconstruit la pièce
swModel.ForceRebuild3 False
'récupère le document actif dans SW
Set swModel = swApp.ActiveDoc
If Not swModel Is Nothing Then
Set swPart = swModel
'Boucle sur toutes les configurations
tConfig = swModel.GetConfigurationNames
For i = 0 To UBound(tConfig)
Set swCustProp = swModelDocExt.CustomPropertyManager(tConfig(i))
'Récupération de la propriété de Longueur Cube Visualisation
bRet = swCustProp.Get6("Longueur totale du cube de visualisation", False, sValout, sLongueur, False, False)
'Renseignement de la propriété LONGUEUR avec la valeur "sVal"
bRet = swCustProp.Add3("LONGUEUR", 30, sLongueur, 1)
Next i
End If
MsgBox "MAJ LONGUEUR OK"
End Sub
Działa dobrze, pozwala na aktualizację zmiennej LENGTH, gdy zmieniasz długość swojej części.
Witam
Poczyniłem duże postępy w moim makro. Działa dobrze na części za pierwszym razem.
Ale jeśli zrestartuję makro (zmienię długość części do przetestowania, a nawet bez zmiany czegokolwiek), makro zawiesza się w następujący sposób:
A debugowanie daje mi to:
Nie mogę zrozumieć i dlatego naprawić tego problemu. Czy ktoś mógłby mi pomóc?
Oto pełny kod:
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swConfigMgr As SldWorks.ConfigurationManager
Dim swConfig As SldWorks.Configuration
Dim vConfigName As Variant
Dim vConfigNameArr As Variant
Dim sSpecConfigNameArr(0) As String
Dim vSpecConfigNameArr As Variant
Dim dimValue As Variant
Dim Part As Object
Dim stnameConfig As String
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Dim i As Integer
Dim swErrors As Long
Dim swWarnings As Long
Dim swPart As SldWorks.PartDoc
Dim tConfig() As String
Dim swModelDocExt As ModelDocExtension
Dim swCustProp As CustomPropertyManager
Dim sMasse As String
Dim sValout As String
Dim sValSurf As String
Dim sValLong As String
Dim bRet As String
Dim NamePiece As String
Dim confName As String
Dim confNameF As String
Dim MaterialFilePath As String
Dim ConfigNameSuffix As String
Dim colorName As String
Dim CodArt As String
Dim CodeArticle As String
Dim sLongueur As String
Dim sCentreMasseY As String
Type ConfigData
MaterialFilePath As String
ConfigNameSuffix As String
colorName As String
confName As String
confNameF As String
NamePiece As String
CodArt As String
CodeArticle As String
End Type
Const PROP_RAL As String = "RAL"
Const PROP_CodeArticle As String = "Code Article"
Sub main()
Set swApp = Application.SldWorks
Dim swModel As SldWorks.ModelDoc2
''' Récupération du document actif
Set swModel = swApp.ActiveDoc
Set swConfigMgr = swModel.ConfigurationManager
''' Récupération de la configuration active
Set swConfig = swConfigMgr.ActiveConfiguration
stnameConfig = swConfig.Name
vConfigNameArr = swModel.GetConfigurationNames
Set swModelDocExt = swModel.Extension
Set Part = swApp.ActiveDoc
Dim swFeat As Object
Dim swFeatMgr As Object
''' Suppression Cube de visualistaion éxistant
Set Part = swApp.ActiveDoc
boolstatus = Part.Extension.SelectByID2("Cube de visualisation", "BBOXSKETCH", 0, 0, 0, False, 0, Nothing, 0)
boolstatus = Part.Extension.SelectByID2("Cube de visualisation", "BBOXSKETCH", 0, 0, 0, False, 0, Nothing, 0)
Part.EditDelete
''' Création Cube de visualisation
Set swFeatMgr = Part.FeatureManager
Dim swFeatData As Object
Set swFeatData = swFeatMgr.CreateDefinition(swFeatureNameID_e.swFmBoundingBox)
swFeatData.IncludeHiddenBodies = False
swFeatData.IncludeSurfaces = False
swFeatData.ReferenceFaceOrPlane = 1
Set swFeat = swFeatMgr.CreateFeature(swFeatData)
Part.ClearSelection2 True
boolstatus = Part.Extension.SelectByID2("Cube de visualisation", "BBOXSKETCH", 0, 0, 0, False, 0, Nothing, 0)
Part.BlankSketch
''' Réglages Préférences SolidWorks
boolstatus = swModel.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsLinearFractionDenominator, 0, 0)
boolstatus = swModel.Extension.SetUserPreferenceToggle(swUserPreferenceToggle_e.swUnitsLinearFeetAndInchesFormat, 0, False)
boolstatus = swModel.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsDualLinear, 0, swLengthUnit_e.swMM)
boolstatus = swModel.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsDualLinearFractionDenominator, 0, 0)
boolstatus = swModel.Extension.SetUserPreferenceToggle(swUserPreferenceToggle_e.swUnitsDualLinearFeetAndInchesFormat, 0, False)
boolstatus = swModel.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsMassPropMass, 0, swUnitsMassPropMass_e.swUnitsMassPropMass_Kilograms)
boolstatus = swModel.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsMassPropVolume, 0, swUnitsMassPropVolume_e.swUnitsMassPropVolume_Meters3)
boolstatus = swModel.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsLinear, 0, swLengthUnit_e.swMM)
boolstatus = swModel.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsMassPropLength, 0, swLengthUnit_e.swMM)
''' Création Configuration 00 et suppression configurations Défaut, xx, PC
Set swPart = swModel
boolstatus = swPart.AddConfiguration2("00", "", "", True, False, False, True, 256)
boolstatus = swModel.DeleteConfiguration2("Défaut")
boolstatus = swModel.DeleteConfiguration2("xx")
boolstatus = swModel.DeleteConfiguration2("PC")
''' Mise en place du matériaux
swModel.SetMaterialPropertyName2 "", "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\MATERIAUX\MATERIAUX QUALI-CITE/QUALI-CITE.sldmat", "ALUMINIUM 6060"
''' Récupération de la variable NomDeFichier sans extension
NamePiece = GetFileNameWithoutExtension(swModel.GetPathName())
''' Création des Configurations 00 et RAL avec ajout des textures RAL MAT
Dim CONFIGS_DATA(14) As ConfigData
CONFIGS_DATA(1).colorName = "ALUMINIUM BRUT"
CONFIGS_DATA(1).ConfigNameSuffix = "00"
CONFIGS_DATA(1).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\APPARENCES\alu inox.p2m"
CONFIGS_DATA(2).colorName = "RAL 1013"
CONFIGS_DATA(2).ConfigNameSuffix = "R1013"
CONFIGS_DATA(2).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 1013 mat.p2m"
CONFIGS_DATA(3).colorName = "RAL 1018"
CONFIGS_DATA(3).ConfigNameSuffix = "R1018"
CONFIGS_DATA(3).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 1018 mat.p2m"
CONFIGS_DATA(4).colorName = "RAL 2008"
CONFIGS_DATA(4).ConfigNameSuffix = "R2008"
CONFIGS_DATA(4).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 2008 mat.p2m"
CONFIGS_DATA(5).colorName = "RAL 3000"
CONFIGS_DATA(5).ConfigNameSuffix = "R3000"
CONFIGS_DATA(5).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 3000 mat.p2m"
CONFIGS_DATA(6).colorName = "RAL 3004"
CONFIGS_DATA(6).ConfigNameSuffix = "R3004"
CONFIGS_DATA(6).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 3004 mat.p2m"
CONFIGS_DATA(7).colorName = "RAL 5015"
CONFIGS_DATA(7).ConfigNameSuffix = "R5015"
CONFIGS_DATA(7).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 5015 mat.p2m"
CONFIGS_DATA(8).colorName = "RAL 6005"
CONFIGS_DATA(8).ConfigNameSuffix = "R6005"
CONFIGS_DATA(8).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 6005 mat.p2m"
CONFIGS_DATA(9).colorName = "RAL 6018"
CONFIGS_DATA(9).ConfigNameSuffix = "R6018"
CONFIGS_DATA(9).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 6018 mat.p2m"
CONFIGS_DATA(10).colorName = "RAL 6029"
CONFIGS_DATA(10).ConfigNameSuffix = "R6029"
CONFIGS_DATA(10).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 6029 mat.p2m"
CONFIGS_DATA(11).colorName = "RAL 7016"
CONFIGS_DATA(11).ConfigNameSuffix = "R7016"
CONFIGS_DATA(11).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 7016 mat.p2m"
CONFIGS_DATA(12).colorName = "RAL 7035"
CONFIGS_DATA(12).ConfigNameSuffix = "R7035"
CONFIGS_DATA(12).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 7035 mat.p2m"
CONFIGS_DATA(13).colorName = "RAL 7037"
CONFIGS_DATA(13).ConfigNameSuffix = "R7037"
CONFIGS_DATA(13).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 7037 mat.p2m"
CONFIGS_DATA(14).colorName = "RAL 9005"
CONFIGS_DATA(14).ConfigNameSuffix = "R9005"
CONFIGS_DATA(14).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 9005 mat.p2m"
''' Ajout de propriétés à toutes les configurations
Dim i As Integer
For i = 0 To UBound(CONFIGS_DATA)
confName = ""
If CONFIGS_DATA(i).ConfigNameSuffix <> "" Then
confName = CONFIGS_DATA(i).ConfigNameSuffix
CodArt = NamePiece & "-" & CONFIGS_DATA(i).ConfigNameSuffix
End If
If i <> 0 Then
swModel.AddConfiguration3 confName, "", "", 0
''' Ajout de la propriété "Code Article"
CodeArticle = CodArt
bRet = swModel.DeleteCustomInfo2(confName, "Code Article")
bRet = swModel.AddCustomInfo3(confName, "Code Article", swCustomInfoText, CodeArticle)
''' Ajout de la propriété "PROFILS"
bRet = swModel.DeleteCustomInfo2(confName, "DESIGNATION 2")
bRet = swModel.DeleteCustomInfo2(confName, "PROFILS")
bRet = swModel.AddCustomInfo3(confName, "PROFILS", swCustomInfoText, "POTEAUXHEXA")
''' Ajout de la propriété "MASSE" avec la valeur swMasse
''' Chr(34) permet d'ajouter le caractère "
bRet = swModel.DeleteCustomInfo2(confName, "masse")
bRet = swModel.AddCustomInfo3(confName, "masse", swCustomInfoText, Chr(34) & "SW-Mass" & Chr(34))
''' Ajout de la propriété "POIDS" avec la valeur swMasse
''' Chr(34) permet d'ajouter le caractère "
bRet = swModel.DeleteCustomInfo2(confName, "POIDS")
bRet = swModel.AddCustomInfo3(confName, "POIDS", swCustomInfoText, Chr(34) & "SW-Mass" & Chr(34))
''' ajoute un propriété personnalisée edition avec la valeur MATERIAUX
''' Chr(34) permet d'ajouter le caractère "
bRet = swModel.DeleteCustomInfo2(confName, "MATERIAUX")
bRet = swModel.AddCustomInfo3(confName, "MATERIAUX", swCustomInfoText, Chr(34) & "SW-Material" & Chr(34))
''' on reconstruit la pièce
swModel.ForceRebuild3 False
Set swCustProp = swModelDocExt.CustomPropertyManager(confName)
''' Récupération de la propriété de Longueur Cube Visualisation
bRet = swCustProp.Get6("Longueur totale du cube de visualisation", False, sValout, sLongueur, False, False)
''' Renseignement de la propriété LONGUEUR avec la valeur "sVal"
bRet = swCustProp.Add3("LONGUEUR", 30, sLongueur, 1)
''' Renseignement de la propriété DESIGNATION 2 avec la valeur "sVal"
bRet = swCustProp.Add3("DESIGNATION 2", 30, sLongueur, 1)
''' on reconstruit la pièce
swModel.ForceRebuild3 False
''' Conversion du texte en valeur décimale, multiplication LONGUEUR x RATIO SURFACE et conversion en donné de type texte
sValSurf = CStr(Format(CDec(sLongueur) * 0.000304, "0.000"))
''' Renseignement de la propriété SURFACE PIECE avec la valeur "sVal"
bRet = swCustProp.Add3("SURFACE PIECE", 30, sValSurf, 1)
End If
swModel.ConfigurationManager.ActiveConfiguration.Name = confName
If CONFIGS_DATA(i).MaterialFilePath <> "" Then
AddRenderMaterial swModel, CONFIGS_DATA(i).MaterialFilePath
End If
AddConfigProperty swModel, CONFIGS_DATA(i).colorName
Next
End Sub
Sub AddRenderMaterial(model As SldWorks.ModelDoc2, path As String)
Dim swRenderMaterial As SldWorks.RenderMaterial
Set swRenderMaterial = model.Extension.CreateRenderMaterial(path)
If False <> swRenderMaterial.AddEntity(model) Then
If False = model.Extension.AddDisplayStateSpecificRenderMaterial(swRenderMaterial, swDisplayStateOpts_e.swThisDisplayState, Empty, -1, -1) Then
Err.Raise vbError, "", "Failed to apply render material to display state"
End If
Else
Err.Raise vbError, "", "Failed to add model as entity to render material"
End If
End Sub
''' Attribution Propriété "RAL"
Sub AddConfigProperty(model As SldWorks.ModelDoc2, colorName As String)
Dim swCustPrpMgr As SldWorks.CustomPropertyManager
Set swCustPrpMgr = model.Extension.CustomPropertyManager("")
Dim propRal As String
swCustPrpMgr.Get4 PROP_RAL, False, "", propRal
Set swCustPrpMgr = model.ConfigurationManager.ActiveConfiguration.CustomPropertyManager
swCustPrpMgr.Add3 PROP_RAL, swCustomInfoType_e.swCustomInfoText, propRal & colorName, swCustomPropertyAddOption_e.swCustomPropertyReplaceValue
End Sub
Function GetFileNameWithoutExtension(filePath As String) As String
GetFileNameWithoutExtension = Mid(filePath, InStrRev(filePath, "\") + 1, InStrRev(filePath, ".") - InStrRev(filePath, "\") - 1)
End Function
Z góry dziękuję
Uruchamia makro w trybie edycji i krok po kroku i sprawdza wartości różnych zmiennych używanych w tym wierszu (w błędzie), jeśli jedna z nich jest pusta lub nienumeryczna, możliwe, że jest powiązana.
Aby to zrobić, dodaj debug.print sLength, inny z debug.print Format(Cdec...), na przykład, aby sprawdzić, czy działa dobrze, czy nie.
Nie ma czasu na dokładne przyjrzenie się makr.
Tryb krok po kroku pozwala, a dodanie debug.print pozwala na początku zobaczyć stan różnych zmiennych w oknie wykonywania (w przeciwnym razie zobacz okno Zmienne lokalne), ale dla mnie mniej praktyczne.
Dziękujemy @sbadenis
Próbowałem, ale nie mogę sobie wyobrazić, skąd bierze się ten problem.
Czy powinniśmy dodać RAZ wartości na początku makra (jeśli istnieje)? Mam wrażenie, że po jego wypełnieniu makro się zawiesza
Twój problem polega na tym, że twoje właściwości kostki wizualizacji są tworzone w konfiguracji R9005:
Aby zobaczyć, że wartość jest pusta w trybie krokowym, po minięciu linii najedź myszką na zmienną sLength i zobaczysz, że jest równa niczym:
Prościej jest utworzyć obwiednię po wyczyszczeniu konfiguracji i tam to działa:
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swConfigMgr As SldWorks.ConfigurationManager
Dim swConfig As SldWorks.Configuration
Dim vConfigName As Variant
Dim vConfigNameArr As Variant
Dim sSpecConfigNameArr(0) As String
Dim vSpecConfigNameArr As Variant
Dim dimValue As Variant
Dim Part As Object
Dim stnameConfig As String
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Dim i As Integer
Dim swErrors As Long
Dim swWarnings As Long
Dim swPart As SldWorks.PartDoc
Dim tConfig() As String
Dim swModelDocExt As ModelDocExtension
Dim swCustProp As CustomPropertyManager
Dim sMasse As String
Dim sValout As String
Dim sValSurf As String
Dim sValLong As String
Dim bRet As String
Dim NamePiece As String
Dim confName As String
Dim confNameF As String
Dim MaterialFilePath As String
Dim ConfigNameSuffix As String
Dim colorName As String
Dim CodArt As String
Dim CodeArticle As String
Dim sLongueur As String
Dim sCentreMasseY As String
Type ConfigData
MaterialFilePath As String
ConfigNameSuffix As String
colorName As String
confName As String
confNameF As String
NamePiece As String
CodArt As String
CodeArticle As String
End Type
Const PROP_RAL As String = "RAL"
Const PROP_CodeArticle As String = "Code Article"
Sub main()
Set swApp = Application.SldWorks
Dim swModel As SldWorks.ModelDoc2
''' Récupération du document actif
Set swModel = swApp.ActiveDoc
Set swConfigMgr = swModel.ConfigurationManager
''' Récupération de la configuration active
Set swConfig = swConfigMgr.ActiveConfiguration
stnameConfig = swConfig.Name
vConfigNameArr = swModel.GetConfigurationNames
Set swModelDocExt = swModel.Extension
Set Part = swApp.ActiveDoc
Dim swFeat As Object
Dim swFeatMgr As Object
''' Création Configuration 00 et suppression configurations Défaut, xx, PC
Set swPart = swModel
boolstatus = swPart.AddConfiguration2("00", "", "", True, False, False, True, 256)
boolstatus = swModel.DeleteConfiguration2("Défaut")
boolstatus = swModel.DeleteConfiguration2("xx")
boolstatus = swModel.DeleteConfiguration2("PC")
''' Suppression Cube de visualistaion éxistant
Set Part = swApp.ActiveDoc
boolstatus = Part.Extension.SelectByID2("Cube de visualisation", "BBOXSKETCH", 0, 0, 0, False, 0, Nothing, 0)
boolstatus = Part.Extension.SelectByID2("Cube de visualisation", "BBOXSKETCH", 0, 0, 0, False, 0, Nothing, 0)
Part.EditDelete
''' Création Cube de visualisation
Set swFeatMgr = Part.FeatureManager
Dim swFeatData As Object
Set swFeatData = swFeatMgr.CreateDefinition(swFeatureNameID_e.swFmBoundingBox)
swFeatData.IncludeHiddenBodies = False
swFeatData.IncludeSurfaces = False
swFeatData.ReferenceFaceOrPlane = 1
Set swFeat = swFeatMgr.CreateFeature(swFeatData)
Part.ClearSelection2 True
boolstatus = Part.Extension.SelectByID2("Cube de visualisation", "BBOXSKETCH", 0, 0, 0, False, 0, Nothing, 0)
Part.BlankSketch
''' Réglages Préférences SolidWorks
boolstatus = swModel.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsLinearFractionDenominator, 0, 0)
boolstatus = swModel.Extension.SetUserPreferenceToggle(swUserPreferenceToggle_e.swUnitsLinearFeetAndInchesFormat, 0, False)
boolstatus = swModel.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsDualLinear, 0, swLengthUnit_e.swMM)
boolstatus = swModel.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsDualLinearFractionDenominator, 0, 0)
boolstatus = swModel.Extension.SetUserPreferenceToggle(swUserPreferenceToggle_e.swUnitsDualLinearFeetAndInchesFormat, 0, False)
boolstatus = swModel.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsMassPropMass, 0, swUnitsMassPropMass_e.swUnitsMassPropMass_Kilograms)
boolstatus = swModel.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsMassPropVolume, 0, swUnitsMassPropVolume_e.swUnitsMassPropVolume_Meters3)
boolstatus = swModel.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsLinear, 0, swLengthUnit_e.swMM)
boolstatus = swModel.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsMassPropLength, 0, swLengthUnit_e.swMM)
''' Mise en place du matériaux
swModel.SetMaterialPropertyName2 "", "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\MATERIAUX\MATERIAUX QUALI-CITE/QUALI-CITE.sldmat", "ALUMINIUM 6060"
''' Récupération de la variable NomDeFichier sans extension
NamePiece = GetFileNameWithoutExtension(swModel.GetPathName())
''' Création des Configurations 00 et RAL avec ajout des textures RAL MAT
Dim CONFIGS_DATA(14) As ConfigData
CONFIGS_DATA(1).colorName = "ALUMINIUM BRUT"
CONFIGS_DATA(1).ConfigNameSuffix = "00"
CONFIGS_DATA(1).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\APPARENCES\alu inox.p2m"
CONFIGS_DATA(2).colorName = "RAL 1013"
CONFIGS_DATA(2).ConfigNameSuffix = "R1013"
CONFIGS_DATA(2).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 1013 mat.p2m"
CONFIGS_DATA(3).colorName = "RAL 1018"
CONFIGS_DATA(3).ConfigNameSuffix = "R1018"
CONFIGS_DATA(3).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 1018 mat.p2m"
CONFIGS_DATA(4).colorName = "RAL 2008"
CONFIGS_DATA(4).ConfigNameSuffix = "R2008"
CONFIGS_DATA(4).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 2008 mat.p2m"
CONFIGS_DATA(5).colorName = "RAL 3000"
CONFIGS_DATA(5).ConfigNameSuffix = "R3000"
CONFIGS_DATA(5).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 3000 mat.p2m"
CONFIGS_DATA(6).colorName = "RAL 3004"
CONFIGS_DATA(6).ConfigNameSuffix = "R3004"
CONFIGS_DATA(6).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 3004 mat.p2m"
CONFIGS_DATA(7).colorName = "RAL 5015"
CONFIGS_DATA(7).ConfigNameSuffix = "R5015"
CONFIGS_DATA(7).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 5015 mat.p2m"
CONFIGS_DATA(8).colorName = "RAL 6005"
CONFIGS_DATA(8).ConfigNameSuffix = "R6005"
CONFIGS_DATA(8).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 6005 mat.p2m"
CONFIGS_DATA(9).colorName = "RAL 6018"
CONFIGS_DATA(9).ConfigNameSuffix = "R6018"
CONFIGS_DATA(9).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 6018 mat.p2m"
CONFIGS_DATA(10).colorName = "RAL 6029"
CONFIGS_DATA(10).ConfigNameSuffix = "R6029"
CONFIGS_DATA(10).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 6029 mat.p2m"
CONFIGS_DATA(11).colorName = "RAL 7016"
CONFIGS_DATA(11).ConfigNameSuffix = "R7016"
CONFIGS_DATA(11).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 7016 mat.p2m"
CONFIGS_DATA(12).colorName = "RAL 7035"
CONFIGS_DATA(12).ConfigNameSuffix = "R7035"
CONFIGS_DATA(12).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 7035 mat.p2m"
CONFIGS_DATA(13).colorName = "RAL 7037"
CONFIGS_DATA(13).ConfigNameSuffix = "R7037"
CONFIGS_DATA(13).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 7037 mat.p2m"
CONFIGS_DATA(14).colorName = "RAL 9005"
CONFIGS_DATA(14).ConfigNameSuffix = "R9005"
CONFIGS_DATA(14).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 9005 mat.p2m"
''' Ajout de propriétés à toutes les configurations
Dim i As Integer
For i = 0 To UBound(CONFIGS_DATA)
confName = ""
If CONFIGS_DATA(i).ConfigNameSuffix <> "" Then
confName = CONFIGS_DATA(i).ConfigNameSuffix
CodArt = NamePiece & "-" & CONFIGS_DATA(i).ConfigNameSuffix
End If
If i <> 0 Then
swModel.AddConfiguration3 confName, "", "", 0
''' Ajout de la propriété "Code Article"
CodeArticle = CodArt
bRet = swModel.DeleteCustomInfo2(confName, "Code Article")
bRet = swModel.AddCustomInfo3(confName, "Code Article", swCustomInfoText, CodeArticle)
''' Ajout de la propriété "PROFILS"
bRet = swModel.DeleteCustomInfo2(confName, "DESIGNATION 2")
bRet = swModel.DeleteCustomInfo2(confName, "PROFILS")
bRet = swModel.AddCustomInfo3(confName, "PROFILS", swCustomInfoText, "POTEAUXHEXA")
''' Ajout de la propriété "MASSE" avec la valeur swMasse
''' Chr(34) permet d'ajouter le caractère "
bRet = swModel.DeleteCustomInfo2(confName, "masse")
bRet = swModel.AddCustomInfo3(confName, "masse", swCustomInfoText, Chr(34) & "SW-Mass" & Chr(34))
''' Ajout de la propriété "POIDS" avec la valeur swMasse
''' Chr(34) permet d'ajouter le caractère "
bRet = swModel.DeleteCustomInfo2(confName, "POIDS")
bRet = swModel.AddCustomInfo3(confName, "POIDS", swCustomInfoText, Chr(34) & "SW-Mass" & Chr(34))
''' ajoute un propriété personnalisée edition avec la valeur MATERIAUX
''' Chr(34) permet d'ajouter le caractère "
bRet = swModel.DeleteCustomInfo2(confName, "MATERIAUX")
bRet = swModel.AddCustomInfo3(confName, "MATERIAUX", swCustomInfoText, Chr(34) & "SW-Material" & Chr(34))
''' on reconstruit la pièce
swModel.ForceRebuild3 False
Set swCustProp = swModelDocExt.CustomPropertyManager(confName)
''' Récupération de la propriété de Longueur Cube Visualisation
bRet = swCustProp.Get6("Longueur totale du cube de visualisation", False, sValout, sLongueur, False, False)
''' Renseignement de la propriété LONGUEUR avec la valeur "sVal"
bRet = swCustProp.Add3("LONGUEUR", 30, sLongueur, 1)
''' Renseignement de la propriété DESIGNATION 2 avec la valeur "sVal"
bRet = swCustProp.Add3("DESIGNATION 2", 30, sLongueur, 1)
''' on reconstruit la pièce
swModel.ForceRebuild3 False
''' Conversion du texte en valeur décimale, multiplication LONGUEUR x RATIO SURFACE et conversion en donné de type texte
sValSurf = CStr(Format(CDec(sLongueur) * 0.000304, "0.000"))
''' Renseignement de la propriété SURFACE PIECE avec la valeur "sVal"
bRet = swCustProp.Add3("SURFACE PIECE", 30, sValSurf, 1)
End If
swModel.ConfigurationManager.ActiveConfiguration.Name = confName
If CONFIGS_DATA(i).MaterialFilePath <> "" Then
AddRenderMaterial swModel, CONFIGS_DATA(i).MaterialFilePath
End If
AddConfigProperty swModel, CONFIGS_DATA(i).colorName
Next
End Sub
Sub AddRenderMaterial(model As SldWorks.ModelDoc2, path As String)
Dim swRenderMaterial As SldWorks.RenderMaterial
Set swRenderMaterial = model.Extension.CreateRenderMaterial(path)
If False <> swRenderMaterial.AddEntity(model) Then
If False = model.Extension.AddDisplayStateSpecificRenderMaterial(swRenderMaterial, swDisplayStateOpts_e.swThisDisplayState, Empty, -1, -1) Then
Err.Raise vbError, "", "Failed to apply render material to display state"
End If
Else
Err.Raise vbError, "", "Failed to add model as entity to render material"
End If
End Sub
''' Attribution Propriété "RAL"
Sub AddConfigProperty(model As SldWorks.ModelDoc2, colorName As String)
Dim swCustPrpMgr As SldWorks.CustomPropertyManager
Set swCustPrpMgr = model.Extension.CustomPropertyManager("")
Dim propRal As String
swCustPrpMgr.Get4 PROP_RAL, False, "", propRal
Set swCustPrpMgr = model.ConfigurationManager.ActiveConfiguration.CustomPropertyManager
swCustPrpMgr.Add3 PROP_RAL, swCustomInfoType_e.swCustomInfoText, propRal & colorName, swCustomPropertyAddOption_e.swCustomPropertyReplaceValue
End Sub
Function GetFileNameWithoutExtension(filePath As String) As String
GetFileNameWithoutExtension = Mid(filePath, InStrRev(filePath, "\") + 1, InStrRev(filePath, ".") - InStrRev(filePath, "\") - 1)
End Function
Dzięki @sbadenis , przetestowałem kod z kostką po wyczyszczeniu konfiguracji, ale nadal mam błąd 13 w tym wierszu:
''' Conversion du texte en valeur décimale, multiplication LONGUEUR x RATIO SURFACE et conversion en donné de type texte
sValSurf = CStr(Format(CDec(sLongueur) * 0.000304, "0.000"))
A ja mam sześcian, który jest w trybie usuniętym w drzewie, więc makro się blokuje, bo nie odzyskuje długości
Z częścią, którą miałem, to zadziałało.
Być może Twoja konfiguracja została już wcześniej utworzona, w takim przypadku podczas przewijania każdej konfiguracji musiałbyś anulować usunięcie kostki wizualizacji
W przeciwnym razie podaj część lub to nie działa (część wykonana na przykład, jeśli poufność) dla mojej części jestem w sw2020. (z dostępem do 1 SW223)
Testowałem z usunięciem kostki i bez niego, ale mam ten sam błąd wracający.
Czy nie powinniśmy umieścić usunięcia kostki wrehabilitacyjnej na końcu makra. Po wypełnieniu właściwości nie ma już potrzeby ich wykonywania?
Ale trudno mi się zorientować, gdzie muszę to wcisnąć, aby w końcu to się stało...
W załączeniu egzemplarz wykonany na SW 2022.
Potem to już tylko podstawowe wytłaczanie... Ale chciałbym, aby zmieniając długość, możemy zaktualizować właściwości, uruchamiając ponownie to samo makro
PRÓBKA TESTU. SLDPRT (161.7 KB)
Powodem jest to, że w opcjach konfiguracyjnych masz ten znacznik wyboru:
''' Création Configuration 00 et suppression configurations Défaut, xx, PC
Set swPart = swModel
boolstatus = swPart.AddConfiguration2("00", "", "", True, False, False, True, 256)
boolstatus = swModel.DeleteConfiguration2("Défaut")
boolstatus = swModel.DeleteConfiguration2("xx")
boolstatus = swModel.DeleteConfiguration2("PC")
'On active la config 00
boolstatus = swModel.ShowConfiguration2("00")
Dziękuję @sbadenis !!
Posunąłem się nawet dalej, bo szkic kostki wizualizacji był jeszcze widoczny po ponownym uruchomieniu makra.
Dodałem więc usunięcie konfiguracji RAL na początku makra. Podobnie jak w cal, wszystko zaczyna się od zera i to działa 
.
''' Création Configuration 00 et suppression configurations Défaut, xx, PC
Set swPart = swModel
boolstatus = swPart.AddConfiguration2("00", "", "", True, False, False, True, 256)
boolstatus = swModel.DeleteConfiguration2("Défaut")
boolstatus = swModel.DeleteConfiguration2("xx")
boolstatus = swModel.DeleteConfiguration2("PC")
''' Activation de la config 00
boolstatus = swModel.ShowConfiguration2("00")
''' Suppression des configurations RAL
boolstatus = swModel.DeleteConfiguration2("R1013")
boolstatus = swModel.DeleteConfiguration2("R1018")
boolstatus = swModel.DeleteConfiguration2("R2008")
boolstatus = swModel.DeleteConfiguration2("R3000")
boolstatus = swModel.DeleteConfiguration2("R3004")
boolstatus = swModel.DeleteConfiguration2("R5015")
boolstatus = swModel.DeleteConfiguration2("R6005")
boolstatus = swModel.DeleteConfiguration2("R6018")
boolstatus = swModel.DeleteConfiguration2("R6029")
boolstatus = swModel.DeleteConfiguration2("R7016")
boolstatus = swModel.DeleteConfiguration2("R7035")
boolstatus = swModel.DeleteConfiguration2("R7037")
boolstatus = swModel.DeleteConfiguration2("R9005")
Wreszcie, czy możliwa jest zmiana głębokości usuwania materiału za pomocą makra?
Dokonałem manipulacji, nagrywając makro, ale kod nie zawiera głębi:
Option Explicit
Dim swApp As Object
Dim Part As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Sub main()
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
boolstatus = Part.Extension.SelectByID2("Face gauche", "BODYFEATURE", 0, 0, 0, False, 0, Nothing, 0)
Part.ClearSelection2 True
Part.SelectionManager.EnableContourSelection = False
End Sub
Witam
Musisz zajrzeć do funkcji FeatureCut
Metoda FeatureCut4 (IFeatureManager) - 2022 - Pomoc SOLIDWORKS API
Za pomocą funkcji FeatureCut4 mogę tworzyć usunięcia materiału ze szkicu, ale nie mogę zmienić głębokości istniejącego elementu
Czy jest to możliwe?
Witam
Prawdę mówiąc, joker. Możliwe, że w starszych plikach funkcja nie zezwala na dostęp do opcji, które mogły nie istnieć w tych starszych wersjach.