I have a macro to create our outsourced drawings to send to vendors however I would like it to ask me what configuration to select of the model. Any ideas?
Option Explicit
Sub Main()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swDrawModel As SldWorks.ModelDoc2
Dim swDraw As SldWorks.DrawingDoc
Dim swView As SldWorks.View
Dim nErrors As Long
Dim nWarnings As Long
Dim Revision As String
Dim Rev As String
Dim Description As String
Dim Ver As String
Dim dFileName As String
Dim pFileName As String
Dim ValOut As String
Dim wasResolved As Boolean
Dim bRetVal As Boolean
Dim swCustProp As SldWorks.CustomPropertyManager
Dim TodayDate As String
Const Path As String = "C:\Users\charlesl\Desktop\OUTSOURCE\" 'Change Path here
Dim prefix As String
Dim Part As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Set swApp = Application.SldWorks
Set swDrawModel = swApp.ActiveDoc
bRetVal = swApp.SetUserPreferenceIntegerValue(swStepAP, 214)
Set Part = swApp.ActiveDoc
boolstatus = Part.SetUserPreferenceToggle(swUserPreferenceToggle_e.swViewDisplayHideAllTypes, False)
boolstatus = Part.SetUserPreferenceToggle(swUserPreferenceToggle_e.swViewDispGlobalBBox, False)
' Check to see if a drawing is loaded.
If swDrawModel Is Nothing Then
MsgBox "There is no active drawing document"
Exit Sub
End If
If swDrawModel.GetType <> swDocDRAWING Then
MsgBox "Open a drawing first and then TRY again!"
Exit Sub
End If
If swDrawModel.GetPathName = "" Then
MsgBox "Plese Save the Drawing and then TRY again!"
swDrawModel.Save
Exit Sub
End If
Set swDraw = swDrawModel
Set swView = swDraw.GetFirstView
Set swView = swView.GetNextView
' Determine if there is any model view
If swView Is Nothing Then
MsgBox "No View(s) found, Insert a View first and then TRY again!"
Exit Sub
End If
' Determine if there is any model view
If swView.GetReferencedModelName = "" Then
MsgBox "No Model View(s) found, Insert a View first and then TRY again!"
Exit Sub
End If
Set swModel = swView.ReferencedDocument
Set swCustProp = swModel.Extension.CustomPropertyManager("")
swCustProp.Get5 "Revision", False, ValOut, Revision, wasResolved
Revision = swDraw.GetCustomInfoValue("", "Revision")
If Revision = "" Then
Revision = ""
End If
'Description = swDraw.GetCustomInfoValue("", "Description")
swCustProp.Get5 "Description", False, ValOut, Description, wasResolved
If Description = "" Then
Description = ""
End If
Ver = swDraw.GetCustomInfoValue("", "Ver")
If Ver = "" Then
Ver = ""
End If
'Today's Date, change format as needed but '\', '/', '. ', '?' , and '* are not allowed
TodayDate = Format(Date, "YYYY-MM-DD")
prefix = "OS "
'Drawing File Name Without Extension
dFileName = Mid(swDraw.GetPathName, InStrRev(swDraw.GetPathName, "\") + 1)
dFileName = Left(dFileName, InStrRev(dFileName, ".") - 1)
dFileName = Path + prefix + dFileName
'Save as PDF
swDraw.SaveAs3 dFileName & " REV " & Revision & " " & "[" & TodayDate & "]" & ".PDF", 0, 0
'Save as DXF
swDraw.SaveAs3 dFileName & " REV " & Revision & " " & "[" & TodayDate & "]" & ".DXF", 0, 0
Set swModel = swApp.ActivateDoc3(swModel.GetPathName, False, swRebuildActiveDoc, nErrors)
'Save as IGES
swModel.Extension.SaveAs dFileName & " REV " & Revision & " " & "[" & TodayDate & "]" & ".igs", swSaveAsCurrentVersion, swSaveAsOptions_Silent, Nothing, nErrors, nWarnings
swApp.CloseDoc swModel.GetTitle
End Sub