我有一些宏,我希望它运行一些代码,然后提示用户从另一个程序导出Excel工作簿,然后在打开导出后运行更多代码。棘手的部分是某些程序导出到新的Excel实例,而其他程序导出到当前实例。
目前的工作流程是(底层代码):
使用导出名称调用中央“捕获”模块(有些 程序导出'书[x]'有些做'工作簿[x]'等)和 找到导出后要运行的过程。
Capture Module获取所有现有工作簿名称的列表 Excel实例并另存为模块级字符串。
Capture Module使用Application.OnTime使其每隔3秒就可以了 扫描所有Excel实例中的所有工作簿列表。
如果找到的工作簿不在之前保存的列表中 所有现有工作簿名称,并包含该名称 export,它将该工作簿存储为公共模块级变量, 并运行步骤1中保存的过程,可以参考 商店工作簿。
这适用于所有情况, EXCEPT 。如果我已经在我当前的Excel实例中打开了Book1.xlsx,并且第三方程序将Book1.xlsx导出到Excel的新实例,则程序不会将此识别为导出,因为Book1.xlsx位于现有的工作簿名称字符串数组已经。
我的解决方案是找到一种唯一识别每个工作簿的方法,这些工作簿优于“名称”或“路径”。我尝试将现有工作簿名称字符串中的每个工作簿名称保存为[application.hwnd]![工作簿名称],但这是一个不稳定的修复程序并经常破坏(我真的不明白hwnd如何工作所以我不能说为什么)
有什么想法吗?谢谢!
使用MCaptureExport的示例程序
Public Sub GrabFXAllExport()
Const sSOURCE As String = "GrabFXAllExport"
On Error GoTo ErrorHandler
If Not TAAA.MCaptureExport.bCaptureExport("FXALL", "TAAA.FXAllEmail.ProcessFXAllExport") Then Err.Raise glHANDLED_ERROR
ErrorExit:
Exit Sub
ErrorHandler:
If bCentralErrorHandler(msMODULE, sSOURCE, , True) Then
Stop
Resume
Else
Resume ErrorExit
End If
End Sub
Public Sub ProcessFXAllExport()
Const sSOURCE As String = "ProcessFXAllExport"
On Error GoTo ErrorHandler
If MCaptureExport.mwbCaptured Is Nothing Then
MsgBox "Exported Workbook Not Found. Please try again.", vbCritical, gsAPP_NAME
GoTo ErrorExit
End If
Dim wsSourceSheet As Worksheet
Set wsSourceSheet = MCaptureExport.mwbCaptured.Worksheets(1)
Set MCaptureExport.mwbCaptured = Nothing
[I now have the export and can work with it as a I please]
ErrorExit:
Exit Sub
ErrorHandler:
If bCentralErrorHandler(msMODULE, sSOURCE, , True) Then
Stop
Resume
Else
Resume ErrorExit
End If
End Sub
MCaptureExport模块
Option Explicit
Option Base 1
' Description: This module contains the central error
' handler and related constant declarations.
Private Const msMODULE As String = "MCaptureExport"
Private sExistingWorkbookList() As String
Public mwbCaptured As Workbook
Public msCaptureType As String
Private sReturnProcedure As String
Private bListening As Boolean
Public Function bCaptureExport(sCaptureType As String, sRunAfterCapture As String) As Boolean
Dim bReturn As Boolean
Const sSOURCE As String = "bCaptureExport()"
On Error GoTo ErrorHandler
bReturn = True
If Not bWorkbookNamesAsArray(sExistingWorkbookList, True, False) Then Err.Raise glHANDLED_ERROR
sReturnProcedure = sRunAfterCapture
bListening = True
msCaptureType = sCaptureType
TAAA.MCaptureExport.WaitForCapture sCaptureTypeToNameContains(msCaptureType)
MsgBox "Waiting for " & msCaptureType & " Export", vbInformation, gsAPP_NAME
ErrorExit:
bCaptureExport = bReturn
Exit Function
ErrorHandler:
bReturn = False
If bCentralErrorHandler(msMODULE, sSOURCE) Then
Stop
Resume
Else
Resume ErrorExit
End If
End Function
Private Sub WaitForCapture(sNameContains As String)
Const sSOURCE As String = "WaitForCapture"
On Error GoTo ErrorHandler
Dim wbCaptureCheck As Workbook
If Not bCaptureCheck(sNameContains, wbCaptureCheck) Then Err.Raise glHANDLED_ERROR
If wbCaptureCheck Is Nothing Then
If bListening Then _
Application.OnTime Now + TimeSerial(0, 0, 3), "'TAAA.MCaptureExport.WaitForCapture " & Chr(34) & sNameContains & Chr(34) & "'"
Else
Dim bSameApp As Boolean
If Not bWorkbooksInSameApp(ThisWorkbook, wbCaptureCheck, bSameApp) Then Err.Raise glHANDLED_ERROR
If Not bSameApp Then
Dim sTempFilePath As String
sTempFilePath = ThisWorkbook.Path & "\temp_" & Format(Now, "mmddyyhhmmss") & ".xls"
wbCaptureCheck.SaveCopyAs sTempFilePath
wbCaptureCheck.Close SaveChanges:=False
Set wbCaptureCheck = Application.Workbooks.Open(sTempFilePath)
End If
Set mwbCaptured = wbCaptureCheck
bListening = False
Application.Run sReturnProcedure
End If
ErrorExit:
Exit Sub
ErrorHandler:
If bCentralErrorHandler(msMODULE, sSOURCE, , True) Then
Stop
Resume
Else
Resume ErrorExit
End If
End Sub
Private Function sCaptureTypeToNameContains(sCaptureType As String) As String
sCaptureTypeToNameContains = "*"
On Error Resume Next
Select Case UCase(sCaptureType)
Case "SOTER": sCaptureTypeToNameContains = "workbook"
Case "THOR": sCaptureTypeToNameContains = "Book"
Case "FXALL": sCaptureTypeToNameContains = "search_results_export"
End Select
End Function
Private Function bCaptureCheck(sNameContains As String, wbResult As Workbook) As Boolean
Dim bReturn As Boolean
Const sSOURCE As String = "bCaptureCheck()"
On Error GoTo ErrorHandler
bReturn = True
Dim i As Long, wb As Workbook
Dim xlApps() As Application
If Not bGetAllExcelInstances(xlApps) Then Err.Raise glHANDLED_ERROR
For i = LBound(xlApps) To UBound(xlApps)
For Each wb In xlApps(i).Workbooks
If wb.Name Like "*" & sNameContains & "*" _
And Not bIsInArray(wb.Name, sExistingWorkbookList) Then
Set wbResult = wb
GoTo ErrorExit
End If
Next
Next
ErrorExit:
bCaptureCheck = bReturn
Exit Function
ErrorHandler:
bReturn = False
If bCentralErrorHandler(msMODULE, sSOURCE) Then
Stop
Resume
Else
Resume ErrorExit
End If
End Function
MCaptureExport使用的实用程序函数
Public Function bWorkbookNamesAsArray(sResult() As String, Optional bAllInstances As Boolean = True) As Boolean
Dim bReturn As Boolean
Const sSOURCE As String = "bWorkbookNamesAsArray()"
On Error GoTo ErrorHandler
bReturn = True
Dim i As Long, wb As Workbook
Dim xlApps() As Application
Dim ResultArray() As String
Dim Ndx As Integer, wbCount As Integer
If bAllInstances Then
If Not bGetAllExcelInstances(xlApps) Then Err.Raise glHANDLED_ERROR
Else
ReDim xlApps(0)
Set xlApps(0) = Application
End If
For i = LBound(xlApps) To UBound(xlApps)
For Each wb In xlApps(i).Workbooks
wbCount = wbCount + 1
Next
Next
ReDim ResultArray(1 To wbCount)
For i = LBound(xlApps) To UBound(xlApps)
For Each wb In xlApps(i).Workbooks
Ndx = Ndx + 1
ResultArray(Ndx) = wb.Name
Next
Next
sResult = ResultArray()
ErrorExit:
bWorkbookNamesAsArray = bReturn
Exit Function
ErrorHandler:
bReturn = False
If bCentralErrorHandler(msMODULE, sSOURCE) Then
Stop
Resume
Else
Resume ErrorExit
End If
End Function
Public Function bGetAllExcelInstances(xlApps() As Application) As Boolean
Dim bReturn As Boolean
Const sSOURCE As String = "bGetAllExcelInstances()"
On Error GoTo ErrorHandler
bReturn = True
Dim n As Long
Dim hWndMain As LongPtr
Dim app As Application
' Cater for 100 potential Excel instances, clearly could be better
ReDim xlApps(1 To 100)
hWndMain = FindWindowEx(0&, 0&, "XLMAIN", vbNullString)
Do While hWndMain <> 0
If Not bGetExcelObjectFromHwnd(hWndMain, app) Then Err.Raise glHANDLED_ERROR
If Not (app Is Nothing) Then
If n = 0 Then
n = n + 1
Set xlApps(n) = app
ElseIf bCheckHwnds(xlApps, app.Hwnd) Then
n = n + 1
Set xlApps(n) = app
End If
End If
hWndMain = FindWindowEx(0&, hWndMain, "XLMAIN", vbNullString)
Loop
If n Then
ReDim Preserve xlApps(1 To n)
'GetAllExcelInstances = n
Else
Erase xlApps
End If
ErrorExit:
bGetAllExcelInstances = bReturn
Exit Function
ErrorHandler:
bReturn = False
If bCentralErrorHandler(msMODULE, sSOURCE) Then
Stop
Resume
Else
Resume ErrorExit
End If
End Function
Private Function bCheckHwnds(xlApps() As Application, Hwnd As LongPtr) As Boolean
On Error Resume Next
Dim i As Integer
For i = LBound(xlApps) To UBound(xlApps)
If Not xlApps(i) Is Nothing Then
If xlApps(i).Hwnd = Hwnd Then
bCheckHwnds = False
Exit Function
End If
End If
Next i
bCheckHwnds = True
End Function
Public Function bWorkbooksInSameApp(wb1 As Workbook, wb2 As Workbook, bSameApp As Boolean) As Boolean
Dim bReturn As Boolean
Const sSOURCE As String = "bWorkbooksInSameApp()"
On Error GoTo ErrorHandler
bReturn = True
bSameApp = wb1.Application.Hwnd = wb2.Application.Hwnd
ErrorExit:
bWorkbooksInSameApp = bReturn
Exit Function
ErrorHandler:
bReturn = False
If bCentralErrorHandler(msMODULE, sSOURCE) Then
Stop
Resume
Else
Resume ErrorExit
End If
End Function
Private Function bGetExcelObjectFromHwnd(ByVal hWndMain As LongPtr, aAppResult As Application) As Boolean
Dim bReturn As Boolean
Const sSOURCE As String = "bGetExcelObjectFromHwnd()"
On Error GoTo ErrorHandler
bReturn = True
Dim hWndDesk As LongPtr
Dim Hwnd As LongPtr
Dim strText As String
Dim lngRet As Long
Dim iid As UUID
Dim obj As Object
hWndDesk = FindWindowEx(hWndMain, 0&, "XLDESK", vbNullString)
If hWndDesk <> 0 Then
Hwnd = FindWindowEx(hWndDesk, 0, vbNullString, vbNullString)
Do While Hwnd <> 0
strText = String$(100, Chr$(0))
lngRet = CLng(GetClassName(Hwnd, strText, 100))
If Left$(strText, lngRet) = "EXCEL7" Then
Call IIDFromString(StrPtr(IID_IDispatch), iid)
If AccessibleObjectFromWindow(Hwnd, OBJID_NATIVEOM, iid, obj) = 0 Then 'S_OK
Set aAppResult = obj.Application
GoTo ErrorExit
End If
End If
Hwnd = FindWindowEx(hWndDesk, Hwnd, vbNullString, vbNullString)
Loop
End If
ErrorExit:
bGetExcelObjectFromHwnd = bReturn
Exit Function
ErrorHandler:
MsgBox Err.Number
bReturn = False
If bCentralErrorHandler(msMODULE, sSOURCE) Then
Stop
Resume
Else
Resume ErrorExit
End If
End Function
答案 0 :(得分:1)
我有一个潜在的解决方案。但是我想把这个问题保持开放。这是一个相当复杂的问题,我敢打赌,有比我提出的更优雅的解决方案。
所以我将sExistingWorkbookList的格式更新为[Application.hWnd]![Workbook.name]。我之前尝试过这个,但我觉得这次工作正常。
思想?
更新版本的bWorkbookNamesAsArray
将wb.Application.Hwnd & "!" &
添加到ResultArray(Ndx) = wb.name
Public Function bWorkbookNamesAsArray(sResult() As String, Optional bAllInstances As Boolean = True) As Boolean
Dim bReturn As Boolean
Const sSOURCE As String = "bWorkbookNamesAsArray()"
On Error GoTo ErrorHandler
bReturn = True
Dim i As Long, wb As Workbook
Dim xlApps() As Application
Dim ResultArray() As String
Dim Ndx As Integer, wbCount As Integer
If bAllInstances Then
If Not bGetAllExcelInstances(xlApps) Then Err.Raise glHANDLED_ERROR
Else
ReDim xlApps(0)
Set xlApps(0) = Application
End If
For i = LBound(xlApps) To UBound(xlApps)
For Each wb In xlApps(i).Workbooks
wbCount = wbCount + 1
Next
Next
ReDim ResultArray(1 To wbCount)
For i = LBound(xlApps) To UBound(xlApps)
For Each wb In xlApps(i).Workbooks
Ndx = Ndx + 1
ResultArray(Ndx) = wb.Application.Hwnd & "!" & wb.Name
Next
Next
sResult = ResultArray()
ErrorExit:
bWorkbookNamesAsArray = bReturn
Exit Function
ErrorHandler:
bReturn = False
If bCentralErrorHandler(msMODULE, sSOURCE) Then
Stop
Resume
Else
Resume ErrorExit
End If
End Function
新效用函数
Public Function bGetWorkbookFromHwndAndName(ByVal sWorkbookReference As String, ByRef wbResult As Workbook)
Dim bReturn As Boolean
Const sSOURCE As String = "bGetWorkbookFromHwndAndName()"
On Error GoTo ErrorHandler
bReturn = True
Dim xlApp As Application
If Not bGetExcelObjectFromHwnd(CLng(Split(sWorkbookReference, "!")(0)), xlApp) Then Err.Raise glHANDLED_ERROR
Set wbResult = xlApp.Workbooks(Split(sWorkbookReference, "!")(1))
ErrorExit:
bGetWorkbookFromHwndAndName = bReturn
Exit Function
ErrorHandler:
bReturn = False
If bCentralErrorHandler(msMODULE, sSOURCE) Then
Stop
Resume
Else
Resume ErrorExit
End If
End Function
更新了MCaptureExport.bCaptureCheck()
Private Function bCaptureCheck(sNameContains As String, wbResult As Workbook) As Boolean
Dim bReturn As Boolean
Const sSOURCE As String = "bCaptureCheck()"
On Error GoTo ErrorHandler
bReturn = True
Dim i As Long, wb As Workbook, sFullWorkbookReference As String
Dim xlApps() As Application
If Not bGetAllExcelInstances(xlApps) Then Err.Raise glHANDLED_ERROR
For i = LBound(xlApps) To UBound(xlApps)
For Each wb In xlApps(i).Workbooks
sFullWorkbookReference = wb.Application.Hwnd & "!" & wb.Name
If wb.Name Like "*" & sNameContains & "*" _
And Not bIsInArray(sFullWorkbookReference, sExistingWorkbookList) Then
If Not bGetWorkbookFromHwndAndName(sFullWorkbookReference, wbResult) Then Err.Raise glHANDLED_ERROR
GoTo ErrorExit
End If
Next
Next
ErrorExit:
bCaptureCheck = bReturn
Exit Function
ErrorHandler:
bReturn = False
If bCentralErrorHandler(msMODULE, sSOURCE) Then
Stop
Resume
Else
Resume ErrorExit
End If
End Function