I have a VBA that will set the zoom level based on the screen resolution.
But its working only for ActiveWindow when you open workbook.
How can I add this across all worksheets in Excel?
Declare Function GetSystemMetrics32 Lib "user32" _
Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long
Public Sub ScreenRes()
Dim lResWidth As Long
Dim lResHeight As Long
Dim sRes As String
lResWidth = GetSystemMetrics32(0)
lResHeight = GetSystemMetrics32(1)
sRes = lResWidth & "x" & lResHeight
Select Case sRes
Case Is = "800x600"
ActiveWindow.Zoom = 75
Case Is = "1024x768"
ActiveWindow.Zoom = 125
Case Else
ActiveWindow.Zoom = 100
End Select
End Sub
I will call this module on the Workbook
Private Sub Workbook_Open()
ScreenRes
End Sub
Select all of the Worksheet Objects using the Worksheets collection and the Application.ActiveWindow property will point to them all.
With Worksheets
.Select
ActiveWindow.Zoom = 75
End With
building on #Jeeped answer you could place in ThisWorkbook code pane the following code:
Declare Function GetSystemMetrics32 Lib "user32" _
Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long
Option Explicit
Private Sub Workbook_Open()
With Worksheets
.Select
ActiveWindow.zoom = ScreenResToZoom
End With
End Sub
Public Function ScreenResToZoom() As Long
Select Case GetSystemMetrics32(0) & "x" & GetSystemMetrics32(1)
Case Is = "800x600"
ScreenResToZoom = 75
Case Is = "1024x768"
ScreenResToZoom = 125
Case Else
ScreenResToZoom = 100
End Select
End Function
Related
I found a code to perform a Prnt Screen without using Sendkeys method:
Option Explicit
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal _
bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Const VK_SNAPSHOT = &H2C
Sub PrintScreen()
keybd_event VK_SNAPSHOT, 1, 0, 0
End Sub
I haven't tried yet if it works properly (if not, I will use Sendkeys), but I'm wondering if there's a way to Prnt Screen and save it as .pdf/.jpg (doesn't matter) into a specific folder. All the print screen are about Internet Explorer pages.
The code you have only simulates "pressing" the PrtScrn key, but not "releasing" it. Add the second line here like this:
Option Explicit
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal _
bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Const VK_SNAPSHOT = &H2C
Private Const KEYEVENTF_KEYUP = 2
Sub PrintScreen()
keybd_event VK_SNAPSHOT, 1, 0, 0 'Key Down
keybd_event VK_SNAPSHOT, 1, KEYEVENTF_KEYUP , 0 'Key Up
End Sub
You can then paste the screenshot to a Worksheet and export it as PDF
Sub SaveAsPDF()
Const FILE_PATH as String = "C:\Temp\"
PrintScreen 'Take a screenshot
With Sheet1
.Paste 'Paste it to Sheet1
.ExportAsFixedFormat xlTypePDF, FILE_PATH & "Screenshot File.pdf" 'Export Sheet1 to PDF
End With
End Sub
I found the code below in an another thread which is working as per your requirement.
I tested it and it is taking snapshot and saving it to the specific folder.
Option Explicit
'requires references: "Microsoft HTML Object Library" & "Microsoft Internet Controls"
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, _
ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Declare Function ShowWindow Lib "user32" _
(ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Sub getSS()
Const url = "stackoverflow.com" 'page to get screenshot of (http is added below)
Const fName = "D:\thumb_" & url & ".png" 'output filename (can be png/jpg/bmp/gif)
Const imgScale = 0.25 'scale to 25% (to create thumbnail)
Dim ie As InternetExplorer, ws As Worksheet, sz As Long
Dim img As Picture, oCht As ChartObject
Set ws = ThisWorkbook.Sheets("Sheet1")
Set ie = GetIE()
With ie
.navigate "http://" & url
Do: DoEvents: Loop While .busy Or .readyState <> 4 'wait for page load
ShowWindow Application.hwnd, 5 'activate IE window
Call keybd_event(44, 0, 0, 0) '44="VK_SNAPSHOT"
Pause (0.25) 'pause so clipboard catches up
With ws
ShowWindow Application.hwnd, 5 'back to Excel
.Activate
.Paste
Set img = Selection
With img
Set oCht = ws.ChartObjects.Add(.Left, .Top, .Left + .Width, .Top + .Height)
oCht.Width = .Width * imgScale 'scale obj to picture size
oCht.Height = .Height * imgScale
oCht.Activate
ActiveChart.Paste
ActiveChart.Export fName, Mid(fName, InStrRev(fName, ".") + 1)
oCht.Delete
.Delete
End With
.Activate
End With
.FullScreen = False
.Quit
End With
If Dir(fName) = "" Then Stop 'Something went wrong (file not created)
sz = FileLen(fName)
If sz = 0 Then Stop 'Something went wrong! (invalid filename maybe?)
Debug.Print "Created '" & fName & "' from '" & url & "' (" & sz & " bytes)": Beep
End Sub
Sub Pause(sec As Single)
Dim t As Single: t = Timer
Do: DoEvents: Loop Until Timer > t + sec
End Sub
Function GetIE() As Object
'requires references: "Microsoft HTML Object Library" & "Microsoft Internet Controls"
'return an object for the open Internet Explorer window, or create new one
For Each GetIE In CreateObject("Shell.Application").Windows() 'Loop to find
If (Not GetIE Is Nothing) And GetIE.Name = "Internet Explorer" Then Exit For 'Found!
Next GetIE
If GetIE Is Nothing Then Set GetIE=CreateObject("InternetExplorer.Application") 'Create
GetIE.Visible = True 'Make IE visible
GetIE.FullScreen = True
End Function
Reference:
How to take screenshot of webpage using VBA?
Further, you can modify the code as per your own requirement.
I am creating a marquee text in Excel 2013. As the Microsoft Web Browser Control doesn't work in Excel 2013 and 2016, so I used the following VBA code:
Sub DoMarquee()
Dim sMarquee As String
Dim iWidth As Integer
Dim iPosition As Integer
Dim rCell As Range
Dim iCurPos As Integer
'Set the message to be displayed in this cell
sMarquee = "This is a scrolling Marquee."
'Set the cell width (how many characters you want displayed at once
iWidth = 10
'Which cell are we doing this in?
Set rCell = Sheet1.Range("M2")
'determine where we are now with the message. InStr will return the position
' of the first character where the current cell value is in the marquee message
iCurPos = InStr(1, sMarquee, rCell.Value)
'If we are position 0, then there is no message, so start over
' otherwise, bump the message to the next characterusing mid
If iCurPos = 0 Then
'Start it over
rCell.Value = Mid(sMarquee, 1, iWidth) Else
'bump it
rCell.Value = Mid(sMarquee, iCurPos + 1, iWidth)
End If
'Set excel up to run this thing again in a second or two or whatever
Application.OnTime Now + TimeValue("00:00:01"), "DoMarquee"
End Sub
It is reflecting in excel every second, is there a way to reflect in milliseconds so that it can show some smooth running. And more issue is, it again starts only after scrolling completely. Is there anyway to make it in a scroll continuously with waiting for the entire text to scroll.
For your sub second functionality use an API call.
Option Explicit
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Sub DoMarquee()
Dim sMarquee As String
Dim iWidth As Long
Dim iPosition As Long
Dim rCell As Range
Dim iCurPos As Long
sMarquee = "This is a scrolling Marquee."
iWidth = 10
Set rCell = Sheet1.Range("M2")
iCurPos = InStr(1, sMarquee, rCell.Value)
If iCurPos = 0 Then
rCell.Value = Mid(sMarquee, 1, iWidth)
Else
rCell.Value = Mid(sMarquee, iCurPos + 1, iWidth)
End If
Sleep 100
Application.Run "DoMarquee"
End Sub
Drop the PtrSafe if on 32 bit machine so becomes:
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Edit:
1) A number of users have noted out of stack space messages to frequency of calls.
#Sorceri has correctly pointed out you can re-work as:
Set rCell = Nothing
DoEvents
Sleep 100
Application.OnTime Now, "DoMarquee"
2) I was unaware of the letter by letter part so I will refer you to his/her answer on the pulling of iWidth into global variable.
That in mind, you may wish to amend the following to take account of #Sorceri's iWidth; I have the following version 2 "fudge" for the hyperlink, amended for out-of-stack, and which includes a test for 32 v 64 bit versions to ensure compatibility. More info on compatibility here.
Version 2:
Option Explicit
#If Win64 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
Public Sub DoMarquee()
Dim sMarquee As String
Dim iWidth As Long
Dim iPosition As Long
Dim rCell As Range
Dim iCurPos As Long
sMarquee = "This is a scrolling Marquee."
iWidth = 10
Set rCell = Sheet1.Range("M2")
rCell.Parent.Hyperlinks.Add Anchor:=rCell, Address:="https://www.google.co.uk/", TextToDisplay:=rCell.Text
rCell.Font.ThemeColor = xlThemeColorDark1
iCurPos = InStr(1, sMarquee, rCell.Value)
If iCurPos = 0 Then
rCell.Value = Mid(sMarquee, 1, iWidth)
rCell.Hyperlinks(1).TextToDisplay = rCell.Text
FormatCell rCell
Else
rCell.Value = Mid(sMarquee, iCurPos + 1, iWidth)
On Error Resume Next
rCell.Hyperlinks(1).TextToDisplay = rCell.Text
On Error GoTo 0
FormatCell rCell
End If
Set rCell = Nothing
DoEvents
Sleep 100
Application.OnTime Now, "DoMarquee"
End Sub
Public Sub FormatCell(ByVal rng As Range)
With rng.Font
.Name = "Calibri"
.Size = 11
.Underline = xlUnderlineStyleSingle
.Color = 16711680
End With
End Sub
I couldn't get the example to stop the stack out of space as there were to many calls on the stack to the DoMarquee method. Plus I thought a marquee wrote it out character by character. So using Application.OnTime event to create the marquee. I also took out the iWidth and made it a global variable.
Option Explicit
Private iWidth As Long
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Sub DoMarquee()
Dim sMarquee As String
Dim iPosition As Long
Dim rCell As Range
Dim iCurPos As Long
Dim txtMarquee As String
sMarquee = "This is a scrolling Marquee."
Set rCell = Sheet1.Range("M2")
'check to see if the cell is empty
If rCell.Value = "" Then
'set the current position to 0 and iWidth to 0
iCurPos = 0
iWidth = 0
Else
'not blank so writing has started. Get the position of the cell text
iCurPos = InStr(1, sMarquee, rCell.Value)
End If
If iCurPos = 0 Then
'it is zero so get the first character
rCell.Value = Mid(sMarquee, iCurPos + 1, 1)
Else
If iWidth < 10 Then
'width is less then ten so we have not written out the max characters,
'continue until width is 10
iWidth = iWidth + 1
rCell.Value = Mid(sMarquee, 1, iWidth)
Else
'maxed the amount to show so start scrolling
rCell.Value = Mid(sMarquee, iCurPos + 1, iWidth)
End If
End If
'release range object
Set rCell = Nothing
'Application.OnTime to stop the stack out of space
DoEvents
Sleep 100
Application.OnTime Now, "DoMarquee"
End Sub
I have created a code that extracts certain data from website, adds it to the sheet, then checks what day it is and modifies progress bar (only columns in sheet). Then the code saves the current result on sheet as image and finally sets it as wallpaper. At first I had to deal with "unknown" problems. I ran the code ańd it failed. But when I debugged it step by step it ran perfectly. I figured out that my Workbook had to be corrupted. So I copied the VBA to a new workbook and finally the code ran OK. After few days I started to get errors like cells object global failed etc. I read that it happens when certain objects are not sufficiently defined so I added thisworkbook.sheets(1).cells to every cells object that error appeared at. This didn't help since the errors started popping even in the most fundamental basic stuff. So I shift started the workbook at revealed the problem. Or I THINK.. The macro removes current sheet every time I run it. Few days back it did't. Simply nothing has changed.. I will paste the code below. Is the workbook corrupted again and how does one prevent it?
Option Explicit
Public Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" _
(ByVal uAction As Long, ByVal uParam As Long, _
ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long
Public Const SPI_SETDESKWALLPAPER = 20
Public Const SPIF_SENDWININICHANGE = &H2
Public Const SPIF_UPDATEINIFILE = &H1
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
Sub Auto_Open()
Call getDataFromWebsite
Call weekProgress
Call saveSheet
Call changeWallpaper
ThisWorkbook.Close SaveChanges:=False
Application.Quit
End Sub
Sub getDataFromWebsite()
Dim x As String
Dim IE As Object
Dim HtmlCon As HTMLDocument
Dim element As Object
Dim ArrivalTime
On Error GoTo Handler
x = "someWebsite"
Set IE = New InternetExplorerMedium
IE.Navigate (x)
IE.Visible = False
Do While IE.ReadyState <> 4
DoEvents
Loop
Set HtmlCon = IE.document
Set element = HtmlCon.getElementsByClassName("someclassname")
ArrivalTime = element(0).innerText
ThisWorkbook.Sheets(1).Cells(3, 15).Value = ArrivalTime
Handler:
IE.Quit
End Sub
Sub weekProgress()
Dim caseResult As String
Dim offsetDayIndex As Integer
Const dayBarLenght = 2
Select Case Application.WorksheetFunction.Weekday(Date, 2)
Case 1
caseResult = "Monday"
offsetDayIndex = 0
Case 2
caseResult = "Tuesday"
offsetDayIndex = 1
Case 3
caseResult = "Wednesday"
offsetDayIndex = 2
Case 4
caseResult = "Thursday"
offsetDayIndex = 3
Case 5
caseResult = "Friday"
offsetDayIndex = 4
Case Else
caseResult = "Monday"
End Select
DoEvents
ThisWorkbook.Sheets(1).Cells(24, 11).Value = caseResult
ThisWorkbook.Sheets(1).Range(ThisWorkbook.Sheets(1).Cells(31, 5), ThisWorkbook.Sheets(1).Cells(31, 12)).Interior.ColorIndex = 1
If Not caseResult = "Monday" Then
ThisWorkbook.Sheets(1).Range(ThisWorkbook.Sheets(1).Cells(31, 5), ThisWorkbook.Sheets(1).Cells(31, 4 + (dayBarLenght * offsetDayIndex))).Interior.ColorIndex = 2
End If
End Sub
Sub saveSheet()
Dim oCht As Object
Dim zoom_coef
Dim area
zoom_coef = 100 / ThisWorkbook.Sheets(1).Parent.Windows(1).Zoom
Set area = ThisWorkbook.Sheets(1).Range(ThisWorkbook.Sheets(1).PageSetup.PrintArea)
DoEvents
area.CopyPicture xlPrinter
Application.DisplayAlerts = False
DoEvents
Set oCht = ThisWorkbook.Sheets(1).ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef)
DoEvents
DoEvents
oCht.Chart.Paste
DoEvents
DoEvents
oCht.Chart.Export Filename:="somepath\savedImage.bmp", Filtername:="bmp"
DoEvents
oCht.Delete
Application.DisplayAlerts = True
End Sub
Sub changeWallpaper()
Dim strImagePath As String
strImagePath = "somepath\savedImage.bmp"
Call SystemParametersInfo(SPI_SETDESKWALLPAPER, 0&, strImagePath, SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE)
End Sub
Sub saveSheetBackup()
Dim oCht
Worksheets("List1").Range("B2:Q37").CopyPicture xlScreen, xlBitmap
Application.DisplayAlerts = False
Set oCht = Charts.Add
DoEvents
oCht.Paste
DoEvents
oCht.Export Filename:="somepath\savedImage.bmp", Filtername:="bmp"
DoEvents
oCht.Delete
Application.DisplayAlerts = True
End Sub
I have had an epiphany. I have substituted the Thisworkbook.Close with simple Application.Quit with alerts disabled and this did the trick. I still don't quite understand why shutting down workbook without saving would delete the sheet altogether. Someone can enlighten me?
Dim StartTime As Date
Public Declare Function SetTimer Lib "user32" ( _
ByVal HWnd As Long, ByVal nIDEvent As Long, _
ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32" ( _
ByVal HWnd As Long, ByVal nIDEvent As Long) As Long
Public TimerID As Long, TimerSeconds As Single, tim As Boolean
Dim Counter As Long
Sub StartTimer()
'~~ Set the timer for 1 second
TimerSeconds = 1
TimerID = SetTimer(0&, 0&, TimerSeconds * 1000&, AddressOf TimerProc)
End Sub
'~~> End Timer
Sub EndTimer()
On Error Resume Next
KillTimer 0&, TimerID
End Sub
Sub TimerProc(ByVal HWnd As Long, ByVal uMsg As Long, _
ByVal nIDEvent As Long, ByVal dwTimer As Long)
'~~> Update value in Sheet 1
Sheet1.Range("H6").Value = Time - StartTimer
End Sub
Public Sub sheet()
Sheets("1").Activate
StartTime = Time
Call Module1.StartTimer
End Sub
I would like to write a code which show timer how much time user working on the Worksheet.
Example there is a start button in sheet1 when user click on start button then it will active sheet2 then a timer will run in cell A1. if the timer is 30 min then the workbook save & close.
Try this
Create Button and assign to the following macro
Option Explicit
Sub NewTimer()
Dim Start As Single
Dim Cell As Range
Dim CountDown As Date
'// Store timer as variable
Start = Timer
'// Format cell A1 to 24Hrs eg: 00:00:00
With Range("A1")
.NumberFormat = "HH:MM:SS;#"
End With
Set Cell = Sheet1.Range("A1")
'// This is the starting value. 30 Second
CountDown = TimeValue("00:00:30")
'// Set cell to the starting value
Cell.Value = CountDown
'Keep looping until A1 hits zero or
Do While Cell.Value > 0
'Update the cell. Timer - Starting number is seconds
Cell.Value = CountDown - TimeSerial(0, 0, Timer - Start)
DoEvents
Loop
ThisWorkbook.Save
ThisWorkbook.Close
Application.Quit
End Sub
Thanks to Dick Kusleika See Example
long time user, first question.
So an internet site that my business used to get information on coal ship movements has recently been reworked, so I have to rework my program to scrape the ship information. I had been navigating to each port using button click events and using;
Dim Table As Object, Set Table = ie.document.getElementsByTagName("TABLE")(11)
to get the actual table. On the new site they have the option to export all ship movements to excel and it would be a lot quicker if I could automate the macro to get the excel files. To clarify I am just trying to get my program to go to this site; https://qships.tmr.qld.gov.au/webx/, click on 'Ship Movements' up the top, click 'Tools', click 'Export to excel' then open the file and go back to the site and click 'Vessel At birth', 'Tools', 'Export to excel' and open that file, then use somthing like;
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
To get the sheets from the workbooks back to my main workbook, where I will then search through and get the ones I want. Here's what I've got sofar;
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
and I have this in a module
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
My problem is that when these excel files are opening, they open in a new instance of excel and I can't reference them any regular way. Since they are not actually saved I can't use GetObject() like recommended in this answer Can VBA Reach Across Instances of Excel? and I don't know how to reference the excel workbooks using a handle. I think that they are opening in a new instance of excel because the macro is running and even when using Sleep() it doesn't let excel open the new workbooks. I have tried using a Do DoWhile Loop to let excel open the workbooks but that doesn't seem to work. So, if anyone could help me open the workbooks in the same instance of excel so that I can reference them easier or reference between excel instances without GetObject() that would be greatly appreciated.
==================================EDIT=======================================
This was the final result I wound up with. Thanks to user3565396 I just saved it in the downloads folder like you recommended, I couldn't figure out how to use WinHttp like Robert Co recommended. For some reason the code exits without an error message on the line wb2.Sheets(1).Copy After:=wb1.Sheets("Import") but re-opening seems to work fine and it's only used once or twice a day.
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
Here is the solution. I skipped some steps which you have done correctly. The code starts from clicking Tools and then Export to excel. After that I click "Alt + S" which is Save (Not Open). With this code I managed to copy worksheet from the downloaded file to the workbook from which I was running the VBA code. Hope that helps.
P.S. All files must be in the same directory.
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
When you click a link, it download it to the browser temporary folder and open it with the recommended application in another session. The trick is is download the file within the VBA itself and open it in the same session. If the url is predictable, you can certainly automate that.
Use WinHttp to download as a stream and recreate that file in your own temp folder. It's about 10 lines of code. Continue the VBA with Workbooks.Open which opens the file in the same session.