Question

我有一个问题如何保存finded实例。例如，我从book1启动一个宏，我想将tracelog [1] .xls保存为另一个实例。

GetObject不起作用，因为我无法添加文件名的路径，因为它是临时的，它不会只在我的计算机上运行所以我需要灵活的东西。

'------------- Code Module --------------

Option Explicit

Declare Function FindWindowEx Lib "User32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Declare Function GetClassName Lib "User32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Declare Function IIDFromString Lib "ole32" (ByVal lpsz As Long, ByRef lpiid As UUID) As Long
Declare Function AccessibleObjectFromWindow Lib "oleacc" (ByVal hWnd As Long, ByVal dwId As Long, ByRef riid As UUID, ByRef ppvObject As Object) As Long

Type UUID 'GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(7) As Byte
End Type


Const IID_IDispatch As String = "{00020400-0000-0000-C000-000000000046}"
Const OBJID_NATIVEOM As Long = &HFFFFFFF0

'Sub GetAllWorkbookWindowNames()
Sub Command1_Click()
    On Error GoTo MyErrorHandler

    Dim hWndMain As Long
    hWndMain = FindWindowEx(0&, 0&, "XLMAIN", vbNullString)

    Do While hWndMain <> 0
        GetWbkWindows hWndMain
        hWndMain = FindWindowEx(0&, hWndMain, "XLMAIN", vbNullString)
    Loop

    Exit Sub

MyErrorHandler:
    MsgBox "GetAllWorkbookWindowNames" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Sub

Private Sub GetWbkWindows(ByVal hWndMain As Long)
    On Error GoTo MyErrorHandler

    Dim hWndDesk As Long
    hWndDesk = FindWindowEx(hWndMain, 0&, "XLDESK", vbNullString)

    If hWndDesk <> 0 Then
        Dim hWnd As Long
        hWnd = FindWindowEx(hWndDesk, 0, vbNullString, vbNullString)

        Dim strText As String
        Dim lngRet As Long
        Do While hWnd <> 0
            strText = String$(100, Chr$(0))
            lngRet = GetClassName(hWnd, strText, 100)

            If Left$(strText, lngRet) = "EXCEL7" Then
                GetExcelObjectFromHwnd hWnd
                Exit Sub
            End If

            hWnd = FindWindowEx(hWndDesk, hWnd, vbNullString, vbNullString)
            Loop

        On Error Resume Next
    End If

    Exit Sub

MyErrorHandler:
    MsgBox "GetWbkWindows" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Sub

Public Function GetExcelObjectFromHwnd(ByVal hWnd As Long) As Boolean
    On Error GoTo MyErrorHandler

    Dim xlApp As Excel.Application
    Dim xlWorkbook As Excel.Worksheet
    Dim fOk As Boolean
    fOk = False

    Dim iid As UUID
    Call IIDFromString(StrPtr(IID_IDispatch), iid)

    Dim obj As Object
    If AccessibleObjectFromWindow(hWnd, OBJID_NATIVEOM, iid, obj) = 0 Then 'S_OK
        Dim objApp As Excel.Application
        Set objApp = obj.Application
        Debug.Print objApp.Workbooks(1).name

        Dim myWorksheet As Worksheet
        For Each myWorksheet In objApp.Workbooks(1).Worksheets
            Debug.Print "     " & myWorksheet.name
            DoEvents
        Next
'~~> show names of open workbooks
MsgBox objApp.Workbooks(1).name
        fOk = True
    End If


'~~> i am trying something here...but no use
 If objApp.Workbooks(1).name = "TraceLog 1.xls" Then

 xlWorkbook = "TraceLog 1.xls"
 xlWorkbook.SaveAs Filename:="\\wegdafs6\Data2\BSC Projects\14.00 Shared\07_Automation_Project\01_Implementation\PRG\Automat_temp\TTWEB\test\trlog.xls", _
 FileFormat:=56
     End If


    GetExcelObjectFromHwnd = fOk

    Exit Function

MyErrorHandler:
    MsgBox "GetExcelObjectFromHwnd" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Function

Answer 1

