VBA - Save as Automatic Drawing

Out of category
1

Hello, I would like to make a mep that from a room, opens its drawing and saves under the room and the mep under the same name. I made the code below, while testing it, the variables are good but it doesn't work ...

Thank you for your help:)

 

Sub main()

Set swApp = _

Application.SldWorks

Set swModel = swApp.ActiveDoc

FilePath = swModel.GetPathName

TitleP = swModel.GetTitle

PathSize = Len(FilePath)

PathNoExtension = Left(FilePath, PathSize - 7)

PathMEP = PathNoExtension & ". SLDDRW"

TitleSize = Len(TitleP)

TitleNoExtension = Left(TitleP, TitleSize - 7)

TitleMEP = TitleNoExtension & " - Sheet1"

Set Part = swApp.OpenDoc6(PathMEP, 2, 0, "", longstatus, longwarnings) 'opening source assembly'

swApp.ActivateDoc2 TitleMEP, False, longstatus

Set Part = swApp.ActiveDoc 'activation'

Set swApp = Application.SldWorks

Set swModel = swApp.ActiveDoc

bool = swModel.Extension.RunCommand(SwCommands.swCommands_SaveAs, "")

Set swModel = swApp.ActiveDoc

'Recovers the full name of the file

FilePath = swModel.GetPathName

PathSize = Len(FilePath)

PathNoExtension = Left(FilePath, PathSize - 6)

PathMEP = PathNoExtension & ". SLDDRW"

Set Part = swApp.ActiveDoc

longstatus = Part.SaveAs3(FilePathMEP, 0, 2)

End Sub

 

2

Hello

I advise you to watch the macro record under that I put as a tutorial on Lynkoa:

http://www.lynkoa.com/tutos/3d/macro-enregistrer-sous-avec-solidworks

She does what you ask and every line is commented on.

3

Is it possible to have the code directly in macro format please ? It will be more readable:) 

4

The code is available in the link, but if you prefer it this way, here it is :

'3/19/2012 4:46 PM works but only if DRW has the same name in the same folder
Sub SAVE() 'save as
Dim swApp As SldWorks.SldWorks
Dim SWmoddoc As SldWorks.ModelDoc2
Dim CODE As String
Dim nErrors             As Long
Dim nWarnings           As Long
Set swApp = Application.SldWorks
Set SWmoddoc = swApp.ActiveDoc
Gets the full path of the current document, including the file name:
PathName = UCase(SWmoddoc.GetPathName)     
'check that we are not on a drw = 2D:
If Right(PathName, 3) = "DRW" Then
    MesgBOX = MsgBox("Macro to be launched only from a part or assembly", vbMsgBoxSetForeground, "Save-As (By LPR)")
    Exit Sub
    ElseIf Right(PathName, 3) = "PRT" Then
        DRWPath = Replace(PathName, "PRT", "DRW")
    ElseIf Right(PathName, 3) = "ASM" Then
        DRWPath = Replace(PathName, "ASM", "DRW")
End If
Gets the path to the current document, without the file name:
FilePath = Left(PathName, InStrRev(PathName, "\"))
Gets the file name:
FileName = Right(PathName, Len(PathName) - InStrRev(PathName, "\")) 
'retrieves the custom property (=CustomInfo) CODE (CustomInfo) =>SPECIFIC CODE:
CODE = SWmoddoc.CustomInfo("code")
If CODE = "" Then
'If the code doesn't exist, retrieve the first 8 characters of the =>SPECIFIC CODE & 8 characters file
    CODE = Left(Replace(FileName, " ", ""), 8)    
End If    
'retrieves the file designation (FR label in our case) =>SPECIFIC FR label:
FR = SWmoddoc.CustomInfo("FRLED")
If libelleFR = "" Then
' retrieves the label based on the filename -7 character = extension (. SLDASM for example) =>SPECIFIC LibelFR:
    libelleFR = Left(Right(FileName, Len(FileName) - InStr(FileName, "-")), Len(Right(FileName, Len(FileName) - InStr(FileName, "-"))) - 7)
End If
'Confirmation Request Message:
RET = MsgBox("Do you want to create a copy of this part (or assembly) and its drawing under new code?" & vbNewLine & vbNewLine & "WARNING: the file will be replaced in ALL open SolidWorks files!", vbOKCancel + vbExclamation + vbMsgBoxSetForeground + vbSystemModal, "Save-As (By LPR)")
'If cancel: end of the program:
If RET = vbCancel Then End
 

5

'If the drw (=2D) exists:
If Dir$(DRWPath) <> "" Then
    Then we open it:
    Set open = swApp.OpenDoc6(DRWPath, swDocDRAWING, swOpenDocOptions_Silent, "", nErrors, nWarnings)
    DRWNull = 0
    Else
    'or we warn that it does not exist in the same file:
    DRWNull = MsgBox("The drawing is not found, either:" & vbNewLine & vbNewLine & "- the name is different from 3D" & vbNewLine & "- the folder is different from 3D" & vbNewLine & "- the drawing does not exist" & vbNewLine & vbNewLine & "Do you want to continue?", vbOKCancel + vbExclamation + vbMsgBoxSetForeground + vbSystemModal, "Save-Under (By LPR)")
    ' We leave the program
    If DRWNull = 2 Then Exit Sub
End If
'As long as (information in the new code): 
Do
    'the new code is not filled in =>SPECIFIC code proposed by default:
    NewCode = InputBox("To do this, please enter the new code: ", "Save-As (By LPR)", CODE)
    'If we cancel:
    If StrPtr(NewCode) = 0 Then
        MsgBox "Procedure Canceled"
        We leave:
        Exit Sub
    End If
    'Check if the code is numeric =>SPECIFIC CODE-only numeric:
    Do While IsNumeric(NewCode) = False And MessageBox <> "6"
        MessageBox = MsgBox("Be careful, your code is not uniquely numeric!" & vbNewLine & "Is this intentional?", vbYesNo)
        If MessageBox = vbNo Then NewCode = InputBox("To save-as, please specify the new code without spaces: ", "Save-under by LPR", NewCode)
    Loop
'do loop, as long as the code is not 8 characters =>SPECIFIC 8-character CODE
Loop While Len(NewCode) <> 8
'As long as (new name information = FR label):
Do
    'What's the new name? =>SPECIFIC labelFR proposed by default:
    NewName = InputBox ("Please specify the new name: " & vbNewLine & vbNewLine & "Remember to write in uppercase", "Save-under by LPR", FR label)
    'If we cancel:
    If StrPtr(NewName) = 0 Then
        MsgBox "Procedure Canceled"
        We leave:
        Exit Sub
    End If
    'Check if there are characters in the name that are forbidden in Windows" \ / : * ? > < | 
    Do while InStr(NewName, Chr(34)) > 0 or InStr(NewName, "\") > 0 or InStr(NewName, "/") > 0 _
    or InStr(NewName, ":") > 0 or InStr(NewName, "*") > 0 or InStr(NewName, "?") > 0 or InStr(NewName, "<") > 0 or InStr(NewName, ">") > 0 or InStr(NewName, "|") > 0
        'Persists of a prohibited nature
        NewName = InputBox("Warning, the name contains at least one of the forbidden characters \/:*?""<>|" & vbNewLine & vbNewLine & _
        "Please indicate the new name: ", "Save-under by LPR", NewName)
    Loop
'Do loop, as long as the new name is empty
Loop While NewName = ""
 

6

'As long as (path information or save = pathname):
Do
    'What is the way?
    FilePath = InputBox("" & vbNewLine & " ", "Save-Under by LPR", FilePath)
    If StrPtr(FilePath) = 0 Then
        MsgBox "Procedure Canceled"
        Exit Sub
    End If
    If it is not there:
    If Right(FilePath, 1) <> "\" Then FilePath = FilePath & "\"
    'Checks for the existence of a file or directory:
    If Dir$(FilePath) <> "" Then
        EXISTS = 1
    Else: MsgBox "The directory doesn't exist, please create it"
    Debug.Print Dir$(FilePath)
    End If
'Do loop, as long as the directory you have entered does not exist:
Loop While EXISTS <> 1
'reactivates the 3D document:
Set swModel = swApp.ActivateDoc2(PathName, False, nErrors)
'If it's an assembly:
If (SWmoddoc.GetType = swDocASSEMBLY) Then
    Recording under PATH & NewCode & Dash & NewName & . SLDASM  
    '=>SPECIFIC NAME-CODE
    For example, all our files are like this:
    '33333333-FILE DESIGNATION.extension
    That is to say ,
    '[8 characters] [hyphen of 6] [file designation]
    SWmoddoc.SAVEAS(FilePath + NewCode + "-" + NewName + ". SLDASM")
ElseIf (SWmoddoc.GetType = swDocPART) Then
    The registration for SLDPRT =>SPECIFIC same above
     SWmoddoc.SAVEAS(FilePath + NewCode + "-" + NewName + ". SLDPRT")
End If
Adds the custom property CODE (=>SPECIFIC CODE):
retval = SWmoddoc.AddCustomInfo3("", "CODE", 30, NewCode)
SWmoddoc.CustomInfo("CODE") = NewCode
Adds the custom property FR (=>SPECIFIC FRLABEL):
retval = SWmoddoc.AddCustomInfo3("", "FR label", 30, NewName)
SWmoddoc.CustomInfo("FR label") = NewName
Adds the custom filename property (=>SPECIFIC filename):
retval = SWmoddoc.AddCustomInfo3("", "filename", 30, NewCode & "-" & NewName)
SWmoddoc.CustomInfo("filename") = NewCode & "-" & NewName
I add the custom property Original file (=>SPECIFIC Original file: I advise you to keep this one, so you will always have the info in the properties of the 3D):
retval = SWmoddoc.AddCustomInfo3("", "Original file", 30, PathName)
SWmoddoc.CustomInfo("Original File") = PathName
'Test that the DRW (2D) exists:
If DRWNull = 0 Then
    Activate the DRW (2D):
    Set SWmoddoc = swApp.ActivateDoc2(DRWPath, False, nErrors)
    'If it's a DRW (2D):
    If SWmoddoc.GetType = swDocDRAWING Then
    Register as (see comments lines 110 to 115 =>SPECIFIC CODE-NAME)
        SWmoddoc.SAVEAS(FilePath + NewCode + "-" + NewName + ". SLDDRW")
        'deletes inserted revision tables =>SPECIFIC Revision tables
        For i = 1 To 6
            boolstatus = SWmoddoc.Extension.SelectByID2("Table of revisions" & i, "REVISIONTABLEFEAT", 0, 0, 0, False, 0, Nothing, 0)
            SWmoddoc.EditDelete
            Set currentSheet = SWmoddoc.GetCurrentSheet()
            Set myRevisionTable = currentSheet.InsertRevisionTable(True, 0, 0, 3, "\\nas01\FOLDER\Detail Review Table.sldrevtbt")
        Next i
    End If
End If
End Sub

7

Perfect by adapting your code it works perfectly:) 

Thank you once again!

1 Like