當 shell function 完全加載 Solidworks 時提取信息

Question

我正在嘗試使用 Excel 中的 VBA 從solidworks 中提取零件信息。 所有存儲的圖紙都在幾個本地文件夾中。 我正在使用的腳本通過從文件 dir() 命令和 shell 腳本加載每個圖形來循環遍歷每個圖形，然后通過另一個宏關閉圖形。 問題是 shell 命令的行為獨立於 VBA 代碼，因此它仍在加載 Solidworks 圖紙，同時仍在運行 vba 程序，並且在加載大型圖紙時出現運行時錯誤。 有些圖紙需要幾分鍾才能打開，有些則需要幾秒鍾才能打開。

我如何告訴 VBA 在圖紙完全加載后繼續其過程？ 我已經嘗試過 Application.wait，但有些圖紙在 3 秒內打開，而另一些在 3 分鍾內打開，我希望有一個更好的解決方案，而不是為每張圖紙等待超過 3 分鍾。

我認為在創建過程 windows.api 中可能有一些東西，但我不確定如何根據我的情況來操作它。 任何幫助表示贊賞。 謝謝！！

https://docs.microsoft.com/en-us/office/vba/access/Concepts/Windows-API/determine-when-a-shelled-process-ends

Public Sub OverallFilePathReferncer()


Dim FSOLibrary As Object
Dim FSOFolder As Object
Dim folderName As String
Range("a2").Select
'Set the folder name to a variable
folderName = "<general_filepath_here\>"

'Set the reference to the FSO Library
Set FSOLibrary = CreateObject("Scripting.FileSystemObject")

'Another Macro must call LoopAllSubFolders Macro to start
LoopAllSubFolders FSOLibrary.GetFolder(folderName)

End Sub


Sub LoopAllSubFolders(FSOFolder As Object)

Dim FSOSubFolder As Object
Dim FSOFile As Object

'For each subfolder call the macro
For Each FSOSubFolder In FSOFolder.SubFolders
    LoopAllSubFolders FSOSubFolder
Next

'For each file, print the name
For Each FSOFile In FSOFolder.Files
If Right(FSOFile.Path, 7) = ".SLDDRW" Then

ActiveCell = FSOFile.Path
'ActiveCell.Offset(0, 3) = FSOFile.Name

CreateObject("Shell.Application").Open (FSOFile.Path)
Set swApp = CreateObject("SldWorks.Application")
swApp.Visible = True


DoEvents
Call CloseOtherWindows
Call PartNumbGrab

ActiveCell.Offset(0, 1) = PartNo
ActiveCell.Offset(0, 2) = PartName
ActiveCell.Offset(1, 0).Select

Debug.Print FSOFile.Path
End If

Next

End Sub

我的 CloseOtherWindow 宏

#If VBA7 Then
 Private Declare PtrSafe Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
#Else
 Private Declare Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
#End If

Dim swApp As SldWorks.SldWorks

Sub CloseOtherWindows()


Set swApp = CreateObject("SldWorks.Application")

Dim swModel As SldWorks.ModelDoc2

Set swModel = swApp.ActiveDoc

If Not swModel Is Nothing Then
    
    Dim vDocsWindows As Variant
    
    Dim swFrame As SldWorks.Frame
    Set swFrame = swApp.Frame
    
    vDocsWindows = swFrame.ModelWindows
    
    Dim i As Integer
    
    For i = 0 To UBound(vDocsWindows)
        
        Dim swDocWin As SldWorks.ModelWindow
        Set swDocWin = vDocsWindows(i)
        
        Dim swRefDoc As SldWorks.ModelDoc2
        Set swRefDoc = swDocWin.ModelDoc
        
        If Not swRefDoc Is swModel Then
            If swRefDoc.GetSaveFlag() Then
                'display the close confirmation dialog for unsaved files
                swApp.ActivateDoc3 swRefDoc.GetTitle, False, swRebuildOnActivation_e.swDontRebuildActiveDoc, 0
                Const WM_COMMAND As Long = &H111
                Const CMD_FileClose As Long = 57602
                SendMessage swFrame.GetHWnd(), WM_COMMAND, CMD_FileClose, 0
            Else
                swApp.CloseDoc swDocWin.ModelDoc.GetTitle
            End If
            
        End If
    Next
    
    swApp.ActivateDoc3 swModel.GetTitle, True, swRebuildOnActivation_e.swUserDecision, 0
    
End If

End Sub

我的 PartNumbGrab 宏

Option Explicit

Dim swApp As SldWorks.SldWorks
Dim swModel As ModelDoc2
Dim swModelDocExt As ModelDocExtension
Dim swCustProp As CustomPropertyManager
Global PartNo As String
Global PartName As String
Dim val As String
Dim bool As Boolean
Sub PartNumbGrab()
Set swApp = CreateObject("SldWorks.Application")
Set swModel = swApp.ActiveDoc
Set swModelDocExt = swModel.Extension
' Get the custom property data
Set swCustProp = swModelDocExt.CustomPropertyManager("")
bool = swCustProp.Get4("PART_NUMBER", False, val, PartNo)
bool = swCustProp.Get4("PART_NAME", False, val, PartName)


End Sub

Answer 1

當指定進程的任何 windows 正在等待用戶輸入時， WaitForInputIdle返回。 請參閱https://docs.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-waitforinputidle

    Public Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Boolean, ByVal processId As Long) As Long
    Public Declare Function WaitForInputIdle Lib "user32" (ByVal hProcess As Long, ByVal dwMilliseconds As Long) As Long

    Public Const AllAccess = &H1F0FFF
    Public Const Terminate = &H1
    Public Const CreateThread = &H2
    Public Const VirtualMemoryOperation = &H8
    Public Const VirtualMemoryRead = &H10
    Public Const VirtualMemoryWrite = &H20
    Public Const DuplicateHandle = &H40
    Public Const CreateProcess = &H80
    Public Const SetQuota = &H100
    Public Const SetInformation = &H200
    Public Const QueryInformation = &H400
    Public Const QueryLimitedInformation = &H1000
    Public Const Synchronize = &H100000

    Public Const WAIT_TIMEOUT = 258 
    Public Const WAIT_Failed = -1 

Sub Main
        hProcess = OpenProcess(QueryInformation, False, ProcessIDOfSolidWorks)
        Ret = WaitForInputIdle(hProcess, TimeoutMilliSec)
End Sub

改編自這里https://winsourcecode.blogspot.com/2021/04/waitforinputidleexe-starts-graphical.html