Option Explicit
Private Declare Function SendInput _
Lib "user32.dll" _
(ByVal nInputs As Long, _
pInputs As GENERALINPUT, _
ByVal cbSize As Long) As Long
Private Declare Sub CopyMemory _
Lib "kernel32" _
Alias "RtlMoveMemory" _
(pDst As Any, _
pSrc As Any, _
ByVal ByteLen As Long)
Private Declare Function FindWindow _
Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function GetWindow _
Lib "user32.dll" _
(ByVal hwnd As Long, _
ByVal wCmd As Long) As Long
Private Declare Function GetWindowText _
Lib "user32" Alias "GetWindowTextA" _
(ByVal hwnd As Long, _
ByVal lpString As String, _
ByVal cch As Long) As Long
Private Declare Function GetWindowTextLength _
Lib "user32" Alias "GetWindowTextLengthA" _
(ByVal hwnd As Long) As Long
Private Type KEYBDINPUT
wVk As Integer
wScan As Integer
dwFlags As Long
time As Long
dwExtraInfo As Long
End Type
Private Type GENERALINPUT
dwType As Long
xi(0 To 23) As Byte
End Type
'virtual key codes are here: http://msdn.microsoft.com/library/d...en-us/wceddk/html/wceddkVirtual_Key_Codes.asp
'Nope, MSDN moved it and I can't find it... here is another place to get them: http://www.math.msu.su/~vfnik/WinApi/other/virtualkeycodes.html
'remember that these are Hexadecimal values...
Private Const VK_A = &H41 'A key
Private Const VK_F = &H46 'F key
Private Const VK_Y = &H59 'Y key
Private Const VK_MENU = &H12 'ALT key
Private Const VK_RETURN = &HD 'enter
Private Const VK_SHIFT = &H10 'shift
Private Const VK_HOME = &H24 'home
'constants for SendKey
Private Const KEYEVENTF_KEYUP = &H2
Private Const INPUT_KEYBOARD = 1
'constants for Get_Window_Handle
Private Const GW_HWNDFIRST = 0 ' Get first Window handle
Private Const GW_HWNDLAST = 1
Private Const GW_HWNDNEXT = 2 ' Get next window handle
Private Const GW_HWNDPREV = 3
Private Const GW_OWNER = 4
Private Const GW_CHILD = 5
Sub Login_Proc(mIE_Obj As InternetExplorer)
'place your login code here
End Sub
Sub Reset_SatausBar()
Application.StatusBar = False
End Sub
Sub Send_String(Sent_Str As String)
Const VK_SPACE = &H20
Const VK_0 = &H30
Const VK_1 = &H31
Const VK_2 = &H32
Const VK_3 = &H33
Const VK_4 = &H34
Const VK_5 = &H35
Const VK_6 = &H36
Const VK_7 = &H37
Const VK_8 = &H38
Const VK_9 = &H39
Const VK_OEM_PLUS = &HBB
Const VK_OEM_COMMA = &HBC
Const VK_OEM_MINUS = &HBD
Const VK_OEM_PERIOD = &HBE
Const VK_OEM_1 = &HBA
Const VK_OEM_2 = &HBF
Const VK_OEM_3 = &HC0
Const VK_OEM_4 = &HDB
Const VK_OEM_5 = &HDC
Const VK_OEM_6 = &HDD
Const VK_OEM_7 = &HDE
Dim cnt As Long
Dim vlue
Dim Chrctr As String
For cnt = 1 To Len(Sent_Str)
Chrctr = Mid(Sent_Str, cnt, 1)
vlue = Asc(Chrctr)
If (vlue >= 65 And vlue <= 90) Then
SendKey CByte(vlue), True
ElseIf (vlue >= 48 And vlue <= 57) Then
SendKey CByte(vlue)
ElseIf vlue >= 97 And vlue <= 122 Then
SendKey CByte(vlue - 32)
Else
Select Case Chrctr
Case " "
SendKey VK_SPACE
Case Chr(34) ' double quote
SendKey VK_OEM_7, True
Case "#"
SendKey VK_3, True
Case "$"
SendKey VK_4, True
Case "%"
SendKey VK_5, True
Case "&"
SendKey VK_7, True
Case Chr(39) ' single quote
SendKey VK_OEM_7
Case "("
SendKey VK_9, True
Case ")"
SendKey VK_0, True
Case "*"
SendKey VK_8, True
Case "+"
SendKey VK_OEM_PLUS, True
Case ","
SendKey VK_OEM_COMMA
Case "-"
SendKey VK_OEM_MINUS
Case "."
SendKey VK_OEM_PERIOD
Case "/"
SendKey VK_OEM_2
Case ":"
SendKey VK_OEM_1, True
Case ";"
SendKey VK_OEM_1
Case "<"
SendKey VK_OEM_COMMA, True
Case "="
SendKey VK_OEM_PLUS
Case ">"
SendKey VK_OEM_PERIOD, True
Case "?"
SendKey VK_OEM_2, True
Case "@"
SendKey VK_2, True
Case "["
SendKey VK_OEM_4
Case "\"
SendKey VK_OEM_5
Case "]"
SendKey VK_OEM_6
Case "^"
SendKey VK_6, True
Case "_"
SendKey VK_OEM_MINUS, True
Case Chr(96) ' accent mark
SendKey VK_OEM_3
Case "{"
SendKey VK_OEM_4, True
Case "|"
SendKey VK_OEM_5, True
Case "}"
SendKey VK_OEM_6, True
Case "~"
SendKey VK_OEM_3, True
End Select
End If
Next cnt
End Sub
Sub Save_Web_Page()
'Tools->References:
'Microsoft HTML Object Library
'Microsoft internet Controls
'I figure if the Website hasn't loaded in 4 minutes, you may want to poke at the user...
Const Too_Long As Long = 240
Const Web_Page As String = "http://www.mrexcel.com"
Dim Destination_Path As String
Dim Destination_File As String
Dim Handle As Long
Dim Wnr As Long
Dim Chld As Long
Dim mIE As InternetExplorer
Dim MB As VbMsgBoxResult
Dim tmr As Double
Dim Ttle As String
Dim Flag As Boolean
Dim IE_Handle As Long
On Error GoTo err_handler
'tell th euser what we are doing, and to behave himself
Application.StatusBar = "Opening Web Page (don't touch that keyboard)"
'set the destination to the Desktop
'We could actually send this anywhere, but IE treats the Desktop differently than any other folder in the
'system, and actually creates a sub-folder to hold all of the back-up data for the web page to display properly
Destination_Path = Environ("USERPROFILE") & "\Desktop\"
'this will error unless you have included the proper libraries (see header)
Set mIE = New InternetExplorer
tmr = Timer
mIE.Visible = True 'Must be True for SendKey to work
'go to the specified page
mIE.navigate Web_Page
'wait until the page has actually finished loading before we try to perform any manipulations
Do Until mIE.readyState = READYSTATE_COMPLETE
If Timer - tmr > Too_Long Then
Err.Raise 6969
End If
Loop
'get the website title
Ttle = mIE.document.Title
'build the file_path where the file will get saved... in my example, the period in Mr Excel
'gets transformed to an underscore... so I plopped that in here so it would work.
'it's okay to leave this in, even if you don't have a period in your web address...
'but if the proc is not detecting that the file exists, look for a transform of illegal characters (", ?, /, \, etc)
'and I would advise performing the proper substitution here... I didn't test them all to see if they all get handled
Destination_File = Destination_Path & Replace(Ttle, ".", "_") & ".htm"
'determine if the file exists, if it does, set the flag, so we can automatically over-write it later
If Dir(Destination_File) <> "" Then
Flag = True
End If
'call the login proc... if code is ported, and login is not required, then comment out or delete this line
Call Login_Proc(mIE)
'ONCE WE START SENDING KEY STROKES YOU ABSOLUTELY CANNOT STEP THROUGH THE CODE...
'in fact, if you've stepped up to THIS POINT, IE is no longer the top window, and you'll have a problem.
'open the Save As dialog
SendKey VK_MENU
SendKey VK_F
SendKey VK_A
'get the Window Handle of the Save As Dialog Box
Do
Handle = Get_Window_Handle("Save Web Page")
Loop Until Handle <> 0
'move to Home position in the file/path field
SendKey VK_HOME
'enter the pathname
Send_String Destination_Path
'press the enter key
SendKey VK_RETURN
'if the file exists, then hit "Y" to overwrite it.
'though it's possible that you want to handle this case differently...
If Flag Then
'loop until the dialog comes up asking if we want to overwrite the file
Do
Chld = GetWindow(Handle, GW_CHILD)
Loop Until Chld <> 0
'send the Y key
SendKey VK_Y
'loop until that dialog disappears
Do
Wnr = GetWindow(Chld, GW_HWNDNEXT)
Loop Until Wnr = 0
Chld = 0
End If
'get the handle of the Child window (you know the one, it pops up for an instant showing
'files moving from the Internet to your computer... don't blink or you'll miss it
Do
Chld = GetWindow(Handle, GW_CHILD)
Loop Until Chld <> 0
'keep looping until that child window is GONE, indicating that the save is complete
Do
Wnr = GetWindow(Chld, GW_HWNDNEXT)
Loop Until Wnr = 0
'*********************
'at this point, I believe that the files have been placed in OLK3D (temp folder)
'although the files are now saved to the local drive, they are not yet in their final destination
'either that, or there is still some other cleanup work that IE must do before the Save action is finally done
'***********************
'get the Handle of the IE Window
IE_Handle = mIE.hwnd
'we can't actually close (quit) IE until all of the activities associeted with the Save are completed
'we will take advantage of the fact that the Quit command is ignored by the IE window until all activities are completed
'keep sending the Quit command to the IE window until the window actually disappears
Do
'quit IE
mIE.Quit
'try to get a handle based on the IE handle
Wnr = GetWindow(IE_Handle, GW_HWNDNEXT)
Loop Until Wnr = 0
'report to the user that the actionis complete
Application.StatusBar = "Save Completed Successfully"
'release the MIE object
Set mIE = Nothing
'reset the statusbar in 5 seconds
Application.OnTime Now() + 5 / 24 / 3600, "Reset_SatausBar"
Exit Sub
err_handler:
If Err.Number = 6969 Then
MB = MsgBox("This is taking too long... would you like to continue this manually?", vbYesNoCancel, "What Now?")
If MB = vbNo Then
tmr = Timer
Resume Next
End If
Else
MsgBox "Error " & Err.Number & " encountered." & vbCrLf & "Please report problem to software admin", vbCritical, "Exitting"
End If
Application.StatusBar = "Save Could Not Be Completed Successfully"
Set mIE = Nothing
'reset the statusbar in 5 seconds
Application.OnTime Now() + 5 / 24 / 3600, "Reset_SatausBar"
End Sub
Private Sub SendKey(bKey As Byte, Optional shft As Boolean)
'this code comes from here: http://www.allapi.net/apilist/SendInput.shtml
'Huh, this site seems to have been hijacked by a Bot... don't know
'if there is a mirror somewhere.
'Note that this can be used to insert Mouse events and Hardware events into
'data stream also, but I lobotomized it, since the code seemed incomplete,
'and we didn't need that functionality anyway
'also added the ability to hold the Shift Key, to get CAPS and secondary characters
Dim GInput() As GENERALINPUT
Dim KInput As KEYBDINPUT
If Not shft Then
'resize the array for a single keypress
ReDim GInput(0 To 1)
KInput.wVk = bKey 'the key we're going to press
KInput.dwFlags = 0 'press the key
'copy the structure into the input array's buffer.
GInput(0).dwType = INPUT_KEYBOARD ' keyboard input
CopyMemory GInput(0).xi(0), KInput, Len(KInput)
'do the same as above, but for releasing the key
KInput.wVk = bKey ' the key we're going to realease
KInput.dwFlags = KEYEVENTF_KEYUP ' release the key
GInput(1).dwType = INPUT_KEYBOARD ' keyboard input
CopyMemory GInput(1).xi(0), KInput, Len(KInput)
'send the input now
Call SendInput(2, GInput(0), Len(GInput(0)))
Else
'resize the array to hold 2 keypresses
ReDim GInput(0 To 3)
KInput.wVk = VK_SHIFT 'Shift Key
KInput.dwFlags = 0 'press the key
'copy the structure into the input array's buffer.
GInput(0).dwType = INPUT_KEYBOARD ' keyboard input
CopyMemory GInput(0).xi(0), KInput, Len(KInput)
KInput.wVk = bKey 'the key we're going to press
KInput.dwFlags = 0 'press the key
'copy the structure into the input array's buffer.
GInput(1).dwType = INPUT_KEYBOARD ' keyboard input
CopyMemory GInput(1).xi(0), KInput, Len(KInput)
'do the same as above, but for releasing the key we pressed
KInput.wVk = bKey ' the key we're going to realease
KInput.dwFlags = KEYEVENTF_KEYUP ' release the key
'copy the structure into the input array's buffer.
GInput(2).dwType = INPUT_KEYBOARD ' keyboard input
CopyMemory GInput(2).xi(0), KInput, Len(KInput)
'do the same as above, but for releasing the SHIFT key
KInput.wVk = VK_SHIFT 'Shift Key
KInput.dwFlags = KEYEVENTF_KEYUP ' release the key
'copy the structure into the input array's buffer.
GInput(3).dwType = INPUT_KEYBOARD ' keyboard input
CopyMemory GInput(3).xi(0), KInput, Len(KInput)
'send the input now
Call SendInput(4, GInput(0), Len(GInput(0)))
End If
End Sub
Private Function Get_Window_Handle(winTEXT As String)
Dim hwnd As Long
Dim hwndTask As Long
Dim sClass As String
Dim ThisWindowText As String
'get any old window from the system...
hwnd = FindWindow(vbNullString, vbNullString)
'using a good handle, get the handle of the very first window in the zOrder of the system
hwndTask = GetWindow(hwnd, GW_HWNDFIRST)
'keep getting new window handles until there are no more
Do While hwndTask
'create a null-terminated string to hold the name of the current window handle
ThisWindowText = String(GetWindowTextLength(hwndTask) + 1, Chr$(0))
'get the name of the current window handle
GetWindowText hwndTask, ThisWindowText, Len(ThisWindowText)
'see if this name contains the text we are lookng for
If InStr(1, ThisWindowText, winTEXT, vbTextCompare) > 0 Then
'if the name of the current window contians the text we are looking
'for, then assign this window handle to our function, and 22-skidoo
Get_Window_Handle = hwndTask
Exit Do
End If
'grab the handle of the next window of the zOrder of the system
hwndTask = GetWindow(hwndTask, GW_HWNDNEXT)
Loop
End Function
