Open Drawing macro

For what it's worth, here's a macro I've been finding useful.
It takes the place of the Open Drawing function when right-clicking on
a part or assembly in the feature manager. I've been frustrated with
SWX in the past with multiple drawing files created from a single part
or assembly file and each linked to a configuration, since the Open
Drawing function only looks for drawing files with the same name as
the part or assembly file. So this macro looks at the "Part number to
be displayed in the BOM" in the configuration properties and tries to
find a file with that name to open before defaulting to the standard
Open Drawing behavior. So each configuration can have its own
drawing, you just name it the same as the BOM part number. I was
using the hyperlinked note technique for this problem, but I think
this is a little easier.
Be sure to import swconst.bas to the macro project.
Eric
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Public Function stripPath(ByVal stringToModify As String) As String
'functions strips the path and file extension by removing
'anything to the left of "\" character and right of the "." character
Dim index As Long
If stringToModify = "" Then 'true if the file hasn't been save yet
stripPath = stringToModify
Exit Function
End If
stringToModify = StrReverse(stringToModify)
index = InStr(1, stringToModify, "\", vbTextCompare) - 1
If index > 0 Then stringToModify = Left(stringToModify, index)
index = InStr(1, stringToModify, ".", vbTextCompare)
stringToModify = StrReverse(stringToModify)
If index > 0 Then stringToModify = Left(stringToModify,
Len(stringToModify) - index)
stripPath = stringToModify
End Function
Public Function getPath(ByVal stringToModify As String) As String
'gets the path
Dim index As Long
getPath = ""
If stringToModify = "" Then Exit Function
stringToModify = StrReverse(stringToModify)
index = InStr(1, stringToModify, "\", vbTextCompare) - 1
If index > 0 Then stringToModify = Right(stringToModify,
Len(stringToModify) - index)
getPath = StrReverse(stringToModify)
End Function
Public Function docAintDrawing() As Boolean
'make sure the current document is a part or assembly
If swModel Is Nothing Then
swApp.SendMsgToUser ("Please open a part or assembly document
first.")
docAintDrawing = False
ElseIf swModel.GetType() = swDocPART Or swModel.GetType =
swDocASSEMBLY Then
docAintDrawing = True
Else
swApp.SendMsgToUser ("Please open a part or assembly document
first.")
docAintDrawing = False
End If
End Function
Sub main()
Dim swConfig As SldWorks.Configuration
Dim fileName As String
Dim theName As String
Dim Errors As Long
Dim Warnings As Long
Set swApp = CreateObject("SldWorks.Application")
Set swModel = swApp.ActiveDoc
If Not docAintDrawing Then
Exit Sub
End If
Set swConfig = swModel.GetActiveConfiguration
fileName = swModel.GetPathName
swApp.SetCurrentWorkingDirectory getPath(fileName)
fileName = stripPath(fileName)
Errors = -9009
If swConfig.UseAlternateNameInBOM And swConfig.alternateName = "" Then
'try to open the configuration name
swApp.OpenDoc6 swConfig.Name & ".SLDDRW", swDocDRAWING,
swOpenDocOptions_Silent, "", Errors, Warnings
End If
If Errors = -9009 Or Errors 0 Then
If swConfig.UseAlternateNameInBOM And swConfig.alternateName ""
Then 'try to open a file with the user supplied name
swApp.OpenDoc6 swConfig.alternateName & ".SLDDRW",
swDocDRAWING, swOpenDocOptions_Silent, "", Errors, Warnings
End If
End If
If Errors = -9009 Or Errors 0 Then
swApp.OpenDoc6 fileName & ".SLDDRW", swDocDRAWING,
swOpenDocOptions_Silent, "", Errors, Warnings
End If
If Errors = swFileNotFoundError Then
swApp.SendMsgToUser "Can't find a file with name, go find it
yourself."
End If
Set swApp = Nothing
Set swModel = Nothing
Set swConfig = Nothing
End Sub
Reply to
Eric Zuercher
Loading thread data ...

PolyTech Forum website is not affiliated with any of the manufacturers or service providers discussed here. All logos and trade names are the property of their respective owners.