SaveAS PDF Differences

Here is the code that I have for a macro that saves a drawing as a PDF.
Most of this code has came from a macro that I downloaded somewhere.
I am attempting to change it, but I am having problems. Originally
Line 25 works great, but it saves the PDF to the directory of the
drawing. I don't want that, so I added Lines 20-24 to make up my path.
I then added Line 26 and commented out 25. The Macro did not work at
all. I need to know why line line 25 works and why line 26 will not.
If I debug.print either one of them, they are exactly the same. What
am I doing wrong, and how can I make it work the way I want.

1 Public swApp As SldWorks.SldWorks
2 Public DrawingDoc As SldWorks.DrawingDoc
3 Dim ModelDoc As SldWorks.ModelDoc2
4 Dim objWShell As Object
5 Dim strRegKey As String
6 Dim lngWarnings As Long
7 Dim lngErrors As Long
8 Dim strPDFName As String
9 Sub main()
10 Set swApp = Application.SldWorks
11 Set ModelDoc = swApp.ActiveDoc
12 If Not ModelDoc Is Nothing Then
13 If ModelDoc.GetType = swDocDRAWING Then
14 Set DrawingDoc = ModelDoc
15 strRegKey = "HKEY_CURRENT_USER\Software\Bluebeam
Software\Pushbutton PDF\SolidWorksLt\WhatToPlot"
16 Set objWShell = CreateObject("WScript.Shell")
17 objWShell.RegWrite strRegKey, 1
18 Set objWShell = Nothing
19 Set objFS = CreateObject("Scripting.FileSystemObject")
20 FullPath = ModelDoc.GetPathName ' gets the path of the
file
21 SlashPosition = InStrRev(FullPath, "\") 'gets the
position of last \
22 FileName = Right(FullPath, Len(FullPath) -
SlashPosition) 'removes path and leaves part name
23 FileNameNoExt = Left(FileName, Len(FileName) - 7) 'takes
off the SLDPRT
24 FolderName = Left$(FileName, 4) 'give 1st 4 characters
of part name
25 'strPDFName =
objFS.buildpath(objFS.GetParentFolderName(DrawingDoc.GetPathName),
objFS.GetBaseName(DrawingDoc.GetPathName) & ".PDF")
26 'strPDFName = "H:\DWGS\" & FolderName & "\" &
FileNameNoExt & ".PDF"
27 DrawingDoc.SaveAs4 strPDFName, swSaveAsCurrentVersion,
swSaveAsOptions_Silent, lngErrors, lngWarnings
28 Else
29 MsgBox "A SolidWorks Drawing document must be open in
order to SaveAs a PDF!", vbInformation
30 End If
31 Else
32 MsgBox "A SolidWorks Drawing document must be open in
order to SaveAs a PDF!", vbInformation
33 End If
34 End Sub

 

Well the code is pretty ugly and messes with the registry. This is
much simpler and does the same.

Dim swApp As Object
Dim swDrawing As Object
Dim strName As String
Dim longErrors As Long
Dim longWarnings As Long

Sub main()

Set swApp = Application.SldWorks
Set swDrawing = swApp.ActiveDoc
If swDrawing.GetType <> 3 Then MsgBox "I only work with drawings.": End

Path = "c:\temp\"
strName = Right(swDrawing.GetPathName, Len(swDrawing.GetPathName) -
Len(Left(swDrawing.GetPathName, InStrRev(swDrawing.GetPathName, "\",
-1, vbTextCompare))))
If strName = "" Then MsgBox "Make sure you've saved the drawing before
trying to create a pdf of it.": End
boolstatus = swDrawing.SaveAs4(Path & strName & ".pdf", 0, 1,
longErrors, longWarnings)
If boolstatus = False Then MsgBox "Something went wrong during save.
Make sure you have bluebeam added in for older SW versions."

End Sub

 

Code above puts .slddrw in the PDF filename.

Heres the code I use.

-----------------------------------------------
Dim swApp As Object
Dim Drawing As Object
Dim boolstatus As Boolean
Dim longstatus As Long
Dim Annotation As Object
Dim Gtol As Object
Dim DatumTag As Object
Dim FeatureData As Object
Dim Feature As Object
Dim Component As Object

Sub main()
Dim FileName As String
Dim dotpos As Integer
Dim slashpos As Integer
Dim dashpos As Integer

Set swApp = CreateObject("SldWorks.Application")
Set Drawing = swApp.ActiveDoc

If Drawing Is Nothing Then
MsgBox ("No document loaded")
Exit Sub
End If

If Drawing.GetType <> swDocDRAWING Then
MsgBox ("This macro only works with drawings.")
Exit Sub
End If

FileName = Drawing.GetPathName
If FileName = "" Then 'model is not saved yet
FileName = Drawing.GetTitle
dashpos = InStrRev(FileName, "-") 'find dash to remove sheet name
from title i.e. " - sheet1"
FileName = Mid(FileName, 1, dashpos - 2)
Else
dotpos = InStrRev(FileName, ".")
slashpos = InStrRev(FileName, "\")

If dotpos <> 0 Then ' if contains a dot (extension exists) then
chop off extension
FileName = Mid(FileName, slashpos + 1, dotpos - slashpos - 1)
Else 'does not contain a dot
FileName = Right(FileName, Len(FileName) - slashpos)
End If
End If

Load UserForm1

'set the filter
UserForm1.CommonDialog1.Filter = "All Files (*.*)|*.*|PDF Files
(*.pdf)|*.pdf|SolidWorks Drawing Files (*.slddrw)|*.slddrw"
' Specify default filter.
UserForm1.CommonDialog1.FilterIndex = 2

'Set the default file name
UserForm1.CommonDialog1.FileName = "C:\TEMP-PDF\" + FileName
'FileName = "C:\xxx.DXF"

' Set CancelError is True
UserForm1.CommonDialog1.CancelError = True

' CancelError is True.
On Error GoTo ErrHandler

UserForm1.CommonDialog1.ShowSave

FileName = UserForm1.CommonDialog1.FileName
Drawing.SaveAs3 FileName, swSaveAsCurrentVersion, swSaveAsOptions
ErrHandler:
' User pressed Cancel button.
Unload UserForm1
Exit Sub

End Sub

 

If you want just the basename and not the .slddrw then you can use
instrev to identify the dot position.

strBaseName = Left(strName, len(StrName) - InStrRev(1, StrName, ".",
vbTextCompare)

I think, coding off the top of my head here.

 

I appreciate everyones help. Let me try again. Here is my simplified
code. The problem is that when I try to do my SaveAS, I get errors.
Everything else works OK. Can anyone tell me what is going on with my
SaveAS, and specifically what I need to change.

Sub main()
Dim StartingPath As String
Dim SlashPosition As Integer
Dim FileName As String
Dim FileNameNoExt As String
Dim FolderName As String
Dim FinalPath As String

Set swApp = Application.SldWorks
Set ModelDoc = swApp.ActiveDoc

' gets the path of the file
StartingPath = ModelDoc.GetPathName
'gets the position of last \
SlashPosition = InStrRev(StartingPath, "\")
'removes path and leaves part name
FileName = Right(StartingPath, Len(StartingPath) -
SlashPosition)
'takes off the SLDPRT
FileNameNoExt = Left(FileName, Len(FileName) - 6)
'give 1st 4 characters of part name
FolderName = Left$(FileName, 4)
'final path for save pdf
FinalPath = "H:\DWGS\" & FolderName & "\" & FileNameNoExt &
"PDF"

ModelDoc2.SaveAs4 FinalPath, swSaveAsCurrentVersion,
swSaveAsCurrentVersion

End Sub

 

I appreciate everyones help. Let me try again. Here is my simplified
code. The problem is that when I try to do my SaveAS, I get errors.
Everything else works OK. Can anyone tell me what is going on with my
SaveAS, and specifically what I need to change.

Sub main()
Dim StartingPath As String
Dim SlashPosition As Integer
Dim FileName As String
Dim FileNameNoExt As String
Dim FolderName As String
Dim FinalPath As String

Set swApp = Application.SldWorks
Set ModelDoc = swApp.ActiveDoc

' gets the path of the file
StartingPath = ModelDoc.GetPathName
'gets the position of last \
SlashPosition = InStrRev(StartingPath, "\")
'removes path and leaves part name
FileName = Right(StartingPath, Len(StartingPath) -
SlashPosition)
'takes off the SLDPRT
FileNameNoExt = Left(FileName, Len(FileName) - 6)
'give 1st 4 characters of part name
FolderName = Left$(FileName, 4)
'final path for save pdf
FinalPath = "H:\DWGS\" & FolderName & "\" & FileNameNoExt &
"PDF"

ModelDoc2.SaveAs4 FinalPath, swSaveAsCurrentVersion,
swSaveAsCurrentVersion

End Sub

 

Hope you don't mind my input...This is assembled from various sources
and input on eng-tips. I've left in three methods to set where to
save the PDF. Just comment out the methods not in use. It set it up
to limit PDFs only of drawings, but it can be changed to produce them
for models and assemblies too. This code includes error handling.


Dim SwApp As SldWorks.SldWorks
Dim Model As SldWorks.ModelDoc2
Dim MyPath, ModName, NewName As String
Dim MB As Boolean
Dim Errs As Long
Dim Warnings As Long

Sub main()

Set SwApp = Application.SldWorks

' This ensures that there are files loaded in SolidWorks
Set Model = SwApp.ActiveDoc
If Model Is Nothing Then
MB = MsgBox("No drawing loaded!", vbCritical)
Exit Sub
End
End If

' Admonish user if attempted to run macro on part or assy file
If Model.GetType <> 3 Then
SwApp.SendMsgToUser "Current document is not a drawing."
End
End If

' Use one of the three following options for PDF save location
' Comment out the options with are not used.

' Option 1: Use the current directory
' MyPath = CurDir
'
' Option 2: Specify the directory you want to use
' MyPath = "C:\PDF"

' Option 3: Use the drawing folder
MyPath = Left(Model.GetPathName, InStrRev(Model.GetPathName, "\") -
1)

' Status
ModName = Left(Model.GetTitle, InStrRev(Model.GetTitle, " Sheet") -
3)
NewName = ModName & ".pdf"
MsgBox "Save " & NewName & " to" & Chr(13) & MyPath & Chr(13) &
Chr(13) & "(No notification will occur " & Chr(13) & "for success PDF
creation.)"

' PDF Creation
MB = Model.SaveAs4(MyPath & "\" & NewName, swSaveAsCurrentVersion,
swSaveAsOptions_Silent, Errs, Warnings)

' Warnings to user on Error
' MsgBox "Errors: " & Errs & vbCrLf & "Warnings: " & Warnings
If Warnings <> 0 Then
MsgBox "There were warnings. PDF creation may have failed.
Verify" & Chr(13) & "results and check possible causes.", vbExclamation
Else
End If

If MB = False Then
MsgBox "PDF creation has failed! Check save location, available"
& Chr(13) & "disk space or other possible causes.", vbCritical
Else
End If

'Clear immediate values
Set Model = Nothing
Set MyPath = Nothing


End Sub

 

thx fcsuper. I have tried to use your code, but there is one thing
that is going wrong. I modified your code by taking out some of the
error checking and adding FolderName as a variable. Whenever I use
that variable the save will not work, but if I comment it out, the save
works fine. What is the deal with that variable. Someone please help
me with this.



Dim SwApp As SldWorks.SldWorks
Dim Model As SldWorks.ModelDoc2
Dim MyPath, ModName, NewName, FolderName As String
Dim MB As Boolean
Dim Errs As Long
Dim Warnings As Long
Sub main()

Set SwApp = Application.SldWorks
Set Model = SwApp.ActiveDoc

If Model Is Nothing Then
MB = MsgBox("No drawing loaded!", vbCritical)
Exit Sub
End
End If

If Model.GetType <> 3 Then
SwApp.SendMsgToUser "Current document is not a drawing."
End
End If

ModName = Left(Model.GetTitle, InStrRev(Model.GetTitle, " Sheet") -
3)
NewName = ModName & ".pdf"
FolderName = Left(ModName, 4)

MyPath = "H:\DWGS\" & FolderName & "\" & NewName

MB = Model.SaveAs4(MyPath, swSaveAsCurrentVersion,
swSaveAsOptions_Silent, Errs, Warnings)

End Sub

 

to anyone else out there who is wondering what the answer was. I will
tell you. It would only save the PDF to a folder that already existed.
It was not in the code to create a folder. Here is the code that will
allow you to do this. Hope this helps someone. Thanks everyone for
your input.

Dim SwApp As SldWorks.SldWorks
Dim Model As SldWorks.ModelDoc2
Dim MyPath, ModName, NewName, FolderName As String
Dim MB As Boolean
Dim Errs As Long
Dim Warnings As Long
Sub main()

Set SwApp = Application.SldWorks
Set Model = SwApp.ActiveDoc

'checks to see if something is open
If Model Is Nothing Then
MB = MsgBox("No drawing loaded!", vbCritical)
Exit Sub
End
End If

'checks to make sure drawing is open
If Model.GetType <> 3 Then
SwApp.SendMsgToUser "Current document is not a drawing."
End
End If

'check to make sure drawing has been saved
FileName = Model.GetPathName
If FileName = "" Then
MB = MsgBox("Save Drawing First!", vbCritical)
Exit Sub
End
End If

ModName = Left(Model.GetTitle, InStrRev(Model.GetTitle, " Sheet") -
3) & ".pdf" 'gets file name & adds pdf extension
FolderName = Left(ModName, 4) 'gets first 4 characters from file
name

'CreateDir "H:\DWGS\", FolderName 'creates folder in directory
uncomment if needed

MyPath = "H:\DWGS\" & FolderName & "\" & ModName 'only works if
folder has already been created

MB = Model.SaveAs4(MyPath, swSaveAsCurrentVersion,
swSaveAsOptions_Silent, Errs, Warnings)

'ERROR CHECKING IF NEEDED
'MsgBox "Errors: " & Errs & vbCrLf & "Warnings: " & Warnings
'If Warnings <> 0 Then
' MsgBox "There were warnings. PDF creation may have failed.
Verify" & Chr(13) & "results and check possible causes.", vbExclamation
'Else
'End If

'If MB = False Then
' MsgBox "PDF creation has failed! Check save location,
available" & Chr(13) & "disk space or other possible causes.",
vbCritical
'Else
'End If

End Sub
Sub CreateDir(Path As String, MyFolder As String)
Dim stPath As String
On Error Resume Next
stPath = Path & "\" & MyFolder
MkDir stPath
End Sub

 

Ah, I think I know what you are doing wrong. You are trying to create
a folder that matches the name of the drawing and then saving the
drawing into it.

So if you had a drawing called MyDraw.slddrw you wanted it saved to:

H:\DWGS\MyDraw\MyDraw.pdf

But you can't save to a directory that doesn't exist! You will need to
use the windows filesystemobject to create the directory before trying
to save into it.

dim fso as object
set fso = CreateObject("Scripting.FileSystemObject")
if not fso.folderexists("H:\DWGS\" & FolderName) Then fso.CreateFolder
"H:\DWGS\" & FolderName

The other code piece you posted didn't work because you declare
modeldoc as your document object but then you do the save you used
modeldoc!2!.

Here is my code remodified to account for everything including error
messages, directory creation, drawing name without file extension, save
to folder that uses drawing name.
You can download it at http://209.123.84.162/solidworks/

 

Im confused. What are you trying to do that the macro I posted doesnt
do?

 

I was trying to take the first 4 characters of the Solidworks file name
and use that variable as a folder name in the path of the place where
the PDF was going to be saved. In hindsight, my problem was that it
would only save to a folder that was manually created. I have now
figured out how to create one on the fly now. Sorry for all of the
confusion.

 

fcsuper ,
Im looking at the macro you posted to replace mine. The issue I have
with mine and yours is it doesnt notify you if the PDF already exist.
In SW 2004, my macro did this. Something must have changed in the
code, but I cant figure it out.

Any ideas?

If a PDF already exist in the directory its saving to, I want a message
asking "are you sure you want to overwrite".

 

A simple FileExists call should ensure that you don't overwrite a
pre-existing file. Only a few additional lines of code.

 

I want the user to be allowed to overwrite the file, I just want them
to be notified that a file exist already.

Do you know the code I can use for this?

Like I said, the macro does this in SW 2004, but not in SW 2005.

 

I want the user to be allowed to overwrite the file, I just want them
to be notified that a file exist already.

Do you know the code I can use for this?


Like I said, the macro does this in SW 2004, but not in SW 2005.

Im also trying to figure out how to open the PDF after it is generated.
This would allow the user to verify everything looks good.

 

Just before the save add something like this (make sure you add
reference to microsoft scripting runtime)

Dim fso As object
Dim file as object
set fso = createobject("Scripting.FileSytemObject")

if FileExists(PathToWhereFileWillBeSaved) = True Then
msgbox "I'm going to overwrite this file."
Set File = PathToWhereFileWillBeSaved
File.Delete
if FileExists(PathToWhereFileWillBeSaved) = True Then msgbox
"oops i couldnt delete the file. It must be open already or
something."
End if

 

Mr Who,

I cant get the above to work with my macro posted above. (I added a
reference to MS scripting runtime)

 

That was just the code outline. The actual working code would be like
this.

FileName = "C:\temp\myFile.pdf"
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(FileName) = True Then
MsgBox "I'm going to overwrite: " & FileName
Set file = fso.GetFile(FileName)
file.Delete
If fso.FileExists(FileName) = True Then MsgBox "oops i couldnt
delete the file. It must be open already or something."
End If

In terms of integrating it with your existing macro you have to call it
just before Drawing.SaveAs3 FileName, swSaveAsCurrentVersion,
swSaveAsOptions. I am assuming that FileName is the full path to the
PDF file. I can't actually test this with your code because your code
is dependent on the presence of a userform. Anyone else following this
thread should take note that you can't cut and paste the monkey code
and have it work on your system.

 

Thanks
Thats odd. It seems to work just fine now. I did the same thing you
posted, changed "PathToWhereFileWillBeSaved" to "Filename".

I also removed this line
FileName = "C:\temp\myFile.pdf"
Since I already had a variable called Filename.

It seems to work fine now. Is it bad that I am using a form to store
the filename?

LOL @ the "monkey code" comment.