Een lichaam redden

Out of category
1

Allo Groep,

Ik ben nieuw op dit forum. Ik werk met mechanisch gelaste machines, d.w.z. met meerdere carrosserieën. Ik wil graag een aantal lichamen opslaan als een STEP, IGES-bestand omdat mijn perscontroller alleen dit type bestand kan openen. Er is de functie voor het opslaan van het lichaam (invoegen / functie / lichaam opslaan), maar deze stelt me in staat om alleen in  * op te slaan. SLDPRT

Heb je suggesties voor een andere functie? Anders zijn er macro-professionals in het gebied, ik moet toegeven dat ik er niet al te veel van weet, maar ik kan een macro zien die een lichaam in een nieuwe kamer zou invoegen zonder het op te slaan en dat zou het onderdeel in STEP opslaan, niet de suite met behulp van de vooraf gedefinieerde naam in een parameter.

Dank u allen

2

Hallo

U hoeft alleen maar een configuratie te maken en te verwijderen (met de functie "delete/keep body") wat uw controller niet nodig heeft en het op te slaan als een STEP.

3 likes
3

Hallo

Probeer het volgende:

Option Explicit
Sub main()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swPart As SldWorks.PartDoc
Dim swBody As SldWorks.Body2
Dim FilePath As String
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
If swModel Is Nothing Then MsgBox "Ouvrir une pièce": Exit Sub
If swModel.GetType <> swDocumentTypes_e.swDocPART Then MsgBox "Ouvrir une pièce": Exit Sub
Set swPart = swModel
If swModel.SelectionManager.GetSelectedObjectType3(1, -1) <> swSelectType_e.swSelSOLIDBODIES Then MsgBox "sélectionner un corps": Exit Sub
Set swBody = swModel.SelectionManager.GetSelectedObject6(1, -1)
If swBody Is Nothing Then MsgBox "sélectionner un corps": Exit Sub
swBody.Select2 False, Nothing
FilePath = Left(swModel.GetPathName, InStrRev(swModel.GetPathName, ".") - 1) & " - " & swBody.Name & ".STEP"
swPart.SaveToFile3 FilePath, swSaveAsOptions_e.swSaveAsOptions_Silent, swCutListTransferOptions_e.swCutListTransferOptions_FileProperties, False, Empty, Empty, Empty
Set swModel = swApp.ActiveDoc
swApp.CloseDoc swModel.GetTitle
End Sub

 

4 likes
4

Hallo Jerome P,

Je begreep wat ik wilde helaas de lijn om een lichaam te selecteren, het blokkeert. Ik heb het vak dat wordt geopend, maar ik kan geen selectie maken, ik kan gewoon op OK drukken en het beëindigt de macro. Ik hoop dat je me kunt helpen. Heel hartelijk bedankt.

5

WOWOWOOWOOOOO

Ik heb net betrapt dat ik de body moet selecteren voordat ik de macro start, het is te veel om aan te vinken. Ik weet niet of je me kunt helpen de functie te wijzigen, maar ik zou alleen een dialoogvenster willen toevoegen om je in staat te stellen het bestand te hernoemen of, beter nog, de naam van de bodygroep te gebruiken in plaats van de naam van de body. In mijn voorbeeld wil ik de naam "30320.1 - PL0.25" gebruiken in plaats van de standaardnaam "save body1", zie afbeelding

Bedankt

 


capture.png
6

OK. Probeer het volgende:

