VBA - Opslaan als automatische tekening

Out of category
1

Hallo, ik zou graag een Europarlementariër willen maken die uit een kamer, zijn tekening opent en opslaat onder de kamer en de Europarlementariër onder dezelfde naam. Ik heb de onderstaande code gemaakt, tijdens het testen, de variabelen zijn goed, maar het werkt niet ...

Dank u voor uw hulp:)

 

Sub hoofd()

Stel swApp in = _

Toepassing.SldWorks

Stel swModel = swApp.ActiveDoc in

FilePath = swModel.GetPathName

TitleP = swModel.GetTitle

Padgrootte = Len(FilePath)

PathNoExtension = Links(FilePath, Padgrootte - 7)

PathMEP = PathNoExtension & ". SLDDRW"

Titelgrootte = Len(TitelP)

TitleNoExtension = Links(TitleP, TitleSize - 7)

TitleMEP = TitleNoExtension & " - Blad1"

Set Part = swApp.OpenDoc6(PathMEP, 2, 0, "", longstatus, longwarnings) 'bronassembly openen'

swApp.ActivateDoc2 TitleMEP, False, longstatus

Deel instellen = swApp.ActiveDoc 'activering'

Stel swApp = Toepassing.SldWorks in

Stel swModel = swApp.ActiveDoc in

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

Stel swModel = swApp.ActiveDoc in

'Herstelt de volledige naam van het bestand

FilePath = swModel.GetPathName

Padgrootte = Len(FilePath)

PathNoExtension = Links(FilePath, Padgrootte - 6)

PathMEP = PathNoExtension & ". SLDDRW"

Deel instellen = swApp.ActiveDoc

longstatus = Deel.Opslaan3(FilePathMEP, 0, 2)

Einde Sub

 

2

Hallo

Ik raad je aan om de macro-opname te bekijken die ik als een tutorial over Lynkoa heb gezet:

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

Ze doet wat je vraagt en elke zin wordt becommentarieerd.

3

Is het mogelijk om de code direct in macroformaat te hebben? Het zal leesbaarder zijn:) 

4

De code is beschikbaar in de link, maar als je het op deze manier verkiest, hier is het :

'19-3-2012 16:46 werkt, maar alleen als DRW dezelfde naam in dezelfde map heeft
Sub SAVE() 'opslaan als
Dim swApp als SldWorks.SldWorks
Dim SWmoddoc als SldWorks.ModelDoc2
Dim CODE als snaar
Dim nErrors             zo lang
Dim nWaarschuwingen           zo lang mogelijk
Stel swApp = Toepassing.SldWorks in
Stel SWmoddoc = swApp.ActiveDoc in
Hiermee haalt u het volledige pad van het huidige document op, inclusief de bestandsnaam:
PathName = UCase(SWmoddoc.GetPathName)     
'controleer of we niet op een drw zitten = 2D:
Als right(PathName, 3) = "DRW" dan
    MesgBOX = MsgBox("Macro die alleen vanuit een onderdeel of assemblage moet worden gestart", vbMsgBoxSetForeground, "Save-As (By LPR)")
    Sub afsluiten
    ElseIf Right(PathName, 3) = "PRT" dan
        DRWPath = Vervangen(PadNaam, "PRT", "DRW")
    ElseIf Right(PathName, 3) = "ASM" dan
        DRWPath = Vervangen(PadNaam, "ASM", "DRW")
