如何用VBA从SolidWorks路径提取编号并重命名STEP文件

Here's the modified VBA code that automatically extracts the 4-digit project number from the folder matching your XXX_0000_XXXX pattern (regardless of its position in the path):

'Declare variables
Dim swApp As Object
Dim Part As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Dim PathInit, PathCut  As String

Sub SaveFiles()
    'Use opened file as active document
    Set swApp = Application.SldWorks
    Set Part = swApp.ActiveDoc
    
    'Prepare path
    PathInit = Part.GetPathName 'Determine file location of the assembly
    PathCut = Left(PathInit, InStrRev(PathInit, "\")) 'Remove text after the last slash
 
    'Open user form
    UserParam.Show
    
End Sub

'Helper function to extract 4-digit project number from path
Function GetProjectNumberFromPath(filePath As String) As String
    Dim fso As Object
    Dim folderPath As String
    Dim folders() As String
    Dim i As Integer
    Dim regex As Object
    Dim matches As Object
    
    'Get parent folder of the part file
    Set fso = CreateObject("Scripting.FileSystemObject")
    folderPath = fso.GetParentFolderName(filePath)
    
    'Split folder path into individual components
    folders = Split(folderPath, "\")
    
    'Set up regex to match XXX_0000_XXXX pattern (capture middle 4 digits)
    Set regex = CreateObject("VBScript.RegExp")
    regex.Pattern = "^[A-Za-z]{3}_(\d{4})_[A-Za-z]{4}$"
    regex.IgnoreCase = True 'Handle both uppercase/lowercase letters
    
    'Check each folder for a match
    For i = LBound(folders) To UBound(folders)
        Set matches = regex.Execute(folders(i))
        If matches.Count > 0 Then
            GetProjectNumberFromPath = matches(0).SubMatches(0)
            Exit Function 'Return immediately once match is found
        End If
    Next i
    
    'Return empty string if no match found
    GetProjectNumberFromPath = ""
End Function

Public Sub UserInput(InputFS, InputMS As String)
    Dim PartNrFS, PartNrMS As String
    Dim ExtInit, ExtNew, PartNameFS, ProjectNr, XTFolder, REV  As String
    Dim partFullPath As String
    
    'New pathname settings
    ExtInit = ".SLDPRT" 'Old extension
    ExtNew = ".STEP" 'New extension (either step or xt)
    XTFolder = "XT\"
    PartNrFS = InputFS 'Input from userform
    PartNrMS = InputMS 'Input from userform
    PartNameFS = "PartName"
    REV = "[REV0]"
    
    'Open the SLDPRT file
    Set Part = swApp.OpenDoc6(PathCut + PartNameFS + ExtInit, 1, 0, "", longstatus, longwarnings)
    
    'Extract project number from the part's full path
    partFullPath = Part.GetPathName()
    ProjectNr = GetProjectNumberFromPath(partFullPath)
    
    'Handle case where no matching folder was found
    If ProjectNr = "" Then
        MsgBox "Error: Could not find a folder matching the XXX_0000_XXXX pattern in the path.", vbExclamation
        Part.CloseDoc 'Close the part if no project number found
        Exit Sub
    End If
    
    'Save the part as STEP with dynamic project number prefix
    longstatus = Part.SaveAs3(PathCut + XTFolder + ProjectNr + "_" + PartNrFS + " " + PartNameFS + " " + REV + ExtNew, 0, 2)
    
End Sub

Key Changes Explained: #

1. Helper Function GetProjectNumberFromPath:

   • Uses Scripting.FileSystemObject to isolate the parent folder of the part file.
   • Splits the folder path into individual components for inspection.
   • Uses regular expressions to identify folders matching your XXX_0000_XXXX structure, capturing the middle 4-digit segment.

2. Updated UserInput Sub:

   • Retrieves the full path of the opened part to parse for the project number.
   • Adds error handling to alert the user and clean up if no matching folder is found.
   • Replaces the hardcoded ProjectNr with the dynamically extracted value in the final STEP filename.

3. Regex Pattern:

   • ^[A-Za-z]{3}_(\d{4})_[A-Za-z]{4}$: Explicitly matches your folder naming convention, with the IgnoreCase flag ensuring compatibility with mixed-case letters.

内容的提问来源于stack exchange，提问作者JetskiS