Excel实例之间的参考工作簿

时间：2014-07-04 07:51:07

标签： excel vba internet-explorer excel-vba

长时间用户，第一个问题。

因此，我的企业用来获取煤炭运输信息的互联网网站最近已被重新设计，因此我必须重新修改我的计划以刮取船舶信息。我一直使用按钮点击事件导航到每个端口并使用; Dim Table As Object, Set Table = ie.document.getElementsByTagName("TABLE")(11) 得到实际的表。在新网站上，他们可以选择将所有船舶移动导出到excel，如果我可以自动化宏来获取excel文件，它会更快。澄清我只是想让我的程序去这个网站; https://qships.tmr.qld.gov.au/webx/，点击＆＃39;发货转移＆＃39;在顶部，点击工具＆＃39;，点击＆＃39;导出到excel＆＃39;然后打开文件并返回该站点，然后点击“出生时的船只”，“工具”，“出口到卓越”。并打开该文件，然后使用类似的东西;

Windows("Traffic.xls").Activate Application.ActiveProtectedViewWindow.Edit Sheets("Traffic").Select Application.DisplayAlerts = False Sheets("Traffic").Move After:=Workbooks("Search Ship Schedule.xlsm").Sheets(4) Application.DisplayAlerts = True

要将工作簿中的工作表返回到我的主工作簿，我将在那里搜索并获取我想要的工作簿。这就是我所熟悉的内容; 

Dim ws1, ws2 As Worksheet
Set ws1 = ActiveSheet
Set ws2 = ThisWorkbook.Sheets("Sheet1")
ws2.Cells.ClearContents


Dim Site, BtnPage(1 To 2), Btn As String
Site = "https://qships.tmr.qld.gov.au/webx/"
Dim ie As InternetExplorer

Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = True
ie.navigate Site

        Do While Not ie.readyState = 4 Or ie.Busy
            DoEvents
        Loop
        Application.Wait (Now() + TimeValue("0:00:3"))

ie.document.getElementById("Traffic").Click


        Do While Not ie.readyState = 4 Or ie.Busy
            DoEvents
        Loop
        Application.Wait (Now() + TimeValue("0:00:3"))

ie.document.getElementsByClassName("ui-widget fg-button fg-button-icon-left ui-corner-all grid-tools")(0).Click
Sleep 100
ie.document.getElementById("0").Click

        Do While Not ie.readyState = 4 Or ie.Busy
            DoEvents
        Loop

Sleep 2500

SendKeys "%o"

        Do While Not ie.readyState = 4 Or ie.Busy
            DoEvents
        Loop
Sleep 6500

'Sleep_DoEvents 7

ie.document.getElementById("InPort").Click


Do While Not ie.readyState = 4 Or ie.Busy
            DoEvents
        Loop
        Application.Wait (Now() + TimeValue("0:00:3"))

ie.document.getElementsByClassName("ui-widget fg-button fg-button-icon-left ui-corner-all grid-tools")(0).Click
Sleep 100
ie.document.getElementById("0").Click

        Do While Not ie.readyState = 4 Or ie.Busy
            DoEvents
        Loop

        'Windows("Traffic").Activate
        'Application.Windows("Traffic.xls").ActiveProtectedViewWindow.Edit
        'Application.Windows("Traffic.xls").Activate

        Static hWnds() As Variant
        Sleep 500
        r = FindWindowLike(hWnds(), 0, "Public Pages - Internet Explorer", "*", Null)

        Sleep 3000

        If r > 0 Then
            SetFocusAPI (hWnds(1))
            'Sleep 1000
            SendKeys "%o"
            Do While Not ie.readyState = 4 Or ie.Busy
                DoEvents
            Loop
            Sleep 6000
            'Application.ActiveProtectedViewWindow.Edit
        End If
'ie.Close

我在模块中有这个

Public Declare Function BlockInput Lib "USER32.dll" (ByVal fBlockIt As Long) As Long


#If VBA7 Then
    Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) 'For 64 Bit Systems
#Else
    Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'For 32 Bit Systems
