ds-blue-logo
Preview  |  SOLIDWORKS USER FORUM
Use your SOLIDWORKS ID or 3DEXPERIENCE ID to log in.
MTMARCO TULIO RAMOS FILHO11/08/2017

I'm trying to run a macro to a number of problematic drawing files to repair their views that became hidden. Is a simple macro that check-out the file, open it in SOLIDWORKS, unhide their views, save the file and check-in back to the vault.

In a normal test environment everything went ok, but when it runs on customer vault this one problem became a nightmare.

In some files an 'Save As' dialog shows up and the task hangs and resume run only when the user clicks 'Cancel'. I don't know in first place why the 'Save As' dialog shows up and I don't know how to progamatically clicks the cancel button.

The code is the following:

Dim swApp As Object

Dim swModel As SldWorks.ModelDoc2

Dim errors As Long

Dim warnings As Long

Dim FileSystemObj As Object

Dim swModExt As SldWorks.ModelDocExtension

Dim Vault As Object

Dim swDraw As SldWorks.DrawingDoc

Dim swSheet As SldWorks.Sheet

Dim swView As SldWorks.View

Dim vViews As Variant

Dim i As Integer

#If VBA7 Then

Private Declare PtrSafe Function GetLongPathName Lib "kernel32" Alias "GetLongPathNameA" (ByVal lpszShortPath As String, ByVal lpszLongPath As String, ByVal cchBuffer As Long) As Long

Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long

Private Declare PtrSafe Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long

Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long

Private Declare PtrSafe Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

  

#Else

Private Declare Function GetLongPathName Lib "kernel32" Alias "GetLongPathNameA" (ByVal lpszShortPath As String, ByVal lpszLongPath As String, ByVal cchBuffer As Long)  As Long

Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long

Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long

Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long

Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

#End If

Sub OpenAndRebuild(docFileName)

   Call LoginToVault

   Dim strCheckOutFileErrorMessage As String

   strCheckOutFileErrorMessage = CheckOutFile((docFileName))

   docType = swDocDRAWING

   Set swModel = swApp.OpenDoc6(docFileName, docType, swOpenDocOptions_Silent, "", errors, warnings)

   If errors = swFutureVersion Then

          Log "Document '" & docFileName & "' is future version."

          Exit Sub

   End If

' Load failed?

If swModel Is Nothing Then

Log "Method call SldWorks::OpenDoc6 for document '" & docFileName & "' failed. Error code " & errors & " returned."

Exit Sub

End If

Set swDraw = swModel

Set swSheet = swDraw.GetCurrentSheet

vViews = swSheet.GetViews

swModel.ClearSelection2 False

For i = 0 To UBound(vViews)

Set swView = vViews(i)

swModel.Extension.SelectByID2 swView.Name, "DRAWINGVIEW", 0, 0, 0, True, 0, Nothing, 0

swModel.UnsuppressView

Next i

swModel.ClearSelection2 True

swModel.Save

swApp.QuitDoc swModel.GetTitle

Dim strCheckInFileErrorMessage As String

strCheckInFileErrorMessage = CheckInFile((docFileName))

End Sub

Private Sub LoginToVault()

On Error GoTo ErrHand

Dim strTempVaultName As String

Dim strVaultName As String

strTempVaultName = "<VaultPath>"

i = Len(strTempVaultName)

j = InStrRev(strTempVaultName, "\")

strVaultName = Right(strTempVaultName, i - j)

Set Vault = CreateObject("ConisioLib.EdmVault.1")

Vault.LoginAuto strVaultName, 0

Exit Sub

ErrHand:

If Not Vault Is Nothing Then

Dim ErrName As String

Dim ErrDesc As String

Vault.GetErrorString Err.Number, ErrName, ErrDesc

MsgBox "Could not open file vault." + vbLf + ErrName + vbLf + ErrDesc

'ErrorOut "Could not open file vault.", errorFilePath

Else

MsgBox "Error creating file vault interface."

End If

End Sub

Private Function CheckOutFile(strFileName As String) As String

On Error GoTo ErrHand

Dim folder As Object

Dim folderPath As String

Dim FolderPath1 As String

folderPath = strFileName

j = InStrRev(folderPath, "\")

FolderPath1 = Left(folderPath, j)

Set folder = Vault.GetFolderFromPath(FolderPath1)

i = Len(strFileName)

j = InStrRev(strFileName, "\")

FileName = Right(strFileName, i - j)

Dim file As Object

Dim oNull As Object

Set file = folder.GetFile(FileName)

If file Is Nothing Then

'MsgBox "File not found."

Exit Function

End If

file.LockFile folder.ID, 0

CheckOutFile = "Successful"

Exit Function

ErrHand:

Dim ename As String

Dim edesc As String

Vault.GetErrorString Err.Number, ename, edesc

CheckOutFile = edesc

'MsgBox ename + vbLf + edesc

End Function

Private Function CheckInFile(strFileName As String) As String

On Error GoTo ErrHand

Dim file As Object

Dim oNull As Object

Set file = Vault.GetFileFromPath(strFileName, oNull)

If file Is Nothing Then

'MsgBox "File not found."

Exit Function

End If

file.UnlockFile 0, "The file was checked in!"

CheckInFile = "Successful"

Exit Function

ErrHand:

Dim ename As String

Dim edesc As String

Vault.GetErrorString Err.Number, ename, edesc

CheckInFile = edesc

'MsgBox ename + vbLf + edesc

End Function

Sub main()

'debug.assert false

On Error GoTo Fail:

Set FileSystemObj = CreateObject("Scripting.FileSystemObject")

docFileName = "<Filepath>"

If LCase(Right(docFileName, 7)) = ".slddrw" then

' Get SW interface object

Set swApp = Application.SldWorks

swApp.Visible = True    'SPR 682792, 538578, 651998

OpenAndRebuild docFileName

Exit Sub

Else

Exit Sub

End If  

 

Fail:

Log "Error while OpenAndRebuilding file '" & docFileName & "': " & vbCrLf & _

"An unexpected error occurred while executing the generated script. Script syntax error?" & vbCrLf & _

"Error number: " & Err.Number & vbCrLf & _

"Error description: '" & Err.Description & "'" & vbCrLf

End Sub