ds-blue-logo
Preview  |  SOLIDWORKS USER FORUM
Use your SOLIDWORKS ID or 3DEXPERIENCE ID to log in.
CLCharles Lewis08/10/2021

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