Einde als
Hiermee haalt u het pad naar het huidige document op, zonder de bestandsnaam:
FilePath = Links(PathName, InStrRev(PathName, "\"))
Haalt de bestandsnaam op:
FileName = Right(PathName, Len(PathName) - InStrRev(PathName, "\")) 
'haalt de custom eigenschap op (=CustomInfo) CODE (CustomInfo) =>SPECIFIEKE CODE:
CODE = SWmoddoc.CustomInfo("code")
Als CODE = "" Dan
'Als de code niet bestaat, haal dan de eerste 8 tekens van het bestand =>SPECIFIEKE CODE & 8 tekens op'
    CODE = Links(Vervang(Bestandsnaam, " ", ""), 8)    
Einde als    
'haalt de bestandsaanduiding op (FR-label in ons geval) =>SPECIFIEK FR-label:
FR = SWmoddoc.CustomInfo("FRLED")
Als libelleFR = "" Dan
' haalt het label op op basis van de bestandsnaam -7 teken = extensie (. SLDASM bijvoorbeeld) =>SPECIFIEKE LibelFR:
    libelleFR = Left(Right(FileName, Len(FileName) - InStr(FileName, "-")), Len(Right(FileName, Len(FileName) - InStr(FileName, "-"))) - 7)
Einde als
'Bericht bevestigingsverzoek:
RET = MsgBox ("Wilt u een kopie maken van dit onderdeel (of assemblage) en de tekening ervan onder nieuwe code?" & vbNewLine & "WAARSCHUWING: het bestand wordt vervangen in ALLE open SolidWorks-bestanden!", vbOKCancel + vbExclamation + vbMsgBoxSetForeground + vbSystemModal, "Save-As (By LPR)")
'Indien geannuleerd: einde van het programma:
Als RET = vbCancel then end
 

5

"Indien de drw (=2D) bestaat:
Als dir$(DRWPath) <> "" dan
    Dan openen we het:
    Open instellen = swApp.OpenDoc6(DRWPath, swDocDRAWING, swOpenDocOptions_Silent, "", nErrors, nWarnings)
    DRWNull = 0
    Anders
    'Of we waarschuwen dat het niet in hetzelfde bestand voorkomt:
    DRWNull = MsgBox ("De tekening is ook niet gevonden:" & vbNewLine & vbNewLine & "- de naam is anders dan 3D" & vbNewLine & "- de tekening bestaat niet" & vbNewLine & "Wil je doorgaan?", vbOKCancel + vbExclamation + vbMsgBoxSetForeground + vbSystemModal, "Opslaan onder (door LPR)")
    'We verlaten het programma
    Als DRWNull = 2, sluit dan Sub af
Einde als
"Zolang (informatie in het nieuwe wetboek): 
Doen
    'de nieuwe code is niet ingevuld =>SPECIFIEKE code die standaard wordt voorgesteld:
    NewCode = InputBox("Voer hiervoor de nieuwe code in: ", "Opslaan als (door LPR)", CODE)
    "Als we annuleren:
    Als StrPtr(NewCode) = 0 dan
        MsgBox "Procedure geannuleerd"
        We vertrekken:
        Sub afsluiten
    Einde als
    'Controleer of de code numeriek is =>SPECIFIEKE CODE-alleen numeriek:
    Do While IsNumeric(NewCode) = False En MessageBox <> "6"
        MessageBox = MsgBox ("Wees voorzichtig, uw code is niet uniek numeriek!" & vbNewLine & "Is dit opzettelijk?", vbYesNo)
        Als MessageBox = vbNo Dan NewCode = InputBox ("Om op te slaan-als, gelieve de nieuwe code zonder spaties op te geven: ", "Opslaan onder door LPR", NewCode)
    Strik
'lus, zolang de code niet 8 tekens is =>SPECIFIEKE CODE van 8 tekens
Loop terwijl Len (NewCode) <> 8
"Zolang (nieuwe naamsaanduiding = FR-etiket):
Doen
    'Wat is de nieuwe naam? =>SPECIFIEK labelFR standaard voorgesteld:
    NewName = InputBox ("Geef de nieuwe naam op: " & vbNewLine & vbNewLine & "Vergeet niet in hoofdletters te schrijven", "Save-under by LPR", FR label)
    "Als we annuleren:
    Als StrPtr(NewName) = 0 dan
        MsgBox "Procedure geannuleerd"
        We vertrekken:
        Sub afsluiten
    Einde als
    'Controleer of er tekens in de naam staan die verboden zijn in Windows' \ / : * ? > < | 
    Doe terwijl InStr(NewName, Chr(34)) > 0 of InStr(NewName, "\") > 0 of InStr(NewName, "/") > 0 _
    of InStr(NewName, ":") > 0 of InStr(NewName, "*") > 0 of InStr(NewName, "?") > 0 of InStr(NewName, "<") > 0 of InStr(NewName, ">") > 0 of InStr(NewName, "|") > 0
        "Blijft van verboden aard
        NewName = InputBox("Waarschuwing, de naam bevat ten minste één van de verboden tekens \/:*?""<>|" & vbNewLine & vbNewLine & _
        "Gelieve de nieuwe naam te vermelden: ", "Opslaan onder door LPR", NewName)
    Strik
'Wel herhalen, zolang de nieuwe naam leeg is
Loop terwijl NewName = ""
 

6

'Zolang (padinformatie of opslaan = padnaam):
Doen
    'Wat is de weg?
    FilePath = InputBox("" & vbNewLine & " ", "Save-Under by LPR", FilePath)
    Als StrPtr(FilePath) = 0 dan
        MsgBox "Procedure geannuleerd"
        Sub afsluiten
    Einde als
    Als het er niet is:
    Als Right(FilePath, 1) <> "\" dan is FilePath = FilePath & "\"
    "Controle op het bestaan van een bestand of mappen:
    Als dir$(FilePath) <> "" dan
        BESTAAT = 1
    Anders: MsgBox "De directory bestaat niet, maak hem alsjeblieft aan"
    Debug.Print Dir$(FilePath)
    Einde als
'Doe een lus, zolang de directory die je hebt ingevoerd niet bestaat:
Loop Terwijl BESTAAT <> 1
'activeert het 3D-document opnieuw:
Stel swModel = swApp.ActivateDoc2(PathName, False, nErrors) in
'Als het een assemblage is:
Als (SWmoddoc.GetType = swDocASSEMBLY) Dan
    Opnemen onder PATH & NewCode & Dash & NewName & . SLDASME  
    '=>SPECIFIEKE NAAM-CODE
    Al onze bestanden zien er bijvoorbeeld zo uit:
    "33333333-BESTAND AANDUIDING.extensie
    Dat wil zeggen ,
    "[8 tekens] [koppelteken van 6] [bestandsaanduiding]
    SWmoddoc.SAVEAS(FilePath + NewCode + "-" + NewName + ". SLDASM")
ElseIf (SWmoddoc.GetType = swDocPART) Dan
    De registratie voor SLDPRT =>SPECIFIEK hetzelfde hierboven
     SWmoddoc.SAVEAS(FilePath + NewCode + "-" + NewName + ". SLDPRT")
Einde als
Voegt de aangepaste eigenschap CODE (=>SPECIFIEKE CODE) TOE:
retval = SWmoddoc.AddCustomInfo3("", "CODE", 30, NewCode)
SWmoddoc.CustomInfo("CODE") = Nieuwe code
Voegt de aangepaste eigenschap FR (=>SPECIFIEK FRLABEL) toe:
retval = SWmoddoc.AddCustomInfo3("", "FR label", 30, NewName)
SWmoddoc.CustomInfo("FR-label") = Nieuwe naam
Voegt de eigenschap aangepaste bestandsnaam toe (=>SPECIFIEKE bestandsnaam):
retval = SWmoddoc.AddCustomInfo3("", "bestandsnaam", 30, NewCode & "-" & NewName)
SWmoddoc.CustomInfo("bestandsnaam") = NieuwCode & "-" & NieuwNaam
Ik voeg de aangepaste eigenschap Origineel bestand toe (=>SPECIFIEK Origineel bestand: ik raad je aan om deze te bewaren, zodat je altijd de info in de eigenschappen van de 3D hebt):
retval = SWmoddoc.AddCustomInfo3("", "Origineel bestand", 30, PathName)
SWmoddoc.CustomInfo("Origineel bestand") = PadNaam
"Test voor het bestaan van de DRW (2D):
Als DRWNull = 0 Dan
    Activeer de DRW (2D):
    Stel SWmoddoc in = swApp.ActivateDoc2(DRWPath, False, nErrors)
    'Als het een DRW (2D) is:
    Als SWmoddoc.GetType = swDocDRAWING Dan
    Registreer als (zie opmerkingen regels 110 t/m 115 =>SPECIFIEKE CODENAAM)
        SWmoddoc.SAVEAS(FilePath + NewCode + "-" + NewName + ". SLDDRW")
        'verwijdert ingevoegde revisietabellen =>SPECIFIEKE Revisietabellen
        Voor i = 1 tot 6
            boolstatus = SWmoddoc.Extension.SelectByID2("Tabel met revisies" & i, "REVISIONTABLEFEAT", 0, 0, 0, False, 0, Nothing, 0)
            SWmoddoc.EditDelete
            Stel currentSheet in = SWmoddoc.GetCurrentSheet()
            Set myRevisionTable = currentSheet.InsertRevisionTable(True, 0, 0, 3, "\\nas01\FOLDER\Detail Review Table.sldrevtbt")
        volgende i
    Einde als
Einde als
Einde Sub

7

Perfect door je code aan te passen werkt het perfect:) 

Nogmaals bedankt!

1 like