CADSharp

MACRO LIBRARY

Lesson 6.3 code

Free public access. No account or subscription required.

Files

Associated model(s) Lesson 6.3 code

Code

Module: mMain

'Lesson 6.3 complete code
    
'Code in mMain is a heavily modified version of the macro provided in S-013887
'Modified by Keith Rice
'CADSharp LLC
'www.cadsharp.com
    
Option Explicit
    
#If VBA7 Then
    
Sub main()
    'Show form
    UserForm1.Show vbModeless
End Sub
    
#Else
    
'Determines whether a file is an executable (.exe) file, and if so, which subsystem runs the executable file.
Declare Function GetBinaryType Lib "kernel32" Alias "GetBinaryTypeA" (ByVal sFileName As String, ByRef BinType As Long) As Long
    
'Retrieves a handle to the top-level window whose class name and window name match the specified strings.
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    
'Changes the size, position, and Z order of a child, pop-up, or top-level window.
Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    
Sub main()
    Dim lBinaryType As Long
    Dim hWnd As Boolean     'window handle
    Dim swApp As SldWorks.SldWorks
    Set swApp = Application.SldWorks
    
    'This function returns lBinaryType as 6 for x64 and 0 for x86 (32 bit)
    GetBinaryType swApp.GetExecutablePath & "\sldworks.exe", lBinaryType
    
    'Show form
    UserForm1.Show vbModeless
    
    'If x64 make form on top
    If lBinaryType = 6 Then
        hWnd = FindWindow(vbNullString, UserForm1.Caption)
        'See this article for information on SetWindowPos arguments: _
            http://msdn.microsoft.com/en-us/library/windows/desktop/ms633545(v=vs.85).aspx
        'The flags are currently set for SWP_NOMOVE and SWP_NOSIZE
        SetWindowPos hWnd, -1, 0, 0, 0, 0, 1 + 2
    End If
End Sub
    
#End If

Module: mBrowseFolder

#If VBA7 Then
    
Private Type BROWSEINFO
hOwner As LongPtr
pidlRoot As LongPtr
pszDisplayName As String
lpszTitle As String
ulFlags As LongPtr
lpfn As LongPtr
lParam As LongPtr
iImage As LongPtr
End Type
    
Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias _
            "SHGetPathFromIDListA" (ByVal pidl As LongPtr, _
            ByVal pszPath As String) As LongPtr
            
Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" Alias _
            "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
            As LongPtr
            
Dim X As LongPtr, bi As BROWSEINFO, dwIList As LongPtr
    
#Else
    
Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
    
Private Declare  Function SHGetPathFromIDList Lib "shell32.dll" Alias _
            "SHGetPathFromIDListA" (ByVal pidl As Long, _
            ByVal pszPath As String) As Long
            
Private Declare  Function SHBrowseForFolder Lib "shell32.dll" Alias _
            "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
            As Long
            
Dim X As Long, bi As BROWSEINFO, dwIList As Long
    
#End If
    
Private Const BIF_RETURNONLYFSDIRS = &H1
    
Public Function BrowseFolder(szDialogTitle As String) As String
    
Dim szPath As String, wPos As Integer
    
    With bi
        .hOwner = hWndAccessApp
        .lpszTitle = szDialogTitle
        .ulFlags = BIF_RETURNONLYFSDIRS
    End With
    
    dwIList = SHBrowseForFolder(bi)
    szPath = Space$(512)
    X = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)
    
    If X Then
        wPos = InStr(szPath, Chr(0))
        BrowseFolder = Left$(szPath, wPos - 1)
    Else
        BrowseFolder = vbNullString
    End If
End Function

User Form: UserForm1

Dim strFolderPath As String
Dim strResults As String
    
Private Sub cmdBrowse_Click()
    strFolderPath = BrowseFolder("Browse")
    txtFolderPath.Text = strFolderPath
End Sub
    
Private Sub cmdResults_Click()
    If strFolderPath <> "" Then _
        Shell "notepad.exe " & strFolderPath & "results.txt", vbMaximizedFocus
End Sub
    
