VBA - Als automatische Zeichnung speichern

Out of category
1

Hallo, ich möchte ein MEP erstellen , das aus einem Raum heraus seine Zeichnung öffnet und unter dem Raum und dem MEP unter demselben Namen speichert. Ich habe den folgenden Code erstellt, während ich ihn getestet habe, die Variablen sind gut, aber es funktioniert nicht ...

Vielen Dank für Ihre Hilfe:)

 

Sub main()

swApp = _ setzen

Anwendung.SldWorks

Festlegen von swModel = swApp.ActiveDoc

DateiPfad = swModel.GetPfadName

TitelP = swModel.GetTitle

PfadGröße = Len(Dateipfad)

PfadNoExtension = Links(DateiPfad, Pfadgröße - 7)

PfadMEP = PfadNoExtension & ". SLDDRW"

TitelGröße = Länge(TitelP)

TitleNoExtension = Links(TitelP, TitelGröße - 7)

TitleMEP = TitelNoExtension & " - Blatt1"

Set Part = swApp.OpenDoc6(PathMEP, 2, 0, "", longstatus, longwarnings) 'Quellassembly öffnen'

swApp.ActivateDoc2 TitelMEP, Falsch, longstatus

Set Part = swApp.ActiveDoc 'Aktivierung'

Legen Sie swApp = Application.SldWorks fest

Festlegen von swModel = swApp.ActiveDoc

bool = swModel.Extension.RunCommand(SwCommands.swCommands_SaveAs, "")

Festlegen von swModel = swApp.ActiveDoc

"Stellt den vollständigen Namen der Datei wieder her

DateiPfad = swModel.GetPfadName

PfadGröße = Len(Dateipfad)

PfadNoExtension = Links(DateiPfad, Pfadgröße - 6)

PfadMEP = PfadNoExtension & ". SLDDRW"

Set Part = swApp.ActiveDoc

longstatus = Teil.SaveAs3(DateiPfadMEP, 0, 2)

Ende Sub

 

2

Hallo

Ich rate Ihnen, sich den Makro-Datensatz anzusehen, den ich als Tutorial auf Lynkoa gesetzt habe:

http://www.lynkoa.com/tutos/3d/macro-enregistrer-sous-avec-solidworks

Sie tut, was man verlangt und jede Zeile wird kommentiert.

3

Ist es möglich, den Code direkt im Makroformat zu haben? Es wird besser lesbar sein:) 

4

Der Code ist im Link verfügbar, aber wenn Sie es auf diese Weise bevorzugen, hier ist er:

'19.03.2012 16:46 Uhr funktioniert, aber nur, wenn DRW den gleichen Namen im selben Ordner hat
Sub SAVE() 'Speichern unter
Dim swApp als SldWorks.SldWorks
Dim SWmoddoc As SldWorks.ModelDoc2
CODE als Zeichenfolge dimmen
Dim nErrors             so lange
Dimmen           nWarnungen so lange
Legen Sie swApp = Application.SldWorks fest
Legen Sie SWmoddoc = swApp.ActiveDoc fest.
Ruft den vollständigen Pfad des aktuellen Dokuments ab, einschließlich des Dateinamens:
Pfadname = UCase(SWmoddoc.GetPfadname)     
'Überprüfen Sie, ob wir uns nicht auf einem DRW = 2D befinden:
Wenn right(PathName, 3) = "DRW" dann
    MesgBOX = MsgBox("Makro, das nur von einem Teil oder einer Baugruppe gestartet werden soll", vbMsgBoxSetForeground, "Speichern unter (von LPR)")
    Sub beenden
    ElseIf Right(Pfadname, 3) = "PRT" dann
        DRWPath = Ersetzen(Pfadname, "PRT", "DRW")
    ElseIf Right(Pfadname, 3) = "ASM" dann
        DRWPath = Ersetzen(Pfadname, "ASM", "DRW")
