Macro query
Macro query
(OP)
I played about a bit and got to the editor tool, which displays as below, but there doesn't appear to be an instruction to determine colour/B&W. I'd really like to do more with these - they seem like great timesavers...
Dim swApp As Object
Dim Part As Object
Dim SelMgr As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Dim Feature As Object
Sub main()
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
Set SelMgr = Part.SelectionManager
Set swModel = swApp.ActiveDoc
sPathName = swModel.GetPathName 'Get File Name & Path
Extension = Right(sPathName, 6) 'Determine File Type
'Try Again if Not "SLDDRW"
If Extension <> "SLDDRW" Then
MsgBox ("Current Document Is Not .SLDDRW")
End
End If
'Save as PDF
SavePDF:
sPathName = Left(sPathName, Len(sPathName) - 6) 'Remove "SLDDRW" Extension
sPathName = sPathName + "pdf" 'Add "PDF" Extension
Set fso = CreateObject("Scripting.FileSystemObject") 'Check if file exists
If (fso.FileExists(sPathName)) Then 'If file exists
If MsgBox("Overwrite " & sPathName & " ?", vbYesNo) = vbNo Then 'Ask if want to overwrite file
End If
End If
Part.SaveAs2 sPathName, 0, True, False 'Save file if file does not exist or if choose vbYes
End Sub
Dim swApp As Object
Dim Part As Object
Dim SelMgr As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Dim Feature As Object
Sub main()
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
Set SelMgr = Part.SelectionManager
Set swModel = swApp.ActiveDoc
sPathName = swModel.GetPathName 'Get File Name & Path
Extension = Right(sPathName, 6) 'Determine File Type
'Try Again if Not "SLDDRW"
If Extension <> "SLDDRW" Then
MsgBox ("Current Document Is Not .SLDDRW")
End
End If
'Save as PDF
SavePDF:
sPathName = Left(sPathName, Len(sPathName) - 6) 'Remove "SLDDRW" Extension
sPathName = sPathName + "pdf" 'Add "PDF" Extension
Set fso = CreateObject("Scripting.FileSystemObject") 'Check if file exists
If (fso.FileExists(sPathName)) Then 'If file exists
If MsgBox("Overwrite " & sPathName & " ?", vbYesNo) = vbNo Then 'Ask if want to overwrite file
End If
End If
Part.SaveAs2 sPathName, 0, True, False 'Save file if file does not exist or if choose vbYes
End Sub






RE: Macro query
http
h
http://sw
http://www
https://forum.solidworks.com/thread/46204
https://forum.solidworks.com/message/144051#144051
RE: Macro query
Dim swApp As Object
Dim Part As Object
Dim SelMgr As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Dim Feature As Object
Dim pdfColor as Boolean
Sub main()
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
Set SelMgr = Part.SelectionManager
Set swModel = swApp.ActiveDoc
sPathName = swModel.GetPathName 'Get File Name & Path
Extension = Right(sPathName, 6) 'Determine File Type
'Try Again if Not "SLDDRW"
If Extension <> "SLDDRW" Then
MsgBox ("Current Document Is Not .SLDDRW")
End
End If
'Save as PDF
SavePDF:
sPathName = Left(sPathName, Len(sPathName) - 6) 'Remove "SLDDRW" Extension
sPathName = sPathName + "pdf" 'Add "PDF" Extension
pdfColor = swApp.GetUserPreferenceToggle(swPDFExportInColor)
swApp.SetUserPreferenceToggle swPDFExportInColor, False
Set fso = CreateObject("Scripting.FileSystemObject") 'Check if file exists
If (fso.FileExists(sPathName)) Then 'If file exists
If MsgBox("Overwrite " & sPathName & " ?", vbYesNo) = vbNo Then 'Ask if want to overwrite file
End If
End If
Part.SaveAs2 sPathName, 0, True, False 'Save file if file does not exist or if choose vbYes
swApp.SetUserPreferenceToggle swPDFExportInColor, pdfColor
End Sub
RE: Macro query
Dim swApp As Object
Dim swModel As Object
Dim sPathName As String
Dim pdfColor As Boolean
Dim SaveFile As Boolean
Sub main()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
If swModel Is Nothing Then
End
End If
If swModel.GetType <> 3 Then
MsgBox "This utility only works on .SLDDRW files"
End
End If
sPathName = swModel.GetPathName 'Get File Name & Path
sPathName = Left(sPathName, Len(sPathName) - 6) 'Remove "SLDDRW" Extension
sPathName = sPathName & "pdf" 'Add "PDF" Extension
pdfColor = swApp.GetUserPreferenceToggle(swPDFExportInColor)
swApp.SetUserPreferenceToggle swPDFExportInColor, False
SaveFile = True
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(sPathName) Then 'Check if file exists
If MsgBox("Overwrite " & sPathName & " ?", vbYesNo) = vbNo Then 'Ask if want to overwrite file
SaveFile = False
End If
End If
If SaveFile Then
swModel.SaveAs2 sPathName, 0, True, False 'Save file if file does not exist or if choose vbYes
End If
swApp.SetUserPreferenceToggle swPDFExportInColor, pdfColor
End Sub
RE: Macro query
RE: Macro query
Anyway, if you didn't already, I'd suggest using the second piece of code I posted instead of the first. Your original code does NOT skip saving the file if you choose "No" when asked if you want to overwrite the file.
RE: Macro query
I have a client that requests all their drawings in dwg and occasionally dxf as well as the SW format we normally deliver. If you have one that exports dwg's in a sensible manner, I'd be forever grateful. I find save-as seems to generate some odd results (scales out - so I open in AutoCAD and scale everything up, only to find dimensions get multiplied by the same amount... etc, etc!)
I'll paste the second revision code in and give it a blast. I'm truly jealous that you can just bash this stuff out - it's like looking at the matrix to me at the moment...
RE: Macro query
As for a macro, I do have one that saves a DXF, but it's a bit more detailed than you'd probably need. If I get a chance, I'll try and get a quick one working tomorrow. Otherwise, there should be plenty of examples that do the trick.
RE: Macro query
As for the dwg's, I tried the task scheduler some time ago but wasn't exactly blown away by the results. I thought it was worth another try, so gave it a second shot yesterday and had much better results, so I think I'll stick with that route for now.
Thanks again, however!