VBA - Zapisz jako rysunek automatyczny

actixxx · 27 Lipiec 2016 09:53

Witam, chciałbym zrobić mep, który z pokoju, otwiera swój rysunek i zapisuje pod pokojem i mepem pod tą samą nazwą. Zrobiłem poniższy kod, podczas testowania zmienne są dobre, ale to nie działa...

Dziękuję za pomoc :)

Sub main()

Ustaw swApp = _

Aplikacja.SldWorks

Ustaw swModel = swApp.ActiveDoc

ŚcieżkaPliku = swModel.GetPathName

TitleP = swModel.GetTitle

PathSize = Len(ŚcieżkaPliku)

PathNoExtension = Left(ŚcieżkaPliku, RozmiarŚcieżki - 7)

PathMEP = PathNoExtension & ". SLDDRW"

RozmiarTytułu = Len(TytułP)

TitleNoExtension = Lewo(TytułP, RozmiarTytułu - 7)

TitleMEP = TitleNoExtension & " - Arkusz1"

Set Part = swApp.OpenDoc6(PathMEP, 2, 0, "", longstatus, longwarnings) 'otwieranie zestawu źródłowego'

swApp.ActivateDoc2 TitleMEP, Fałsz, longstatus

Ustaw część = swApp.ActiveDoc 'aktywacja'

Ustaw swApp = Application.SldWorks

Ustaw swModel = swApp.ActiveDoc

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

Ustaw swModel = swApp.ActiveDoc

"Odzyskuje pełną nazwę pliku

ŚcieżkaPliku = swModel.GetPathName

PathSize = Len(ŚcieżkaPliku)

PathNoExtension = Left(ŚcieżkaPliku, RozmiarŚcieżki - 6)

PathMEP = PathNoExtension & ". SLDDRW"

Ustaw część = swApp.ActiveDoc

longstatus = Part.SaveAs3(Ścieżka plikuMEP, 0, 2)

Koniec subwoofera

pl · 27 Lipiec 2016 09:55

Witam

Radzę obejrzeć zapis makra poniżej, który umieściłem jako samouczek na Lynkoa:

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

Robi to, o co prosisz, a każda linijka jest komentowana.

actixxx · 27 Lipiec 2016 10:34

Czy możliwe jest posiadanie kodu bezpośrednio w formacie makra? Będzie bardziej czytelny :)

pl · 27 Lipiec 2016 12:18

Kod jest dostępny w linku, ale jeśli wolisz to w ten sposób, oto on :

'2012-03-19 16:46 działa, ale tylko jeśli DRW ma tę samą nazwę w tym samym folderze
Sub SAVE() 'zapisz jako
Dim swApp jako SldWorks.SldWorks
Przyciemnij SWmoddoc jako SldWorks.ModelDoc2
Przyciemnij KOD Jako ciąg
Dim nErrors tak długo, jak długo
Dim nWarnings tak długo, jak długo
Ustaw swApp = Application.SldWorks
Ustaw SWmoddoc = swApp.ActiveDoc
Pobiera pełną ścieżkę bieżącego dokumentu, w tym nazwę pliku:
PathName = UCase(SWmoddoc.GetPathName)
'sprawdź, czy nie jesteśmy na DRW = 2D:
Jeśli Right(PathName, 3) = "DRW" Następnie
MesgBOX = MsgBox("Makro uruchamiane tylko z części lub złożenia", vbMsgBoxSetForeground, "Zapisz jako (przez LPR)")
Wyjdź z subwoofera
ElseIf Right(PathName, 3) = "PRT" Następnie
DRWPath = Zamień(nazwa_ścieżki, "PRT", "DRW")
ElseIf Right(PathName, 3) = "ASM" Następnie
DRWPath = Replace(nazwa_ścieżki, "ASM", "DRW")
Zakończ jeżeli:
Pobiera ścieżkę do bieżącego dokumentu bez nazwy pliku:
FilePath = Left(NazwaŚcieżki, InStrRev(NazwaŚcieżki, "\"))
Pobiera nazwę pliku:
NazwaPliku = Right(NazwaŚcieżki, Len(NazwaŚcieżki) - InStrRev(NazwaŚcieżki, "\"))
'pobiera właściwość niestandardową (=CustomInfo) KOD (CustomInfo) =>KOD SPECYFICZNY:
KOD = SWmoddoc.CustomInfo("kod")
Jeśli KOD = "" Wtedy
'Jeśli kod nie istnieje, pobierz pierwsze 8 znaków z pliku =>SPECIFIC CODE & 8 znaków
KOD = Lewo(Zamień(NazwaPliku, " ", ""), 8)
Zakończ jeżeli:
'pobiera oznaczenie pliku (w naszym przypadku etykieta FR) =>SPECYFICZNA etykieta FR:
FR = SWmoddoc.CustomInfo("FRLED")
Jeśli libelleFR = "" Wtedy
' pobiera etykietę na podstawie nazwy pliku -7 znak = rozszerzenie (. SLDASM na przykład) =>SPECYFICZNY ZNIESŁAWIENIEFR:
libelleFR = Left(Right(NazwaPliku, Len(NazwaPliku) - InStr(NazwaPliku, "-")), Len(Right(NazwaPliku, Len(NazwaPliku) - InStr(NazwaPliku, "-"))) - 7)
Zakończ jeżeli:
"Komunikat z prośbą o potwierdzenie:
RET = MsgBox("Czy chcesz utworzyć kopię tej części (lub złożenia) i jej rysunku pod nowym kodem?" & vbNewLine & vbNewLine & "OSTRZEŻENIE: plik zostanie zastąpiony we WSZYSTKICH otwartych plikach SolidWorks!", vbOKCancel + vbExclamation + vbMsgBoxSetForeground + vbSystemModal, "Zapisz jako (przez LPR)")
"W przypadku anulowania: zakończenie programu:
Jeśli RET = vbAnuluj, to Koniec

pl · 27 Lipiec 2016 12:19

"Jeżeli drw (=2D) istnieje:
Jeśli Dir$(DRWPath) <> "" to
   Następnie otwieramy go:
Ustaw open = swApp.OpenDoc6(DRWPath, swDocDRAWING, swOpenDocOptions_Silent, "", nErrors, nWarnings)
DRWNull = 0
Inaczej
   'lub ostrzegamy, że nie ma go w tym samym pliku:
DRWNull = MsgBox("Rysunek nie został znaleziony, albo:" & vbNewLine & vbNewLine & "- nazwa jest inna niż 3D" & vbNewLine & "- folder jest inny niż 3D" & vbNewLine & "- rysunek nie istnieje" & vbNewLine & "Czy chcesz kontynuować?", vbOKCancel + vbExclamation + vbMsgBoxSetForeground + vbSystemModal, "Save-Under (By LPR)")
   ' Wychodzimy z programu
Jeśli DRWNull = 2, wyjdź z sub
Zakończ jeżeli:
"O ile (informacje zawarte w nowym kodzie):
Robić
   'nowy kod nie jest wypełniony =>SPECYFICZNY kod proponowany domyślnie:
NewCode = InputBox("Aby to zrobić, wprowadź nowy kod: ", "Save-As (By LPR)", CODE)
   "W przypadku anulowania:
   Jeśli StrPtr(NewCode) = 0, to
       MsgBox "Procedura anulowana"
       Wyjeżdżamy:
       Wyjdź z subwoofera
   Zakończ jeżeli:
   'Sprawdź, czy kod jest numeryczny =>SPECYFICZNY KOD - tylko numeryczny:
   Wykonaj while IsNumeric(NewCode) = False i MessageBox <> "6"
       MessageBox = MsgBox("Bądź ostrożny, twój kod nie jest jednoznacznie numeryczny!" & vbNewLine & "Czy to jest celowe?", vbYesNo)
       Jeśli MessageBox = vbNo Then NewCode = InputBox("Aby zapisać jako, określ nowy kod bez spacji: ", "Save-under by LPR", NewCode)
   Pętla
'do, o ile kod nie ma 8 znaków =>KONKRETNY 8-ZNAKOWY KOD
Pętla, podczas gdy Len(NewCode) <> 8
"Tak długo, jak (informacja o nowej nazwie = etykieta FR):
Robić
   – Jaka jest nowa nazwa? =>SPECYFICZNA etykieta FR proponowana domyślnie:
NewName = InputBox ("Proszę podać nową nazwę: " & vbNewLine & vbNewLine & "Pamiętaj, aby pisać wielkimi literami", "Save-under by LPR", etykieta FR)
   "W przypadku anulowania:
   Jeśli StrPtr(NewName) = 0, to
       MsgBox "Procedura anulowana"
       Wyjeżdżamy:
       Wyjdź z subwoofera
   Zakończ jeżeli:
   'Sprawdź, czy w nazwie znajdują się znaki, które są zabronione w systemie Windows" \ / : * ? > < |
   Wykonaj while InStr(nowaNazwa, Chr(34)) > 0 lub InStr(NowaNazwa, "\") > 0 lub InStr(NowaNazwa, "/") > 0 _
   lub InStr(NowaNazwa, ":") > 0 lub InStr(NowaNazwa, "*") > 0 lub InStr(NowaNazwa, "?") > 0 lub InStr(NowaNazwa, "<") > 0 lub InStr(NowaNazwa, ">") > 0 lub InStr(NowaNazwa, "|") > 0
       "Utrzymują się o charakterze zakazanym
       NewName = InputBox("Ostrzeżenie, nazwa zawiera co najmniej jeden z zabronionych znaków \/:*?""<>|" & vbNewLine & vbNewLine & _
       "Proszę wskazać nową nazwę: ", "Save-under by LPR", NewName)
   Pętla
'Do pętli, o ile nowa nazwa jest pusta
Pętla, podczas gdy NewName = ""

pl · 27 Lipiec 2016 12:19

'Tak długo, jak (informacje o ścieżce lub zapisz = nazwa_ścieżki):
Robić
   – Jaka jest droga?
FilePath = InputBox("" & vbNewLine & " ", "Save-Under przez LPR", FilePath)
   Jeśli StrPtr(ŚcieżkaPliku) = 0, to
       MsgBox "Procedura anulowana"
       Wyjdź z subwoofera
   Zakończ jeżeli:
   Jeśli go tam nie ma:
   Jeśli Right(FilePath, 1) <> "\", to FilePath = FilePath & "\"
   "Sprawdza, czy istnieje plik lub katalog:
   Jeśli Dir$(FilePath) <> "" to
       ISTNIEJE = 1
   W przeciwnym razie: MsgBox "Katalog nie istnieje, utwórz go"
   Debug.Print Dir$(FilePath)
   Zakończ jeżeli:
'Wykonaj pętlę, o ile wprowadzony katalog nie istnieje:
Pętla, gdy ISTNIEJE <> 1
'reaktywuje dokument 3D:
Set swModel = swApp.ActivateDoc2(NazwaŚcieżki, Fałsz, nBłędy)
"Jeśli jest to zgromadzenie:
Jeśli (SWmoddoc.GetType = swDocASSEMBLY) Wtedy
   Nagrywanie w PATH & NewCode & Dash & NewName & . SLDASM powiedział:
   '=>KONKRETNY KOD NAZWY
   Na przykład wszystkie nasze pliki są takie:
   '33333333-FILE DESIGNATION.extension
   To znaczy , że
   '[8 znaków] [łącznik liczby 6] [oznaczenie pliku]
SWmoddoc.SAVEAS(ŚcieżkaPliku + Nowy Kod + "-" + Nowa Nazwa + ". SLDASM")
ElseIf (SWmoddoc.GetType = swDocPART) Następnie
   Rejestracja dla SLDPRT =>SPECYFICZNE to samo powyżej
SWmoddoc.SAVEAS(ŚcieżkaPliku + Nowy Kod + "-" + Nowa Nazwa + ". SLDPRT")
Zakończ jeżeli:
Dodaje właściwość niestandardową CODE (=>SPECYFICZNY KORD):
retval = SWmoddoc.AddCustomInfo3("", "KOD", 30, NowyKod)
SWmoddoc.CustomInfo("KOD") = Nowy kod
Dodaje właściwość niestandardową FR (=>SPECIFIC FRLABEL):
retval = SWmoddoc.AddCustomInfo3("", "Etykieta FR", 30, NowaNazwa)
SWmoddoc.CustomInfo("Etykieta FR") = Nowa Nazwa
Dodaje niestandardową właściwość nazwy pliku (=>SPECIFIC nazwa_pliku):
retval = SWmoddoc.AddCustomInfo3("", "nazwa pliku", 30, Nowy kod & "-" & nowaNazwa)
SWmoddoc.CustomInfo("nazwa_pliku") = Nowy kod & "-" & nowaNazwa.
Dodaję niestandardową właściwość Oryginalny plik (=>SPECIFIC Oryginalny plik: Radzę zachować ten, aby zawsze mieć informacje we właściwościach 3D):
retval = SWmoddoc.AddCustomInfo3("", "Oryginalny plik", 30, NazwaŚcieżki)
SWmoddoc.CustomInfo("Oryginalny plik") = Nazwa_ścieżki
"Sprawdzić, czy DRW (2D) istnieje:
Jeśli DRWNull = 0, to
   Aktywuj DRW (2D):
Ustaw SWmoddoc = swApp.ActivateDoc2(DRWPath, False, nErrors)
   "Jeżeli jest to DRW (2D):
Jeśli SWmoddoc.GetType = swDocDRAWING Następnie
   Zarejestruj się jako (patrz komentarze wiersze od 110 do 115 =>SPECYFICZNA NAZWA KODOWA)
SWmoddoc.SAVEAS(ŚcieżkaPliku + Nowy Kod + "-" + Nowa Nazwa + ". SLDDRW")
       'usuwa wstawione tabele poprawek =>KONKRETNE tabele zmian
Dla i = 1 do 6
boolstatus = SWmoddoc.Extension.SelectByID2("Tabela wersji" & i, "REVISIONTABLEFEAT", 0, 0, 0, False, 0, Nic, 0)
SWmoddoc.EditUsuń
Ustaw currentSheet = SWmoddoc.GetCurrentSheet()
Ustaw myRevisionTable = currentSheet.InsertRevisionTable(True, 0, 0, 3, "\\nas01\FOLDER\Detail Review Table.sldrevtbt")
Dalej i
Zakończ jeżeli:
Zakończ jeżeli:
Koniec subwoofera

actixxx · 28 Lipiec 2016 12:07

Idealnie, dostosowując Twój kod, działa idealnie :)

Jeszcze raz dziękujemy!