Mam makro, które idzie gładko ... ale gdzie nic się nie dzieje. Naprawdę nie rozumiem, dlaczego i gdzie to utknęło. Czy ktoś ma jakiś pomysł?
Wstawiam komentarze, aby wyjaśnić, co próbuję tam zrobić. Chodzi o to, aby zapisać każdy arkusz mojego DRW w DXF i PDF pod odpowiednią nazwą w odpowiednim katalogu.
Zapisz podrzędnie() Dim swapp As SldWorks.SldWorks Przyciemnij swdoc jako SldWorks.ModelDoc2 Dim Swdraw jako SldWorks.ModelDoc Przyciemnij swSheet jako SldWorks.Sheet Dim vSheetNames As Variant Dim Nbfeuille As Variant Ustaw swapp = Application.SldWorks Ustaw swdoc = swapp. Plik ActiveDoc Ustaw Swdraw = swdoc Set swSheet = Swdraw.GetCurrentSheet "Komunikat potwierdzający ret = MsgBox("czy chcesz przekonwertować ten rysunek na DXF i PDF?", vbOKCancel + vbExclamation + vbMsgBoxSetForeground + vbSystemModal, "Konwersja laserowa") Jeśli ret = vbAnuluj, to Koniec Rejestracja nowej nazwy Robić newname = InputBox("Proszę określić nową nazwę:", "blabla", nowanazwa) Jeśli StrPtr(nowanazwa) = 0 to MsgBox "procedura anulowana" Wyjdź z subwoofera Zakończ jeżeli: 'Sprawdzanie okien z zakazanymi znakami Wykonaj While InStr(nowa_nazwa, "/") > 0 Or InStr(nowa_nazwa, "*") > 0 Or InStr(nowa_nazwa, "?") > 0 Lub InStr(nowa_nazwa, "<") > 0 Or InStr(nowa, ">") > 0 Lub InStr(nowa, "!") > 0 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 Pętla, podczas gdy nowa_nazwa = " " "Dokumentacja rejestracyjna Robić FilePath = InputBox("Określ ścieżkę", "folder nagrań", Ścieżka pliku) Jeśli StrPtr(ŚcieżkaPliku) = 0, to MsgBox "procedura anulowana" Wyjdź z subwoofera Zakończ jeżeli: 'Dodanie znaku \ na końcu nazwy folderu Jeśli Right(FilePath, 1) <> "\", to FilePath = FilePath & "\" 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: Pętla, gdy ISTNIEJE <> 1 "Wskazuje liczbę arkuszy Nbfeuille = swdoc. GetSheetCount (Liczba arkuszy) Dla i = 0 Do Nbfeuille SWDOC. ArkuszPoprzedni Dalej i Przechodzenie do następnego arkusza, jeśli < do całkowitej liczby Dla i = 0 Do varSheetCount - 1 Jeśli <> 0, to SWMODEL. ArkuszNastępny Zakończ jeżeli: Nagrywanie w formacie DXF i PDF SWDOC. Zapisz jako (Ścieżka pliku + nowa_nazwa + "_" + i + ".dxf") SWDOC. Zapisz jako (ŚcieżkaPliku + nowa_nazwa + "_" + i + ".pdf") Dalej i Koniec subwoofera
Witam Chciałbym również zapisać moje części w DXF, ale od czasu pliku Part, próbowałem zhakować twój program, aby go dostosować, ale nic nie działa poza oknami komunikatów, nie mam żadnych wyników, ktoś może rzucić okiem na mój kod, lub dać mi taki, który już działa dobrze do tego użytku
Sub Enregistrer()
Dim swapp As SldWorks.SldWorks
Dim swdoc As SldWorks.ModelDoc2
Dim SwPart As SldWorks.ModelDoc
Set swapp = Application.SldWorks
Set swdoc = swapp.ActiveDoc
Set SwPart = swdoc
'Message de confirmation
ret = MsgBox("voulez-vous convertir cette piece en DXF?", vbOKCancel + vbExclamation + vbMsgBoxSetForeground + vbSystemModal, "Conversion Laser")
If ret = vbCancel Then End
'Enregistrement nouveau nom
Do
newname = InputBox("nom du dxf:", "blabla", newname)
If StrPtr(newname) = 0 Then
MsgBox "procédure annulée"
Exit Sub
End If
'Verification caractere interdit Windows
Do While InStr(newname, "/") > 0 Or InStr(newname, "*") > 0 Or InStr(newname, "?") > 0 Or InStr(newname, "<") > 0 Or InStr(newnam, ">") > 0 Or InStr(newnam, "!") > 0
newname = InputBox("Attention, le nom contient au moins un des caractère interdits \/:*?""<>!" & vbNewLine & vbNewLine & "Merci d'indiquer le nouveau nom: ", "enregistrer-sous par LPR", newname)
Loop
Loop While newname = " "
'Dossier d'enregistrement
Do
FilePath = InputBox("Indiquez le chemin d'accés", "dossier enregistrement", FilePath)
If StrPtr(FilePath) = 0 Then
MsgBox "procédure annulée"
Exit Sub
End If
'Ajout du \ à la fin du nom de dossier
If Right(FilePath, 1) <> "\" Then FilePath = FilePath & "\"
If Dir$(FilePath) <> "" Then
EXISTE = 1
Else: MsgBox "le répertoire n'existe pas, merci de le créer"
Debug.Print Dir$(FilePath)
End If
Loop While EXISTE <> 1
'Enregistrement en DXF
swdoc.SaveAs (FilePath + newname + "_" + ".dxf")
End Sub
Makro jest stworzone dla posłów do PE i przekształcasz je w pokój, nic dziwnego, że nie działa. Ponadto, ponieważ temat jest zamknięty od 2014 roku, zapraszam do stworzenia własnego tematu z tym tutaj jako odniesieniem. Domyślam się, że istnieją już makra do eksportu w formacie dxf z części arkusza blachy i dlatego ten nie jest najbardziej odpowiedni.
… 9 lat później... (Nie należy rozkopywać starych tematów, zwłaszcza jeśli są już w "rozwiązanych"...
Aby wyeksportować część objętościową (SLDPRT) w formacie DXF: Zastąp polecenie "saveas" następującymi elementami: ExportToDWG2 (eksport bez rozwinięcia) lub przez ExportFlatPatternView (eksport ze spłaszczaniem)...