Ende, wenn
Ruft den Pfad zum aktuellen Dokument ohne den Dateinamen ab:
FilePath = Links(Pfadname, InStrRev(Pfadname, "\"))
Ruft den Dateinamen ab:
Dateiname = Rechts(Pfadname, Len(Pfadname) - InStrRev(Pfadname, "\")) 
'ruft die benutzerdefinierte Eigenschaft ab (=CustomInfo) CODE (CustomInfo) =>SPEZIFISCHER CODE:
CODE = SWmoddoc.CustomInfo("code")
Wenn CODE = "" Dann
'Wenn der Code nicht existiert, rufen Sie die ersten 8 Zeichen der Datei =>SPECIFIC CODE & 8 Zeichen ab
    CODE = Links(Ersetzen(Dateiname, " ", ""), 8)    
Ende, wenn    
'ruft die Dateibezeichnung ab (in unserem Fall FR-Label) =>SPEZIFISCHES FR-Label:
FR = SWmoddoc.CustomInfo("FRLED")
Wenn libelleFR = "" Dann
' ruft die Bezeichnung basierend auf dem Dateinamen -7 Zeichen = Erweiterung (. SLDASM zum Beispiel) =>SPEZIFISCHE VERLEUMDUNGFR:
    libelleFR = Links(Rechts(Dateiname, Len(Dateiname) - InStr(Dateiname, "-")), Len(Rechts(Dateiname, Len(Dateiname) - InStr(Dateiname, "-"))) - 7)
Ende, wenn
"Bestätigungsanforderung:
RET = MsgBox("Möchten Sie eine Kopie dieses Teils (oder dieser Baugruppe) und seiner Zeichnung unter neuem Code erstellen?" & vbNewLine & vbNewLine & "WARNUNG: Die Datei wird in ALLEN geöffneten SolidWorks Dateien ersetzt!", vbOKCancel + vbExclamation + vbMsgBoxSetForeground + vbSystemModal, "Speichern unter (von LPR)")
"Bei Abbruch: Ende des Programms:
Wenn RET = vbAbbrechen, dann Ende
 

5

'Wenn der drw (=2D) existiert:
Wenn dir$(DRWPath) <> "" dann
    Dann öffnen wir es:
    Set open = swApp.OpenDoc6(DRWPath, swDocDRAWING, swOpenDocOptions_Silent, "", nErrors, nWarnings)
    DRWNull = 0
    Oder
    "Oder wir warnen davor, dass es nicht in derselben Datei existiert:
    DRWNull = MsgBox("Die Zeichnung wurde auch nicht gefunden:" & vbNewLine & vbNewLine & "- der Name unterscheidet sich von 3D" & vbNewLine & "- der Ordner unterscheidet sich von 3D" & vbNewLine & "- die Zeichnung existiert nicht" & vbNewLine & "Möchten Sie fortfahren?", vbOKCancel + vbExclamation + vbMsgBoxSetForeground + vbSystemModal, "Speichern unter (von LPR)")
    " Wir verlassen das Programm
    Wenn DRWNull = 2, dann sub beenden
Ende, wenn
"Solange (Angaben im neuen Kodex): 
Tun
    'der neue Code wird nicht ausgefüllt =>SPEZIFISCHER Code, der standardmäßig vorgeschlagen wird:
    NewCode = InputBox("Um dies zu tun, geben Sie bitte den neuen Code ein: ", "Save-As (By LPR)", CODE)
    "Wenn wir stornieren:
    Wenn StrPtr(NewCode) = 0, dann
        MsgBox "Vorgang abgebrochen"
        Wir gehen:
        Sub beenden
    Ende, wenn
    'Prüfen Sie, ob der Code numerisch ist =>SPEZIFISCHER CODE-nur numerisch:
    Do while IsNumeric(NewCode) = false und MessageBox <> "6"
        MessageBox = MsgBox("Seien Sie vorsichtig, Ihr Code ist nicht eindeutig numerisch!" & vbNewLine & "Ist das beabsichtigt?", vbJaNein)
        If MessageBox = vbNo then NewCode = InputBox("Um zu speichern unter, geben Sie bitte den neuen Code ohne Leerzeichen an: ", "Save-under by LPR", NewCode)
    Schleife
'do-Schleife, solange der Code nicht 8 Zeichen =>SPEZIFISCHER 8-stelliger CODE ist
Schleife während len(NewCode) <> 8
"Solange (neue Namensangabe = FR-Etikett):
Tun
    "Wie lautet der neue Name? =>SPEZIFISCHES LabelFR standardmäßig vorgeschlagen:
    NewName = InputBox ("Bitte geben Sie den neuen Namen an: " & vbNewLine & vbNewLine & "Denken Sie daran, in Großbuchstaben zu schreiben", "Save-under by LPR", FR label)
    "Wenn wir stornieren:
    Wenn StrPtr(NewName) = 0, dann
        MsgBox "Vorgang abgebrochen"
        Wir gehen:
        Sub beenden
    Ende, wenn
    'Überprüfen Sie, ob der Name Zeichen enthält, die in Windows verboten sind' \ / : * ? > < | 
    Ausführen, während InStr(NewName, Chr(34)) > 0 oder InStr(NewName, "\") > 0 oder InStr(NewName, "/") > 0 _
    oder InStr(NewName, ":") > 0 oder InStr(NewName, "*") > 0 oder InStr(NewName, "?") > 0 oder InStr(NewName, "<") > 0 oder InStr(NewName, ">") > 0 oder InStr(NewName, "|") > 0
        "Fortbestehen von verbotener Natur
        NewName = InputBox("Warnung, der Name enthält mindestens eines der verbotenen Zeichen \/:*?""<>|" & vbNewLine & vbNewLine & _
        "Bitte geben Sie den neuen Namen an: ", "Save-under by LPR", NewName)
    Schleife
'Do-Schleife, solange der neue Name leer ist
Schleife, während NewName = ""
 

6

'Solange (Pfadinformation oder Speichern = Pfadname):
Tun
    »Was ist der Weg?
    FilePath = InputBox("" & vbNewLine & " ", "Save-Under von LPR", FilePath)
    Wenn StrPtr(FilePath) = 0, dann
        MsgBox "Vorgang abgebrochen"
        Sub beenden
    Ende, wenn
    Wenn es nicht da ist:
    Wenn Right(FilePath, 1) <> "\" dann FilePath = FilePath & "\"
    "Prüfung, ob eine Datei oder ein Verzeichnis vorhanden ist:
    Wenn Dir$(FilePath) <> "" dann
        EXISTIERT = 1
    Ansonsten: MsgBox "Das Verzeichnis existiert nicht, bitte erstellen Sie es"
    Debug.Print Dir$(Dateipfad)
    Ende, wenn
'Do-Schleife, solange das von Ihnen eingegebene Verzeichnis nicht existiert:
Schleife, während EXISTS <> 1
'reaktiviert das 3D-Dokument:
Set swModel = swApp.ActivateDoc2(Pfadname, False, nErrors)
"Wenn es sich um eine Versammlung handelt:
Wenn (SWmoddoc.GetType = swDocASSEMBLY) dann
    Die Aufzeichnung unter PATH & NewCode & Dash & NewName & . SLDASM  
    '=>SPEZIFISCHER NAMENSCODE
    Zum Beispiel sehen alle unsere Dateien so aus:
    '33333333-DATEIBEZEICHNUNG.ERWEITERUNG
    Das heißt ,
    "[8 Zeichen] [Bindestrich von 6] [Dateibezeichnung]
    SWmoddoc.SAVEAS(Dateipfad + Neuer Code + "-" + Neuer Name + ). SLDASM")
ElseIf (SWmoddoc.GetType = swDocPART) dann
    Die Registrierung für SLDPRT =>SPEZIFISCH gleich oben
     SWmoddoc.SAVEAS(Dateipfad + Neuer Code + "-" + Neuer Name + ). SLDPRT")
Ende, wenn
Fügt die benutzerdefinierte Eigenschaft CODE (=>SPEZIFISCHER CODE) hinzu:
retval = SWmoddoc.AddCustomInfo3("", "CODE", 30, Neuer Code)
SWmoddoc.CustomInfo("CODE") = Neuer Code
Fügt die benutzerdefinierte Eigenschaft FR (=>SPECIFIC FRLABEL) hinzu:
retval = SWmoddoc.AddCustomInfo3("", "FR-Etikett", 30, Neuer Name)
SWmoddoc.CustomInfo("FR-Bezeichnung") = Neuer Name
Fügt die benutzerdefinierte Dateiname-Eigenschaft (=>SPEZIFISCHER Dateiname) hinzu:
retval = SWmoddoc.AddCustomInfo3("", "Dateiname", 30, NewCode & "-" & NewName)
SWmoddoc.CustomInfo("Dateiname") = NewCode & "-" & NewName
Ich füge die benutzerdefinierte Eigenschaft Originaldatei hinzu (=>SPEZIFISCHE Originaldatei: Ich rate dir, diese zu behalten, damit du die Info immer in den Eigenschaften des 3D hast):
retval = SWmoddoc.AddCustomInfo3("", "Originaldatei", 30, Pfadname)
SWmoddoc.CustomInfo("Originaldatei") = Pfadname
"Prüfen Sie, ob das DRW (2D) vorhanden ist:
Wenn DRWNull = 0, dann
    Aktivieren Sie das DRW (2D):
    Set SWmoddoc = swApp.ActivateDoc2(DRWPath, False, nErrors)
    "Wenn es sich um ein DRW (2D) handelt:
    Wenn SWmoddoc.GetType = swDocDRAWING dann
    Registrieren als (siehe Kommentarzeilen 110 bis 115 =>SPEZIFISCHER CODENAME)
        SWmoddoc.SAVEAS(Dateipfad + Neuer Code + "-" + Neuer Name + ). SLDDRW")
        'löscht eingefügte Revisionstabellen =>SPEZIFISCHE Revisionstabellen
        Für i = 1 bis 6
            boolstatus = SWmoddoc.Extension.SelectByID2("Tabelle der Revisionen" & i, "REVISIONTABLEFEAT", 0, 0, 0, Falsch, 0, Nichts, 0)
            SWmoddoc.EditDelete
            Setze currentSheet = SWmoddoc.GetCurrentSheet()
            Set myRevisionTable = currentSheet.InsertRevisionTable(True, 0, 0, 3, "\\nas01\FOLDER\Detail Review Table.sldrevtbt")
        Weiter i
    Ende, wenn
Ende, wenn
Ende Sub

7

Perfekt, indem du deinen Code anpasst, funktioniert es perfekt:) 

Nochmals vielen Dank!

1 „Gefällt mir“