您的代码总体上很好，我已经纠正了一些错误，并且可以正常运行：

予。

Dim xlWorkbook As Excel.Workbook

II。

Set xlWorkbook = objApp.Workbooks(1)

以下是全新的代码：

'------------- Code Module --------------

Option Explicit

Private Declare Function FindWindowEx Lib "User32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function GetClassName Lib "User32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function IIDFromString Lib "ole32" (ByVal lpsz As Long, ByRef lpiid As UUID) As Long
Private Declare Function AccessibleObjectFromWindow Lib "oleacc" (ByVal hWnd As Long, ByVal dwId As Long, ByRef riid As UUID, ByRef ppvObject As Object) As Long

Type UUID 'GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(7) As Byte
End Type


Const IID_IDispatch As String = "{00020400-0000-0000-C000-000000000046}"
Const OBJID_NATIVEOM As Long = &HFFFFFFF0

'Sub GetAllWorkbookWindowNames()
Sub cmdOndo_Click()
  On Error GoTo MyErrorHandler

  Dim hWndMain As Long
  hWndMain = FindWindowEx(0&, 0&, "XLMAIN", vbNullString)

  Do While hWndMain <> 0
    GetWbkWindows hWndMain
    hWndMain = FindWindowEx(0&, hWndMain, "XLMAIN", vbNullString)
  Loop

  Exit Sub

MyErrorHandler:
  MsgBox "GetAllWorkbookWindowNames" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Sub

Private Sub GetWbkWindows(ByVal hWndMain As Long)
  On Error GoTo MyErrorHandler

  Dim hWndDesk As Long
  hWndDesk = FindWindowEx(hWndMain, 0&, "XLDESK", vbNullString)

  If hWndDesk <> 0 Then
    Dim hWnd As Long
    hWnd = FindWindowEx(hWndDesk, 0, vbNullString, vbNullString)

    Dim strText As String
    Dim lngRet As Long
    Do While hWnd <> 0
      strText = String$(100, Chr$(0))
      lngRet = GetClassName(hWnd, strText, 100)

      If Left$(strText, lngRet) = "EXCEL7" Then
        GetExcelObjectFromHwnd hWnd
        Exit Sub
      End If

      hWnd = FindWindowEx(hWndDesk, hWnd, vbNullString, vbNullString)
      Loop

    On Error Resume Next
  End If

  Exit Sub

MyErrorHandler:
  MsgBox "GetWbkWindows" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Sub

Public Function GetExcelObjectFromHwnd(ByVal hWnd As Long) As Boolean
  On Error GoTo MyErrorHandler

  Dim xlApp As Excel.Application
  Dim xlWorkbook As Excel.Workbook
  Dim fOk As Boolean
  fOk = False

  Dim iid As UUID
  Call IIDFromString(StrPtr(IID_IDispatch), iid)

  Dim obj As Object
  If AccessibleObjectFromWindow(hWnd, OBJID_NATIVEOM, iid, obj) = 0 Then 'S_OK
    Dim objApp As Excel.Application
    Set objApp = obj.Application
    Debug.Print objApp.Workbooks(1).Name

    Dim myWorksheet As Worksheet
    For Each myWorksheet In objApp.Workbooks(1).Worksheets
      Debug.Print "   " & myWorksheet.Name
      DoEvents
    Next
'~~> show names of open workbooks
    MsgBox objApp.Workbooks(1).Name
    fOk = True
  End If


'~~> i am trying something here...but no use
  If objApp.Workbooks(1).Name = "TraceLog 1.xls" Then
     Set xlWorkbook = objApp.Workbooks(1)
     '
     xlWorkbook.SaveAs filename:="\\wegdafs6\Data2\BSC Projects\14.00 Shared\07_Automation_Project\01_Implementation\PRG\Automat_temp\TTWEB\test\trlog.xls", _
     FileFormat:=56
     '
   End If


  GetExcelObjectFromHwnd = fOk

 Exit Function

MyErrorHandler:
  MsgBox "GetExcelObjectFromHwnd" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Function

如何保存另一个excel实例

1 个答案: