Ik heb een macro die soepel gaat ... maar waar niets gebeurt. Ik begrijp niet zo goed waarom en waar het vastloopt. Of iemand een idee heeft?
Ik plaats opmerkingen om uit te leggen wat ik daar probeer te doen. Het idee is om elk blad van mijn DRW op te slaan in DXF en PDF onder de juiste naam in de juiste map.
Sub Opslaan() Dim swapp als SldWorks.SldWorks Dim swdoc als SldWorks.ModelDoc2 Dim Swdraw als SldWorks.ModelDoc Dim swSheet als SldWorks.Sheet Dim vSheetNames als variant Dim Nbfeuille als variant Stel swapp in = Toepassing.SldWorks Stel swdoc = swapp in. ActiveDoc Swdraw instellen = swdoc Stel swSheet in = Swdraw.GetCurrentSheet 'Bevestigingsbericht' ret = MsgBox("wilt u deze tekening converteren naar DXF en PDF?", vbOKCancel + vbExclamation + vbMsgBoxSetForeground + vbSystemModal, "Laser Conversion") Als ret = vbCancel Then End Registratie nieuwe naam Doen newname = InputBox("Geef de nieuwe naam op:", "blabla", newname) Als StrPtr(newname) = 0 dan MsgBox "procedure geannuleerd" Sub afsluiten Einde als 'Verboden tekenvensters controleren Doe terwijl InStr(newname, "/") > 0 Of InStr(newname, "*") > 0 Of InStr(newname, "?") > 0 Of InStr(newname, "<") > 0 Of InStr(newnam, ">") > 0 Of InStr(newnam, "!") > 0 newname = InputBox("Waarschuwing, de naam bevat ten minste één van de verboden tekens \/:*?"" <>!" & vbNewLine & vbNewLine & "Gelieve de nieuwe naam te vermelden: ", "save-under by LPR", newname) Strik Loop Terwijl newname = " " "Registratiedossier Doen FilePath = InputBox("Specificeer het pad", "recordmap", FilePath) Als StrPtr(FilePath) = 0 dan MsgBox "procedure geannuleerd" Sub afsluiten Einde als 'De \ toevoegen aan het einde van de mapnaam Als Right(FilePath, 1) <> "\" dan is FilePath = FilePath & "\" Als dir$(FilePath) <> "" dan BESTAAT = 1 Anders: MsgBox "de directory bestaat niet, maak hem alsjeblieft aan" Debug.Print Dir$(FilePath) Einde als Loop Terwijl BESTAAT <> 1 'Geeft het aantal vellen aan Nbfeuille = swdoc. GetSheetCount Voor i = 0 Naar Nbfeuille SWDOC. BladVorige volgende i Naar het volgende blad gaan als < naar het totale aantal Voor i = 0 Naar varSheetCount - 1 Als ik <> 0 Dan swmodel. BladVolgende Einde als Opname in DXF en PDF SWDOC. Opslaan als (FilePath + newname + "_" + i + ".dxf") SWDOC. OpslaanAls (FilePath + newname + "_" + i + ".pdf") volgende i Einde Sub
Omdat ik niet veel weet over het maken van macro's, heb ik alleen een andere macro gevonden die kan doen wat je wilt bereiken ... Als het je kan helpen?
Hallo Ik wil graag mijn onderdelen op te slaan in DXF ook, maar sinds het Part-bestand, heb ik geprobeerd om uw programma te hacken om het aan te passen, maar niets werkt behalve de berichtenvensters Ik heb geen resultaten, iemand kan een kijkje nemen naar mijn code, of geef me een die al goed werkt voor dit gebruik
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
De macro is gemaakt voor Europarlementariërs en je transformeert hem voor een kamer, geen verrassing dat het niet werkt. Bovendien, aangezien het onderwerp sinds 2014 gesloten is, nodig ik u uit om uw eigen onderwerp aan te maken met dit hier als referentie. Ik vermoed dat er al macro's zijn om in dxf te exporteren van een plaatwerkonderdeel en dat deze daarom niet het meest geschikt is.
… 9 jaar later... (Je moet geen oude onderwerpen opgraven, vooral niet als ze al "opgelost" zijn...
Om een volumeonderdeel (SLDPRT) in DXF te exporteren: vervang het commando "saveas" door: ExportToDWG2 (exporteren zonder uitgevouwen) of door ExportFlatPatternView (exporteren met afvlakking)...
