En door het X,Y,Z coördinatensysteem te veranderen?
1 like
Hallo
Een truc misschien, als eenmaal gegenereerd de kubus niet meer verandert (?) zou zijn om een volume te plaatsen (of een tijdelijke extensie op het lichaam te extruderen) dat de rechterbovenhoek van je laatste afbeelding zou afbakenen (dus hoogstens rechts uitgelijnd met de rechterrand van het blauwe gebied, en stapel aan de bovenkant uitgelijnd met de bovenste punt van het witte gebied, om een tijdelijk kader te creëren dat deze toevoeging zal afdwingen.
Het werkt trouwens met elke hoek.
1 like
Een kleine preventieboodschap trouwens:
" Drinken of bouwen, je moet kiezen!" 
4 likes
Hallo @a_eriaud
Ik heb deze macro die goed werkt door zich te oriënteren volgens XYZ:
Dim swApp As SldWorks.SldWorks
Sub main()
Set swApp = Application.SldWorks
Dim swPart As SldWorks.PartDoc
Set swPart = swApp.ActiveDoc
If Not swPart Is Nothing Then
Dim vBBox As Variant
vBBox = GetPreciseBoundingBox(swPart)
DrawBox swPart, CDbl(vBBox(0)), CDbl(vBBox(1)), CDbl(vBBox(2)), CDbl(vBBox(3)), CDbl(vBBox(4)), CDbl(vBBox(5))
Debug.Print "Width: " & CDbl(vBBox(3)) - CDbl(vBBox(0))
Debug.Print "Length: " & CDbl(vBBox(5)) - CDbl(vBBox(2))
Debug.Print "Height: " & CDbl(vBBox(4)) - CDbl(vBBox(1))
Else
MsgBox "Please open part"
End If
End Sub
Function GetPreciseBoundingBox(part As SldWorks.PartDoc) As Variant
Dim dBox(5) As Double
Dim vBodies As Variant
vBodies = part.GetBodies2(swBodyType_e.swSolidBody, True)
Dim minX As Double
Dim minY As Double
Dim minZ As Double
Dim maxX As Double
Dim maxY As Double
Dim maxZ As Double
If Not IsEmpty(vBodies) Then
Dim i As Integer
For i = 0 To UBound(vBodies)
Dim swBody As SldWorks.Body2
Set swBody = vBodies(i)
Dim x As Double
Dim y As Double
Dim z As Double
swBody.GetExtremePoint 1, 0, 0, x, y, z
If i = 0 Or x > maxX Then
maxX = x
End If
swBody.GetExtremePoint -1, 0, 0, x, y, z
If i = 0 Or x < minX Then
minX = x
End If
swBody.GetExtremePoint 0, 1, 0, x, y, z
If i = 0 Or y > maxY Then
maxY = y
End If
swBody.GetExtremePoint 0, -1, 0, x, y, z
If i = 0 Or y < minY Then
minY = y
End If
swBody.GetExtremePoint 0, 0, 1, x, y, z
If i = 0 Or z > maxZ Then
maxZ = z
End If
swBody.GetExtremePoint 0, 0, -1, x, y, z
If i = 0 Or z < minZ Then
minZ = z
End If
Next
End If
dBox(0) = minX: dBox(1) = minY: dBox(2) = minZ
dBox(3) = maxX: dBox(4) = maxY: dBox(5) = maxZ
GetPreciseBoundingBox = dBox
End Function
Sub DrawBox(model As SldWorks.ModelDoc2, minX As Double, minY As Double, minZ As Double, maxX As Double, maxY As Double, maxZ As Double)
model.ClearSelection2 True
model.SketchManager.Insert3DSketch True
model.SketchManager.AddToDB = True
model.SketchManager.CreateLine maxX, minY, minZ, maxX, minY, maxZ
model.SketchManager.CreateLine maxX, minY, maxZ, minX, minY, maxZ
model.SketchManager.CreateLine minX, minY, maxZ, minX, minY, minZ
model.SketchManager.CreateLine minX, minY, minZ, maxX, minY, minZ
model.SketchManager.CreateLine maxX, maxY, minZ, maxX, maxY, maxZ
model.SketchManager.CreateLine maxX, maxY, maxZ, minX, maxY, maxZ
model.SketchManager.CreateLine minX, maxY, maxZ, minX, maxY, minZ
model.SketchManager.CreateLine minX, maxY, minZ, maxX, maxY, minZ
model.SketchManager.CreateLine minX, minY, minZ, minX, maxY, minZ
model.SketchManager.CreateLine minX, minY, maxZ, minX, maxY, maxZ
model.SketchManager.CreateLine maxX, minY, minZ, maxX, maxY, minZ
model.SketchManager.CreateLine maxX, minY, maxZ, maxX, maxY, maxZ
model.SketchManager.AddToDB = False
model.SketchManager.Insert3DSketch True
End Sub
Mijn assemblages zijn altijd evenwijdig aan de bovenste vlakken, dus normaal aan Y, maar niet noodzakelijkerwijs evenwijdig aan X (of Z).
Ik weet niet of VBA-macrofuncties het mogelijk zouden maken om van tevoren het gezicht te selecteren dat de oriëntatiereferentie zou zijn om een goed georiënteerde 3D-schets te genereren...
Als iemand een idee heeft hoe dit in macro te doen, ben ik geïnteresseerd 
Hallo
Inderdaad, er kan iets te maken hebben met deze macro...
Maar ik weet er niet genoeg van om te beginnen...
Ik denk dat je je zou moeten verdiepen in de " GetExtremePoint " functie om het uiterste punt te vinden terwijl je evenwijdig aan een vlak blijft.
Het is maar een idee...
Ik denk dat er op dit forum macro-pro's zijn, sommigen hebben me al veel geholpen...
Heb van tevoren een goed weekend.
2 likes
Hallo @MLG ,
Als we vasthouden aan het idee van een " envelopkubus " (in feite een rechthoekig parallellepipedum), staan de drie genererende vlakken loodrecht. Als de eerste wordt gekozen, is het dan voldoende om een richting in dit vlak te geven om de drievlakker volledig te beperken.
Uitgaande van de Codestack-macro die door @MLG is voorgesteld en bedoeld is voor een onderdeel, denken we dat we deze gewoon hoeven aan te passen aan een assemblage door de delen van de constructieboom te vegen en de projectierichtingen te forceren.
Eenvoudig van uiterlijk, maar de paar voorziene momenten veranderen in uren. Gelukkig was het weer somber...
Het resultaat is beschikbaar in de bijgevoegde macro. Gebruiksaanwijzing:
- Een assemblage moet worden geopend in SolidWorks.
- Een vlak en richting (rechte rand of schetssegment) worden in deze volgorde geselecteerd in het grafische gebied.
- De macro wordt uitgevoerd.
Resultaten:
- De envelopkubus wordt weergegeven als een 3D-schets in de assemblage.
- de randen van de kubus worden gespecificeerd in een UserForm.
Zwakte in vergelijking met de SolidWorks " visualisatiekubus " is dat de envelopkubus bevroren is op de geometrie op het moment van zijn creatie. Er wordt geen rekening gehouden met een verdere evolutie van de vormen van de assemblage.
Zoals altijd, macro zonder beveiligingen, zonder garantie op resultaten, vooral te testen op grote assemblages.
Vriendelijke groeten.
Aangepaste macro, hieronder te downloaden...
5 likes
Hallo @m_blt
Ik heb de code doorgenomen en er is werk aan de winkel!! GOED GEDAAN 
Aan de andere kant heb ik getest op een van mijn assemblages, maar er gebeurt niets.
Geen foutmelding, zelfs niet als ik het forceer door de macro op een munt te starten.
Wat, van wat ik in de code kon zien, een waarschuwingsvenster voor mij zou moeten genereren.
Enig idee wat te doen?
1 like
Bij het starten van de hoofdsub vanuit de editor via F8, toont het me een ontbrekende project- of bibliotheekfout:
En als ik naar de fout kijk, begrijp ik de ontbrekende bibliotheek beter (SW2023)
Misschien heb jij hetzelfde probleem. Welke versie van SW heb je?
@m_blt ik wilde een kijkje nemen uit nieuwsgierigheid en interesse, omdat je macro's me over het algemeen boeien!
Edit: door uit te vinken wat er ontbreekt en de 3 bibliotheken versie 2020 te controleren werkt het!
Opnieuw ben ik verbaasd over deze code:
3 likes
De macro werkt niet op een onderdeel omdat het door de build-boom van een assembly reist. Als je er al bent, zou je dit bericht moeten hebben:
Persoonlijk heb ik de macro op verschillende assemblages getest, waarvan de " zwaarste " 278 onderdelen heeft, zonder enige anomalie op te merken. Als u de macro uitvoert zonder objecten te selecteren, moet u ten minste de UserForm-kaart zien.
Ik bevestig het vermoeden van @sbadenis : de storing kan te wijten zijn aan het ontbreken van bepaalde verwijzingen naar VBA-objecten. Dit zijn degene die ik gebruik met de 2023-versie van SolidWorks:
Controleer ook of de schetsweergave is geactiveerd in de montage, je weet maar nooit...
Nog een aanwijzing: de macro is geschreven met SW 2023. Misschien is er een niet-bestaande functie als u een oudere versie gebruikt. Ook al zou je een foutmelding moeten zien... Afgaande op de illustratie van zijn boodschap, heeft @sbadenis het laten werken met een versie uit 2020
Heeft de assemblage waarop je de macro hebt getest een eigenaardigheid waardoor deze niet goed werkt? U moet een van uw assemblages delen en aangeven welke versie van SW u gebruikt.
2 likes
@m_blt
Als ik dit werk zie, zeg ik tegen mezelf dat het meer dan tijd was om de raaklijn te nemen die evenwijdig is aan het vlak. Trouwens, een goede deal wordt altijd gewaardeerd.
C dlt
4 likes
Ik heb de wijzigingen in de referenties toegepast door de 2022 te controleren voor mijn versie:
En de macro werkte goed, het is TOP @m_blt 
:
Ik heb zojuist de ptLoc van de lengte en diepte van de kubus veranderd, die voor mij omgekeerd waren (ptLoc(4) en (1)), evenals de precisie om geen decimaal te hebben:
UserForm1.Label3.Caption = "Longueur du cube : " & Format(longueur(ptLoc(0), ptLoc(4)), "#####0")
UserForm1.Label4.Caption = "Largeur du cube : " & Format(longueur(ptLoc(0), ptLoc(2)), "#####0")
UserForm1.Label5.Caption = "Profondeur du cube : " & Format(longueur(ptLoc(0), ptLoc(1)), "#####0")
Het is PERFECT.
Aan de andere kant zou ik deze waarden willen ophalen en ze associëren met variabelen in alle configuraties, maar ik weet niet waar en hoe (sub, functie ...) ik dit moet invoegen:
Dim i As Integer
Dim tConfig() As String
Dim swErrors As Long
Dim swWarnings As Long
Do
'récupère le document actif dans SW
Set swModel = swApp.ActiveDoc
If Not swModel Is Nothing Then
'Boucle sur toutes les configurations
tConfig = swModel.GetConfigurationNames
For i = 0 To UBound(tConfig)
'ajoute un propriété personnalisée "DIM-Lo"
'Chr(34) permet d'ajouter le caractère "
bRet = swModel.DeleteCustomInfo2(tConfig(i), "DIM-Lo")
bRet = swModel.AddCustomInfo3(tConfig(i), "DIM-Lo", swCustomInfoText, Chr(34) & Format(longueur(ptLoc(0), ptLoc(4)), "#####0") & Chr(34))
'ajoute un propriété personnalisée "DIM-La"
'Chr(34) permet d'ajouter le caractère "
bRet = swModel.DeleteCustomInfo2(tConfig(i), "DIM-La")
bRet = swModel.AddCustomInfo3(tConfig(i), "DIM-La", swCustomInfoText, Chr(34) & Format(longueur(ptLoc(0), ptLoc(2)), "#####0") & Chr(34))
'ajoute un propriété personnalisée "DIM-Ha"
'Chr(34) permet d'ajouter le caractère "
bRet = swModel.DeleteCustomInfo2(tConfig(i), "DIM-Ha")
bRet = swModel.AddCustomInfo3(tConfig(i), "DIM-Ha", swCustomInfoText, Chr(34) & Format(longueur(ptLoc(0), ptLoc(1)), "#####0") & Chr(34))
Next i
Hebben jullie een aanwijzing voor mij?
Hallo @m_blt Bravo en bedankt voor je macro. Even een kleine suggestie; Geef de xyz-assen van de aangegeven afmetingen op, bijvoorbeeld tussen haakjes, omdat de breedte, lengte, diepte op zijn zachtst gezegd relatief is.
1 like
Hoi allemaal
Nog een laatste (?) antwoord...
- De drie dimensies van de envelopkubus worden geschreven als eigenschappen in alle configuraties van de assemblage;
- Om aan de wens van @Sylk
te voldoen, heb ik aan de oorsprong van de kubus een lokaal coördinatensysteem toegevoegd, waarvan de assen zijn uitgelijnd met de randen. Om de X-, Y- en Z-richtingen te identificeren.
Het lijkt mij dat het voor @MLG in volgorde van hoogte (X), lengte (Y) en diepte (Z) is.
De bestelling kan eenvoudig worden gewijzigd op de lijnen 322 tot 334.
Een kleine afbeelding om de hoekpunten van de kubus te lokaliseren.
Vriendelijke groeten.
CubeVisuAssembly.swp (223 kB)
2 likes
Nogmaals bedankt @m_blt
Het werkt heel goed 
Ik heb een verschil in de precisie van de resultaten tussen het dialoogvenster en de variabelen in de eigenschappen (F8):
De precisie is in eenheden (geen decimalen) in het dialoogvenster
De nauwkeurigheid is 6 cijfers achter de komma
Ik heb echter dezelfde FORMAT toegepast in de code tussen wat wordt weergegeven in het dialoogvenster en in de eigenschappen (F8):
Dim valLONG As Variant
Dim valLARG As Variant
Dim valHAUT As Variant
Set ptLoc(0) = creationPt(min(0), min(1), min(2))
Set ptLoc(1) = creationPt(max(0), min(1), min(2))
Set ptLoc(2) = creationPt(min(0), max(1), min(2))
Set ptLoc(3) = creationPt(max(0), max(1), min(2))
Set ptLoc(4) = creationPt(min(0), min(1), max(2))
Set ptLoc(5) = creationPt(max(0), min(1), max(2))
Set ptLoc(6) = creationPt(min(0), max(1), max(2))
Set ptLoc(7) = creationPt(max(0), max(1), max(2))
For iPt = 0 To 7
Set ptLoc(iPt) = ptLoc(iPt).MultiplyTransform(RgToCube)
Next iPt
TraceBox ptLoc
lgAreteCube(0) = CalculLongueur(ptLoc(0), ptLoc(1))
lgAreteCube(1) = CalculLongueur(ptLoc(0), ptLoc(2))
lgAreteCube(2) = CalculLongueur(ptLoc(0), ptLoc(4))
UserForm1.Label3.Caption = "DIM-Lo : " & Format((lgAreteCube(2) / 10), "#####0")
UserForm1.Label4.Caption = "DIM-La : " & Format((lgAreteCube(0) / 10), "#####0")
UserForm1.Label5.Caption = "DIM-Ha : " & Format((lgAreteCube(1) / 10), "#####0")
UserForm1.CommandButton3.Enabled = True
valLONG = (Format((lgAreteCube(2) / 10), "#####0"))
valLARG = (Format((lgAreteCube(0) / 10), "#####0"))
valHAUT = (Format((lgAreteCube(1) / 10), "#####0"))
swConfNames = swModel.GetConfigurationNames ' Liste des noms de configurations
For iPt = LBound(swConfNames) To UBound(swConfNames) ' Boucle sur les configs
Set swCstPropMgr = swModel.Extension.CustomPropertyManager(swConfNames(iPt))
swCstPropMgr.Add3 "DIM-Lo", swCustomInfoDouble, valLONG, swCustomPropertyReplaceValue
swCstPropMgr.Add3 "DIM-La", swCustomInfoDouble, valLARG, swCustomPropertyReplaceValue
swCstPropMgr.Add3 "DIM-Ha", swCustomInfoDouble, valHAUT, swCustomPropertyReplaceValue
Next iPt
End Sub
En ik heb getest door de decimalen in de instellingen van mijn SW-eenheid te wijzigen, maar het verandert niets.
Heb je enig idee waar het probleem vandaan komt?
1 like
Aangezien u geen decimalen wilt, is de eenvoudigste manier om de variabele lgAreteCube te converteren van het type Dubbel naar Geheel getal in de instructie voor het genereren van eigenschappen.
Vervangen van de lijn:
swCstPropMgr.Add3 "CubEnvLongueurY", swCustomInfoNumber, CInt(lgAreteCube(1)), swCustomPropertyReplaceValue
Door het:
swCstPropMgr.Add3 "CubEnvLongueurY", swCustomInfoNumber, CInt(lgAreteCube(1)), swCustomPropertyReplaceValue
Aan te passen op basis van uw beoordelingen.
Als u op zoek bent naar een gedetailleerder formaat, moet u tekenreeksen gebruiken...
2 likes
Nogmaals bedankt @m_blt
Het werkt heel goed.
Ik ben sinds gisteren op Codestack aan het kijken of er een manier is om de 3D-schets een naam te geven wanneer deze is gemaakt, of om de naam van de laatste schets die in de boom is gemaakt op te halen.
Maar ik kon er niets over vinden.
Ik zou dit nodig hebben om de verwijdering van de 3D-schets aan het einde van de macro toe te voegen om onze assemblages op te schonen zodra de variabelen zijn opgehaald.
Als ik kijk naar deze code die in Solidworks is gegenereerd met een eerste 2D-schets verwijderen en vervolgens een 3D-schets verwijderen, is er geen synthaxis verschil behalve de functienaam. Of het nu 2D of 3D is, het is " SKETCH " die verschijnt:
boolstatus = Part.Extension.SelectByID2("Esquisse3D1", "SKETCH", 0, 0, 0, False, 0, Nothing, 0)
Part.EditDelete
boolstatus = Part.Extension.SelectByID2("Esquisse1", "SKETCH", 0, 0, 0, False, 0, Nothing, 0)
Part.EditDelete
Weet jij hoe je te werk moet gaan?
Bij voorbaat dank
1 like
Hallo
Op de UserForm1-record bevindt zich een knop [Wissen] waarmee de 3D-schets en het coördinatensysteem dat aan de kubus is gekoppeld, worden verwijderd. Mits dit de laatste twee functies van de boom zijn, zodat er niets wordt toegevoegd nadat de kubus is gemaakt.
Wat betreft het ophalen van de naam van een schets, de " Naam " methode maakt deel uit van de " ISketch " klasse van de API ("swSketch.Name ", zie regel 377).
Maar als je een variabele hebt die naar de schets verwijst, zoals regel 363 ("Set swSketch = swModel.SketchManager.ActiveSketch "), dan maakt de " Select4() " methode selectie mogelijk zonder dat je naar de naam hoeft te zoeken, bijvoorbeeld:
" ok = swSketch.Select4(Onwaar, Niets) "
Waarschijnlijk geërfde leden, ze zijn niet gedocumenteerd in de hulp van de " ISketch " -klasse, maar zijn gedocumenteerd in andere...
1 like
Hallo @m_blt
Nogmaals bedankt voor uw feedback.
Ik had eigenlijk niet op de DELETE-knop gedrukt.
Ik zal dit eens nader bekijken om te zien wanneer het werkt in relatie tot de informatie van de variabelen die ik heb toegevoegd ... en om mijn intellectuele armoede te verrijken in VBA 
.
Trouwens, in VBA heb ik er vanmorgen mee gesleuteld...
Een macro die de naam van de laatste functie ophaalt om deze te verwijderen.
Omdat er een 3D-schets en een drievlakker is, verdubbel ik de opdrachtregels om de 2 functies te verwijderen.
Ik weet het, het is archaïsch 
Er is zeker een manier om het eenvoudiger te maken, denk ik ...
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim swDoc As SldWorks.ModelDoc2
Dim swAssembly As SldWorks.AssemblyDoc
Dim swFeatureName As SldWorks.Feature
Sub SuppressionDeuxDernieresFonctions()
Set swApp = Application.SldWorks
Set swDoc = swApp.ActiveDoc
' Vérifie que le document SW est ouvert
If swDoc Is Nothing Then
MsgBox "Aucun document Solidworks ouvert"
Exit Sub
End If
Set swAssembly = swDoc
'''Première passe pour supprimer le trièdre
'Attribution nom dernière fonction
Set swFeatureName = swDoc.Extension.GetLastFeatureAdded
'Vérifie la selection de la fonction
If swFeatureName Is Nothing Then
MsgBox "Sélection fonction impossible"
swDoc.ClearSelection2 True
Exit Sub
End If
'Selection du nom
swFeatureName.Select True
'Suppression de la fonction
swDoc.EditDelete
'''Deuxième passe pour supprimer l'esquisse 3D
'Attribution nom dernière fonction
Set swFeatureName = swDoc.Extension.GetLastFeatureAdded
'Vérifie la selection de la fonction
If swFeatureName Is Nothing Then
MsgBox "Selection fonction Impossible"
swDoc.ClearSelection2 True
Exit Sub
End If
'Selection du nom
swFeatureName.Select True
'Suppression de la fonction
swDoc.EditDelete
End Sub
1 like
Hallo @m_blt
Ik heb een kleine vraag over de definitie van de lay-out van de doos.
Ik heb een paar gevallen waarin het niet helemaal past bij het maximum van wat zou moeten zijn. In het bijzonder op ronde delen met filets:
Ik heb het hoesje op de 2 stukken aan de rechter- en linkerkant:
Maar ik heb niet de behuizing op het bovenste stuk:
Waar in het wetboek kan ik ingrijpen om een goede tangency te verkrijgen?
De macro werkt in ieder geval prima.
Ik heb mijn arrangementen en extra functies meegenomen en het is GEWELDIG.
Hartelijk dank voor de geboden hulp.
Bij voorbaat dank.
Hallo
Het is moeilijk te zeggen wat de oorzaak is van het probleem dat u aan de orde stelt. Een paar opmerkingen:
-
Wat is de grootte van de fout, vergeleken met de algemene afmetingen van de assemblage (in mm bijvoorbeeld)?
-
Voor zover het waargenomen defect een aanzienlijke zoom vereist, kan het scherm de schuldige zijn...
-
De " GetExtremePoint() " methode bepaalt de buitenlimiet voor elk onderdeel. Dit is een numerieke berekening die intern is in de SolidWorks API's. Is het rigoureus? Zoals elke numerieke berekening, gebruikt het een kwaliteitscriterium om zijn zoekopdracht te valideren, een criterium dat onbekend is voor de gebruiker.
Op dit punt geeft SolidWorks Help commentaar op de " GetBodyBox " -functie die blijkbaar de " GetExtremePoint " -methode gebruikt:
BELANGRIJK: De geretourneerde waarden zijn bij benadering en mogen niet worden gebruikt voor vergelijkings- of berekeningsdoeleinden. Bovendien kan het begrenzingsvak variëren nadat het model opnieuw is opgebouwd.
De contouren van de " wolken" die zichtbaar zijn in de schermafbeeldingen lijken gebaseerd te zijn op splines. Zou dit de oorsprong van het pb kunnen zijn?
- De enige berekeningen in de macro zijn wijzigingen in het coördinatensysteem die gebruikmaken van de vector- en rasterfuncties van de API. Ik zie niet in hoe ze het defect kunnen genereren.
Tot slot: ik ben niet in staat om de oorzaak van het probleem te achterhalen. Kunt u het voorbeeld delen dat problematisch is? Zelfs als het wordt gedegradeerd, of via een privébericht...
Vriendelijke groeten.
4 likes