#End If

 Declare Function SetFocusAPI Lib "User32" Alias "SetForegroundWindow" _
    (ByVal hWnd As Long) As Long
   Declare Function GetWindow Lib "User32" (ByVal hWnd As Long, _
    ByVal wCmd As Long) As Long
   Declare Function GetDesktopWindow Lib "User32" () As Long
   Declare Function GetWindowLW Lib "User32" Alias "GetWindowLongA" _
    (ByVal hWnd As Long, ByVal nIndex As Long) As Long
   Declare Function GetParent Lib "User32" (ByVal hWnd As Long) 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 GetWindowText Lib "User32" Alias "GetWindowTextA" _
    (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) _
     As Long

   Public Const GWL_ID = (-12)
   Public Const GW_HWNDNEXT = 2
   Public Const GW_CHILD = 5
   'FindWindowLike
   ' - Finds the window handles of the windows matching the specified
   '   parameters
   '
   'hwndArray()
   ' - An integer array used to return the window handles
   '
   'hWndStart
   ' - The handle of the window to search under.
   ' - The routine searches through all of this window's children and their
   '   children recursively.
   ' - If hWndStart = 0 then the routine searches through all windows.
   '
   'WindowText
   ' - The pattern used with the Like operator to compare window's text.
   '
   'ClassName
   ' - The pattern used with the Like operator to compare window's class
   '   name.
   '
   'ID
   ' - A child ID number used to identify a window.
   ' - Can be a decimal number or a hex string.
   ' - Prefix hex strings with "&H" or an error will occur.
   ' - To ignore the ID pass the Visual Basic Null function.
   '
   'Returns
   ' - The number of windows that matched the parameters.
   ' - Also returns the window handles in hWndArray()
   '
   '----------------------------------------------------------------------
   'Remove this next line to use the strong-typed declarations
   #Const WinVar = True
   #If WinVar Then
   Function FindWindowLike(hWndArray() As Variant, _
    ByVal hWndStart As Variant, WindowText As String, _
     Classname As String, ID) As Integer
   Dim hWnd
   Dim r
   Static level
   Static iFound
   #ElseIf Win32 Then
   Function FindWindowLike(hWndArray() As Long, ByVal hWndStart As Long, _
    WindowText As String, Classname As String, ID) As Long
   Dim hWnd As Long
   Dim r As Long
   ' Hold the level of recursion:
   Static level As Long
   ' Hold the number of matching windows:
   Static iFound As Long
   #ElseIf Win16 Then
   Function FindWindowLike(hWndArray() As Integer, _
    ByVal hWndStart As Integer, WindowText As String, _
    Classname As String, ID) As Integer
   Dim hWnd As Integer
   Dim r As Integer
   ' Hold the level of recursion:
   Static level As Integer
   'Hold the number of matching windows:
   Static iFound As Integer
   #End If
   Dim sWindowText As String
   Dim sClassname As String
   Dim sID
   ' Initialize if necessary:
   If level = 0 Then
   iFound = 0
   ReDim hWndArray(0 To 0)
   If hWndStart = 0 Then hWndStart = GetDesktopWindow()
   End If
   ' Increase recursion counter:
   level = level + 1
   ' Get first child window:
   hWnd = GetWindow(hWndStart, GW_CHILD)
   Do Until hWnd = 0
   DoEvents ' Not necessary
   ' Search children by recursion:
   r = FindWindowLike(hWndArray(), hWnd, WindowText, Classname, ID)
   ' Get the window text and class name:
   sWindowText = Space(255)
   r = GetWindowText(hWnd, sWindowText, 255)
   sWindowText = Left(sWindowText, r)
   sClassname = Space(255)
   r = GetClassName(hWnd, sClassname, 255)
   sClassname = Left(sClassname, r)
   ' If window is a child get the ID:
   If GetParent(hWnd) <> 0 Then
   r = GetWindowLW(hWnd, GWL_ID)
   sID = CLng("&H" & Hex(r))
   Else
   sID = Null
   End If
   ' Check that window matches the search parameters:
   If sWindowText Like WindowText And sClassname Like Classname Then
   If IsNull(ID) Then
   ' If find a match, increment counter and
   '  add handle to array:
   iFound = iFound + 1
   ReDim Preserve hWndArray(0 To iFound)
   hWndArray(iFound) = hWnd
   ElseIf Not IsNull(sID) Then
   If CLng(sID) = CLng(ID) Then
   ' If find a match increment counter and
   '  add handle to array:
   iFound = iFound + 1
   ReDim Preserve hWndArray(0 To iFound)
   hWndArray(iFound) = hWnd
   End If
   End If
   Debug.Print "Window Found: "
   Debug.Print "  Window Text  : " & sWindowText
   Debug.Print "  Window Class : " & sClassname
   Debug.Print "  Window Handle: " & CStr(hWnd)
   End If
   ' Get next child window:
   hWnd = GetWindow(hWnd, GW_HWNDNEXT)
   Loop
   ' Decrement recursion counter:
   level = level - 1
   ' Return the number of windows found:
   FindWindowLike = iFound
   End Function

我的问题是，当这些excel文件打开时，它们会在excel的新实例中打开，我无法以常规方式引用它们。由于它们实际上没有保存，我不能像在这个答案Can VBA Reach Across Instances of Excel?中推荐的那样使用GetObject（），并且我不知道如何使用句柄引用excel工作簿。我认为他们正在开启一个新的excel实例，因为宏正在运行，即使使用Sleep（），它也不会让excel打开新的工作簿。我尝试过使用Do DoWhile循环让excel打开工作簿，但这似乎不起作用。所以，如果有人可以帮我在同一个excel实例中打开工作簿，这样我就可以更容易地引用它们，或者在没有GetObject（）的excel实例之间引用，这将非常感激。

================================== EDIT ============ ===========================

这是我结束的最终结果。感谢user3565396，我刚刚将其保存在您推荐的下载文件夹中，我无法弄清楚如何使用像Robert Co推荐的WinHttp。出于某种原因，代码在wb2.Sheets(1).Copy After:=wb1.Sheets("Import")行上没有出现错误消息而退出，但重新打开似乎工作正常，并且它每天只使用一次或两次。

Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Integer