Private Sub cmdRun_Click()
    Dim swApp As SldWorks.SldWorks
    Dim swModel As SldWorks.ModelDoc2
    Dim swDraw As SldWorks.DrawingDoc
    Dim swFeat As SldWorks.Feature
    Dim swSubFeat As SldWorks.Feature
    Dim swView As SldWorks.View
    Dim swNote As SldWorks.Note
    Dim strFile As String
    Dim lngErrors As Long
    Dim lngWarnings As Long
    Dim i As Integer
    Dim strNoteTextOrig As String
    Dim strNoteTextFinal As String
    
    Set swApp = Application.SldWorks
    
    'Make sure user has selected a directory
    txtFolderPath.Text = strFolderPath
    If strFolderPath = "" Then
        swApp.SendMsgToUser "Please browse for a folder."
        Exit Sub
    End If
    strFolderPath = strFolderPath & "\"
    
    'Add data to results string
    strResults = "Time: " & Date & " " & Time & vbCrLf & _
        "Folder: " & strFolderPath & vbCrLf
    
    'Begin traversing all drawing files in selected directory
    strFile = Dir(strFolderPath & "*.SLDDRW", vbNormal)
    Do While strFile <> ""
        strResults = strResults & "File: " & strFile & vbCrLf
        swApp.OpenDoc6 strFolderPath & strFile, swDocDRAWING, 0, Empty, lngErrors, lngWarnings
        If lngErrors <> 0 Then
            strResults = strResults & "    Error " & lngErrors & " occurred. Abort." & vbCrLf
            End
        End If
        
        'Check drawing views to make sure they are referencing "Light" configuration
        Set swModel = swApp.ActiveDoc
        Set swFeat = swModel.FirstFeature
        While Not swFeat Is Nothing
            Set swSubFeat = swFeat.GetFirstSubFeature
            While Not swSubFeat Is Nothing
                If swSubFeat.GetTypeName = "AbsoluteView" Or _
                    swSubFeat.GetTypeName = "UnfoldedView" Then
                    Set swView = swSubFeat.GetSpecificFeature2
                    If swView.ReferencedConfiguration = "Heavy" Then
                        swView.ReferencedConfiguration = "Light"
                        strResults = strResults & "    Configuration changed for " & _
                            swView.Name & vbCrLf
                    End If
                End If
                Set swSubFeat = swSubFeat.GetNextSubFeature
            Wend
            Set swFeat = swFeat.GetNextFeature
        Wend
        
        'Modifies Author note at sheet format level for normal and compound notes
        Set swDraw = swModel
        swDraw.EditTemplate
        Set swView = swDraw.GetFirstView
        Set swNote = swView.GetFirstNote
        While Not swNote Is Nothing
            If swNote.IsCompoundNote Then   'See API Help article "Compound Note"
                For i = 1 To swNote.GetTextCount
                    strNoteTextOrig = swNote.GetTextAtIndex(i)
                    strNoteTextFinal = Replace(strNoteTextOrig, "CADSHARP", "CADSHARP LLC")
                    swNote.SetTextAtIndex i, strNoteTextFinal
                    If strNoteTextOrig <> strNoteTextFinal Then strResults = strResults & _
                        "    Note text replacement occurred" & vbCrLf
                Next i
            Else
                strNoteTextOrig = swNote.GetText
                strNoteTextFinal = Replace(strNoteTextOrig, "CADSHARP LLC", "CADSHARP")
                swNote.SetText strNoteTextFinal
                If strNoteTextOrig <> strNoteTextFinal Then strResults = strResults & _
                    "    Note text replacement occurred" & vbCrLf
            End If
            Set swNote = swNote.GetNext
        Wend
        swDraw.EditSheet
        
        'Rebuild
        swModel.ForceRebuild3 False
        
        'Zoom to fit
        swModel.ViewZoomtofit2
        
        'Save doc
        swModel.Save3 1, Empty, Empty
        
        'Close doc
        swApp.CloseDoc strFolderPath & strFile
        
        strFile = Dir
    Loop
    
    Call PrintResults
End Sub
    
Sub PrintResults()
    'File Scripting Object reference must be added
    Dim oFSO As FileSystemObject
    Set oFSO = New FileSystemObject
    
    'Open the text file
    Dim oTextStream As TextStream
    Set oTextStream = oFSO.OpenTextFile(strFolderPath & "results.txt", 8, True)
    
    'Write to the file
    oTextStream.WriteLine strResults
    
    'Close the file and clean up
    oTextStream.Close
    Set oTextStream = Nothing
    Set oFSO = Nothing
End Sub