Option Explicit
Sub main()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swPart As SldWorks.PartDoc
Dim swBody As SldWorks.Body2
Dim FilePath As String
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
If swModel Is Nothing Then MsgBox "Ouvrir une pièce": Exit Sub
If swModel.GetType <> swDocumentTypes_e.swDocPART Then MsgBox "Ouvrir une pièce": Exit Sub
Set swPart = swModel
If swModel.SelectionManager.GetSelectedObjectType3(1, -1) <> swSelectType_e.swSelSOLIDBODIES Then MsgBox "sélectionner un corps": Exit Sub
Set swBody = swModel.SelectionManager.GetSelectedObject6(1, -1)
If swBody Is Nothing Then MsgBox "sélectionner un corps": Exit Sub
swBody.Select2 False, Nothing
FilePath = Left(swModel.GetPathName, InStrRev(swModel.GetPathName, "\")) & GetCutList(swModel, swBody.Name) & ".STEP"
swPart.SaveToFile3 FilePath, swSaveAsOptions_e.swSaveAsOptions_Silent, swCutListTransferOptions_e.swCutListTransferOptions_FileProperties, False, Empty, Empty, Empty
Set swModel = swApp.ActiveDoc
swApp.CloseDoc swModel.GetTitle
End Sub

Function GetCutList(swModel As SldWorks.ModelDoc2, BodyName As String) As String
    Dim swFeat As SldWorks.Feature
    Dim swBodyFolder As SldWorks.BodyFolder
    Dim swBody As SldWorks.Body2
    Dim vBodies As Variant
    Dim vBody As Variant
    Set swFeat = swModel.FirstFeature
    While Not swFeat Is Nothing
        If swFeat.GetTypeName = "CutListFolder" Then
            Set swBodyFolder = swFeat.GetSpecificFeature
            vBodies = swBodyFolder.GetBodies
            If Not IsEmpty(vBodies) Then
                For Each vBody In vBodies
                    Set swBody = vBody
                    If swBody.Name = BodyName Then
                        GetCutList = swFeat.Name
                        Exit Function
                    End If
                Next
            End If
        End If
        Set swFeat = swFeat.GetNextFeature
    Wend
    GetCutList = BodyName
End Function

 

2 likes
7

OK, het werkt 50-50 :(

Tijdens het testen werkt de functie "getcutlist" goed omdat de variabele "FilePath" altijd goed is. Aan de andere kant  werkt de "savetofile3" niet. Ik kan op het scherm zien dat de functie actief is omdat het de kamer opent , maar het bestand verschijnt niet in de map.

Aan de andere kant realiseerde ik me tijdens het testen één ding:

  Eerst gebruik ik de directory eigenschap "description" en SW hernoemt mijn directory's automatisch. (zie bijschrift 2) maar als ik deze parameter nog niet heb bewerkt, bijvoorbeeld de map met laatste onderdelen (items-lijst-van-gelaste-onderdelen19) of als ik deze handmatig hernoem. Bijvoorbeeld de eerste directory (test), dan werkt de macro goed en verschijnt het stappenbestand in de directory.

Denk je dat het de haakjes kunnen zijn die SW standaard aan het einde schrijft en die worden gebruikt voor ik weet niet wat?

van het type   "... <#>... "  

Bedankt.

 


capture2.png
8

Inderdaad, als er ongeldige tekens voor de bestandsnaam zijn, wordt deze niet opgeslagen.

Vervangt: FilePath = Left(swModel.GetPathName, InStrRev(swModel.GetPathName, "\")) & GetCutList(swModel, swBody.Name) & ". STAP"

door: FilePath = Left(swModel.GetPathName, InStrRev(swModel.GetPathName, "\")) & RegexStr(GetCutList(swModel, swBody.Name)) & ". STAP"

en voegt de functie toe:

Function RegexStr(ByVal Str As String) As String
Str = Split(Str, "<")(0)
Dim regex As Object
Set regex = CreateObject("VBScript.RegExp")
With regex
    .Pattern = "[^-_ a-zA-Z0-9]"
    .Global = True
    .IgnoreCase = True
    .MultiLine = False
End With
RegexStr = regex.Replace(Str, "")
End Function

 

1 like
9

Wauw geweldig!!

Ik heb een punt toegevoegd aan het einde van regex.pattern(. Patroon = "[^-_ a-zA-Z0-9.]") omdat de functie ze heeft verwijderd (bedankt google).

Bedankt voor je steun, ik zal het nooit alleen kunnen.

Je bent een god van programmeren en ik zou graag een van je discipelen willen worden. :)

Nogmaals bedankt, je maakt mijn dag goed...

 

2 likes