Function DelTrafficAndInPort()

'Clear all ws's like "Traffic" or "In Port" and all wb's

    'In VBE, click Tools, References, find "Microsoft Scripting Runtime"
    'and check it off for this program to work
    Dim fso As FileSystemObject
    Dim fold As Folder
    Dim f As File
    Dim folderPath As String
    Dim cbo As Object

    folderPath = "C:\Users\" & Environ("username") & "\Downloads"

    Set fso = New FileSystemObject
    Set fold = fso.GetFolder(folderPath)

    For Each f In fold.Files
        If ((Left(f.Name, 7) = "Traffic" Or Left(f.Name, 7) = "In Port") And Right(f.Name, 4) = ".xls") Then
            fso.DeleteFile f.Path
        End If
    Next
End Function



Sub BtnScrape_Click()

    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False


Dim wb1, wb2 As Workbook
    Set wb1 = ActiveWorkbook

    Run DelTrafficAndInPort() ' from downloads

    Dim ws As Worksheet
    Application.DisplayAlerts = False
    For Each ws In wb1.Worksheets
        If (Left(ws.Name, 7) = "Traffic" Or Left(ws.Name, 7) = "In Port") Then ws.Delete
    Next ws
    Application.DisplayAlerts = True

Dim ie As InternetExplorer 'SHDocVw.InternetExplorer
Dim sw As New SHDocVw.ShellWindows

Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = True
ie.navigate "https://qships.tmr.qld.gov.au/webx/"

Do While Not ie.readyState = 4 Or ie.Busy
DoEvents
Loop

Dim BtnName(1 To 2), wbPath(1 To 2) As String
    BtnName(1) = "Traffic"
    BtnName(2) = "InPort"
    wbPath(1) = "C:\Users\" & Environ("username") & "\Downloads\Traffic.xls" '"C:\Users\owner\Downloads\Traffic.xls"
    wbPath(2) = "C:\Users\" & Environ("username") & "\Downloads\In Port.xls"

Dim I As Integer
For I = 1 To 2
    ie.document.getElementById(BtnName(I)).Click

    Do While Not ie.readyState = 4 Or ie.Busy
    DoEvents
    Loop

    Application.Wait (Now() + TimeValue("00:00:04"))

    ie.document.getElementsByTagName("span")(8).Click 'Tools
    Application.Wait (Now() + TimeValue("00:00:01"))
    ie.document.getElementById("0").Click             'Export to Excel    'ie.document.getElementsByTagName("span")(27).Click
    Application.Wait (Now() + TimeValue("00:00:5"))

    SetForegroundWindow (ie.hwnd)
    Application.Wait (Now() + TimeValue("00:00:01"))
    SendKeys "%S" 'Save
    Application.Wait (Now() + TimeValue("00:00:02"))
    Set wb2 = Workbooks.Open(wbPath(I))
    wb2.Sheets(1).Copy After:=wb1.Sheets("Import")
    wb2.Close False
Next I
ie.Quit

wb1.Sheets("Import").Select

Run DelTrafficAndInPort() ' from downloads

    Application.ScreenUpdating = True
    Application.DisplayStatusBar = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True

MsgBox "Finished"
End Sub

2 个答案:

答案 0 :(得分：0)

这是解决方案。我跳过了你正确完成的一些步骤。代码从单击工具开始，然后单击导出到Excel。之后，我点击“Alt + S”即保存（未打开）。使用此代码，我设法将工作表从下载的文件复制到我运行VBA代码的工作簿。希望有所帮助。

P.S。所有文件必须位于同一目录中。

Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Integer

Dim ie As SHDocVw.InternetExplorer
Dim sw As New SHDocVw.ShellWindows
Sub test()
Dim hw As Long, rtrn As Integer
For Each ie In sw
    If ie.LocationURL = "https://qships.tmr.qld.gov.au/webx/" Then
        ie.Document.getElementsByTagName("span")(8).Click 'Tools
        ie.Document.getElementsByTagName("span")(27).Click 'Export to Excel
        Application.Wait (Now() + TimeValue("00:00:10"))
        Exit For
    End If
Next ie
hw = ie.hwnd
rtrn = SetForegroundWindow(hw)
Application.Wait (Now() + TimeValue("00:00:03"))
SendKeys "%S" 'Save
Application.Wait (Now() + TimeValue("00:00:03"))
Workbooks.Open ("Traffic.xls")
Dim sh As Worksheet, wb As Workbook
Set wb = Workbooks("TEST.xlsb") 'Target Workbook
For Each sh In Workbooks("Traffic.xls").Worksheets
    sh.Copy After:=wb.Sheets(wb.Sheets.Count)
Next sh
End Sub

答案 1 :(得分：-1)

单击某个链接时，会将其下载到浏览器临时文件夹，然后在另一个会话中使用推荐的应用程序将其打开。诀窍是在VBA中下载文件并在同一会话中打开它。如果网址是可预测的，那么你当然可以实现自动化。

使用WinHttp作为流下载并在您自己的临时文件夹中重新创建该文件。它大约有10行代码。使用Workbooks.Open继续VBA，在同一会话中打开文件。

相关问题
最新问题