I'm using VBA in MS Access. I'm trying search through ie tabs (15 of them) bring the found tab to the foreground, maximise it, then find on page a string i'm searching for. I can find the tab using the code below but its not maximising the window and nor are the send keys working to find on page. Is there a way using the shell to do this?
Option Compare Database
#If Win64 Then
Private Declare PtrSafe Function SetForegroundWindow Lib "user32" _
(ByVal hWnd As LongPtr) As LongPtr
#Else
Private Declare Function SetForegroundWindow Lib "user32" _
(ByVal hWnd As Long) As Long
#End If
Private Sub P2_Click()
Dim sURL As String
Dim strSearch As String
Dim SWs As Object
sURL = CStr(Me.tblOdds_1_sURL)
strSearch = Mid(Me.P2, 1, 5)
'get windows
Set SWs = CreateObject("Shell.Application")
For Each ow In SWs.windows
If ow = "Internet Explorer" _
And sURL = Trim(ow.Document.Location) Then
SetForegroundWindow ow.hWnd
SendKeys "^f", False
SendKeys strSearch, False
SendKeys "{ENTER}", False
SendKeys "{ESC}", False
End If
Next ow
Set SWs = Nothing
End Sub
Related
I tried to follow up with the topic here:
How to connect to OPEN workbook in another instance of Excel
But I ran into a problem,
I am not able grab the new instance name or path.
However I know I have open Excel window in another instance (opened from a SAP system) and when I open VBA editor in that SAP generated Excel file and I type: ? Thisworkbook.Path in immediate window I get nothing, no path is given and thus this solutions does not get the instance path.
What can I do to make it work ?
My issue is that this: Set xlApp = GetObject("C:\Tmp\TestData2.xlsx") is not grabbing the workbook name (including This.workbook.name or activeworkbook.name)
Any idea how else I can make VBA code in instance 1 work with workbook in instance 2?
I only want to save it nothing more, I'm using Saveas option, or at least I try.
Have anyone had a similar issue?
Working with the Excel files downloaded from SAP is always problematic.
You can use the module below and add before the xls.Close SaveChanges:=False this line xls.SaveAs Filename:='Any name that you want after that just place a call in your code after downloading the Excel File with
Call Close_SAP_Excel("TestData2.xlsx")
And it should work fine.
Module:
#If VBA7 Then
Private Declare PtrSafe Function AccessibleObjectFromWindow Lib "oleacc" ( _
ByVal hwnd As LongPtr, ByVal dwId As Long, riid As Any, ppvObject As Object) As Long
Private Declare PtrSafe Function FindWindowExA Lib "user32" ( _
ByVal hwndParent As LongPtr, ByVal hwndChildAfter As LongPtr, _
ByVal lpszClass As String, ByVal lpszWindow As String) As LongPtr
#Else
Private Declare Function AccessibleObjectFromWindow Lib "oleacc" ( _
ByVal hwnd As Long, ByVal dwId As Long, riid As Any, ppvObject As Object) As Long
Private Declare Function FindWindowExA Lib "user32" ( _
ByVal hwndParent As Long, ByVal hwndChildAfter As Long, _
ByVal lpszClass As String, ByVal lpszWindow As String) As Long
#End If
Sub Close_SAP_Excel(ParamArray FileNames())
'Procedure to close files downloaded from SAP and at the same time close the Excel application instance that will be open with them.
Dim ExcelAppSAP As Variant
Dim ExcelFile As Variant
Dim FinishedLoop As Boolean, TimeoutReached As Boolean, FileClosed As Boolean
Dim ReTry As Long
Dim i As Long, x As Long
Set ExcelAppSAP = Nothing
ReTry = 100000 'Used as Timeout 100000 = ~10 seconds
i = 1
'The following loop is executed until excel file is closed.
'Inside of this, there is a For Loop for each Excel Instance and inside of that is another loop
'for each excel inside the instance. If name matches, it is closed.
Do While Not FinishedLoop
If i > ReTry Then
TimeoutReached = True
Exit Do
End If
For Each ExcelFile In GetExcelInstances() 'Function to Get Excel Open Instances
For Each xls In ExcelFile.Workbooks
For x = LBound(FileNames()) To UBound(FileNames())
If xls.Name = FileNames(x) Then
Set ExcelAppSAP = ExcelFile 'Set Instance opened by SAP to variable
'Here add actions if needed. Reference to workbook as xls e.g.: xls.Sheets(1).Range("A1").Copy
xls.Close SaveChanges:=False
FileClosed = True
End If
Next x
Next
Next
If FileClosed Then
FinishedLoop = True
End If
i = i + 1
Loop
ThisWorkbook.Activate
If Not TimeoutReached Then
If FileClosed Then
On Error Resume Next
If ExcelAppSAP.Workbooks.Count = 0 Then
ExcelAppSAP.Quit
End If
Else
MsgBox "Excel application instance from SAP was not closed correctly. Please close it manually or try again.", , "Error"
End If
Else
MsgBox "Max timeout reached", , "Error"
End If
End Sub
Public Function GetExcelInstances() As Collection
Dim guid&(0 To 3), acc As Object, hwnd, hwnd2, hwnd3
guid(0) = &H20400
guid(1) = &H0
guid(2) = &HC0
guid(3) = &H46000000
Set GetExcelInstances = New Collection
Do
hwnd = FindWindowExA(0, hwnd, "XLMAIN", vbNullString)
If hwnd = 0 Then Exit Do
hwnd2 = FindWindowExA(hwnd, 0, "XLDESK", vbNullString)
hwnd3 = FindWindowExA(hwnd2, 0, "EXCEL7", vbNullString)
If AccessibleObjectFromWindow(hwnd3, &HFFFFFFF0, guid(0), acc) = 0 Then
GetExcelInstances.Add acc.Application
End If
Loop
End Function
I am receiving a 'Type Mistmatch' error on the HWNDSrc = objIE.HWND line below but HWND is a Long property & HWNDSrc has been set as Long
Sub Test()
Dim objIE As InternetExplorer
Set objIE = New InternetExplorer
Dim HWNDSrc As Long
HWNDSrc = objIE.HWND
SetForegroundWindow HWNDSrc
End Sub
SetForegroundWindow is a Windows API function that takes and returns LongPtr on 64-bit Office, and Long on 32 bit Office, so you need to account for that using conditional compilation constants. See this for reference.
Option Explicit
#If VBA7 Then
Public Declare PtrSafe Function SetForegroundWindow Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
#Else
Public Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
#End If
Sub Test()
Dim objIE As InternetExplorer
Set objIE = New InternetExplorer
#If VBA7 Then
Dim HWNDSrc As LongPtr
#Else
Dim HWNDSrc As Long
#End If
HWNDSrc = objIE.hwnd
SetForegroundWindow HWNDSrc
End Sub
I had lots of issues dealing with that IE 11 download bar when downloading a file.
I checked different solutions but the only way to make it work the most reliably possible was to put two of them together.
Then I set the default internet download folder as my Desktop so that whenever I download a file with SendKeys I know where to find it with the code.
For the little story, my code is downloading the attached files for all the different incident cases. The number/type of attachments can vary and to oragnize it a little bit I decided to create a folder with the name of the incident case and store the attachments inside.
So here is my code, if you see a part which could be improved let me know :)
Option Explicit
Private objIE As SHDocVw.InternetExplorer
Private ContentFrame As HTMLIFrame
Public Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Public Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Public Const MOUSEEVENTF_LEFTDOWN = &H2
Public Const MOUSEEVENTF_LEFTUP = &H4
Public Const MOUSEEVENTF_RIGHTDOWN As Long = &H8
Public Const MOUSEEVENTF_RIGHTUP As Long = &H10
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Sub LeftClick()
mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
Sleep 50
mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
End Sub
Sub DownloadAttachment()
'make sure Cell A4 isn't empty because it has to contain the incident case
If Sheets(1).Cells(4, 1) = "" Or Sheets(1).Cells(4, 1) = " " Then End
'make sure it's a valid case No. before going on
On Error GoTo Fin
If Len(Cells(4, 1)) <> 8 Or CLng(Sheets(1).Cells(4, 1)) = 0 Then
MsgBox "Please enter a valid Case No."
End
End If
Call GetDataFromIntranet(Sheets(1).Cells(4, 1)
'Delete content on cell A4
Fin:
Sheets(1).Cells(4, 1) = ""
End Sub
Function GetDataFromIntranet(CaseNo As Long)
Dim i As Integer
If ("attachmentDivId").Children(0).Children(1).Children.Length >= 1 Then Call CreateFolder(CaseNo) ' If there is at least 1 attachment then we'll create a folder which has the name of the incident case
For i = 0 To objIE.document.frames(1).frames(1).document.getElementById("attachmentDivId").Children(0).Children(1).Children.Length - 1 ' For each attachment...
RetourALaCaseDepart:
objIE.document.frames(1).frames(1).document.getElementById("attachmentDivId").Children(0).Children(1).Children(i).Click ' Click on it so that it gets activated (blue)
objIE.document.frames(1).frames(1).document.getElementsByName("download")(0).Click 'Click on Save as
'The following bit send keyboard keys to cope with the Internet Downaload window that appears down the page -> downloads the file and save it on the Desktop
Application.Wait Now + TimeSerial(0, 0, 10)
Application.SendKeys "%{S}"
Application.Wait Now + TimeSerial(0, 0, 10)
SendKeys "{F6}", True
SendKeys "{TAB}", True
SendKeys "{ENTER}", True
'Here we close the Desktop window which sometimes open because it can alter the SendKey codes which is very sensitive
Dim objShellWindows As New SHDocVw.ShellWindows
Dim win As Object
For Each win In objShellWindows
If win.LocationName = "Desktop" Then
win.Quit
End If
Next win
Application.Wait Now + TimeSerial(0, 0, 1)
If MakeSureDownloaded(objIE.document.frames(1).frames(1).document.getElementById("attachmentDivId").Children(0).Children(1).Children(i).Children(0).innerText, CaseNo) = False Then GoTo RetourALaCaseDepart ' We check if the attachment was successfully saved, if not we redo the saving process from "RetourALaCaseDepart
Next i
Exit Function
Fini:
MsgBox "No attachments found or attachment tab not found"
End Function
Function MakeSureDownloaded(FileName As String, CaseNo As Long) As Boolean
Dim FileSys As Object 'FileSystemObject
Dim objFile As Object 'File
Dim myFolder
Dim strFilename As String
Const myDir As String = "C:\Users\Seb\Desktop\"
'set up filesys objects
Set FileSys = CreateObject("Scripting.FileSystemObject") 'New FileSystemObject
Set myFolder = FileSys.GetFolder(myDir)
For Each objFile In myFolder.Files
If objFile.Name Like FileName & "*" Then ' If the file was saved then we will add it to the folder created earlier for that Case
strFilename = objFile.Name
MakeSureDownloaded = True
GoTo BienBien
End If
Next objFile
MakeSureDownloaded = False
Set FileSys = Nothing
Set myFolder = Nothing
Exit Function
BienBien:
Dim fso As Object
Set fso = VBA.CreateObject("Scripting.FileSystemObject")
Call fso.MoveFile("C:\Users\Seb\Desktop\" & strFilename, "Path...\Case_Attachments\" & CaseNo & "\" & strFilename)
Set FileSys = Nothing
Set myFolder = Nothing
End Function
Sub CreateFolder(CaseNo As Long)
Dim fsoFSO
Set fsoFSO = CreateObject("Scripting.FileSystemObject")
If fsoFSO.FolderExists("Path...\Case_Attachments\" & CaseNo) Then ' do nothing actually...
Else
fsoFSO.CreateFolder ("Path...\Case_Attachments\" & CaseNo)
End If
End Sub
I'm trying to get my access db to come to the foreground based on the couple of lines, below. I'm not sure why it isn't working though, or if there are better methods to do this.
From what I've read, this should work:
Access.Visible = False
Access.Visible = True
But doesn't actually bring the database to the front.
Edit for more info:
Private Sub Form_Open(Cancel As Integer)
getStrUserName = Environ("username")
dbName = "myDB.accdb" ' database name
versionChckDB = "versionCheckDB.accdb" ' version check db name
strServer = "C:\My\Path\to\Server" ' server location string
strDesktop = "C:\My\Path\to\Local" ' desktop location string
strVersionCheck = "C:\My\Path\to\Version" ' version check location
Static acc As Access.Application
Dim db As DAO.Database
Dim strDbName As String
If FileLocked(strDesktop & "\" & versionChckDB) Then
Dim objAccess As Access.Application
Set objAccess = GetObject(strDesktop & "\" & versionChckDB)
objAccess.Application.Quit acQuitSaveAll
Set objAccess = Nothing
DoCmd.OpenForm "frmMainMenu"
DoCmd.RunCommand acCmdAppMaximize
Access.Visible = False
Access.Visible = True
GoTo exitSub
Else
strDbName = strDesktop & "\" & versionChckDB
Set acc = New Access.Application
acc.Visible = True
Set db = acc.DBEngine.OpenDatabase(strDbName, False, False)
acc.OpenCurrentDatabase strDbName
End If
'db.Close
exitSub:
Call SetForegroundWindow(Application.hWndAccessApp) ' bringing access DB to foreground
End Sub
Usually one uses an API function for that.
From http://www.access-programmers.co.uk/forums/showthread.php?t=132129 :
Public Declare Function SetForegroundWindow Lib "user32" (ByVal hWnd As Long) As Long
and then
Call SetForegroundWindow(Application.hWndAccessApp)
Edit
If you want to get the newly opened Access application window to the front, you need its hWnd:
Call SetForegroundWindow(acc.hWndAccessApp)
Edit 2
This works for me. Notepad is briefly in the foreground, then the Access window.
Module:
Public Declare Function SetForegroundWindow Lib "user32" (ByVal hWnd As Long) As Long
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Sub TestAccessToForeground()
Sleep 300
Shell "notepad.exe", vbNormalFocus
Sleep 300
Call SetForegroundWindow(Application.hWndAccessApp)
End Sub
Form:
Private Sub Form_Open(Cancel As Integer)
Call TestAccessToForeground
End Sub
I am performing a quick PING against the user-selected server IP to confirm it is reachable.
The following code does exactly what I need, except I would like to avoid the quick flash of the Command Shell window.
What do I need to modify to minimize that pesky CMD window?
SystemReachable (myIP)
If InStr(myStatus, "Reply") > 0 Then
' IP is Confirmed Reachable
Else
' IP is Not Reachable
End If
''''''''''''''''''''''
Function SystemReachable(ByVal strIP As String)
Dim oShell, oExec As Variant
Dim strText, strCmd As String
strText = ""
strCmd = "ping -n 1 -w 1000 " & strIP
Set oShell = CreateObject("WScript.Shell")
Set oExec = oShell.Exec(strCmd)
Do While Not oExec.StdOut.AtEndOfStream
strText = oExec.StdOut.ReadLine()
If InStr(strText, "Reply") > 0 Then
myStatus = strText
Exit Do
Else
myStatus = ""
End If
Loop
End Function
This question may be a little old but I figure that this answer may still be able to help.
(Tested with Excel VBA, have not been able to test with Access)
The WshShell.Exec Method enables the use of .StdIn, .StdOut, and .StdErr functions to write to and read from the consol window.
The WshShell.Run Method does not allow this functionality so for some purposes using Exec is required.
While it's true that there is no built in function to start the Exec method minimized or hidden you can use API's to quickly find the Exec window hwnd and minize/hide it.
My below script takes the ProcessID from the Exec object to find the window's Hwnd. With the Hwnd you can then set the window's show state.
From my testing with Excel 2007 VBA, in most cases I never even see the window... In some cases it might be visible for a few milliseconds but would only appear a quick flicker or blink... Note: I had better results using SW_MINIMIZE than I did with SW_HIDE, but you can play around with it.
I added the TestRoutine Sub to show an example of how to use the 'HideWindow' function.
The 'HideWindow' function uses the 'GetHwndFromProcess' function to get the window hwnd from the ProcessID.
Place the below into a Module...
Option Explicit
' ShowWindow() Commands
Public Const SW_HIDE = 0
Public Const SW_MINIMIZE = 6
'GetWindow Constants
Public Const GW_CHILD = 5
Public Const GW_HWNDFIRST = 0
Public Const GW_HWNDLAST = 1
Public Const GW_HWNDNEXT = 2
Public Const GW_HWNDPREV = 3
Public Const GW_OWNER = 4
' API Functions
Public Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Public Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Public Declare Function GetDesktopWindow Lib "user32" () As Long
Public Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Sub TestRoutine()
Dim objShell As Object
Dim oExec As Object
Dim strResults As String
Set objShell = CreateObject("WScript.Shell")
Set oExec = objShell.Exec("CMD /K")
Call HideWindow(oExec.ProcessID)
With oExec
.StdIn.WriteLine "Ping 127.0.0.1"
.StdIn.WriteLine "ipconfig /all"
.StdIn.WriteLine "exit"
Do Until .StdOut.AtEndOfStream
strResults = strResults & vbCrLf & .StdOut.ReadLine
DoEvents
Loop
End With
Set oExec = Nothing
Debug.Print strResults
End Sub
Function HideWindow(iProcessID)
Dim lngWinHwnd As Long
Do
lngWinHwnd = GetHwndFromProcess(CLng(iProcessID))
DoEvents
Loop While lngWinHwnd = 0
HideWindow = ShowWindow(lngWinHwnd, SW_MINIMIZE)
End Function
Function GetHwndFromProcess(p_lngProcessId As Long) As Long
Dim lngDesktop As Long
Dim lngChild As Long
Dim lngChildProcessID As Long
On Error Resume Next
lngDesktop = GetDesktopWindow()
lngChild = GetWindow(lngDesktop, GW_CHILD)
Do While lngChild <> 0
Call GetWindowThreadProcessId(lngChild, lngChildProcessID)
If lngChildProcessID = p_lngProcessId Then
GetHwndFromProcess = lngChild
Exit Do
End If
lngChild = GetWindow(lngChild, GW_HWNDNEXT)
Loop
On Error GoTo 0
End Function
ShowWindow function:
http://msdn.microsoft.com/en-us/library/windows/desktop/ms633548%28v=vs.85%29.aspx
GetWindow function:
http://msdn.microsoft.com/en-us/library/windows/desktop/ms633515%28v=vs.85%29.aspx
GetDesktopWindow function:
http://msdn.microsoft.com/en-us/library/windows/desktop/ms633504%28v=vs.85%29.aspx
GetWindowThreadProcessId function:
http://msdn.microsoft.com/en-us/library/windows/desktop/ms633522%28v=vs.85%29.aspx
If you need more information on how the API's work, a quick google search will provide you with a ton of information.
I hope that this can help... Thank You.
Found a very workable and silent approach:
Dim strCommand as string
Dim strPing As String
strCommand = "%ComSpec% /C %SystemRoot%\system32\ping.exe -n 1 -w 500 " & myIP & " | " & "%SystemRoot%\system32\find.exe /i " & Chr(34) & "TTL=" & Chr(34)
strPing = fShellRun(strCommand)
If strPing = "" Then
MsgBox "Not Connected"
Else
MsgBox "Connected!"
End If
'''''''''''''''''''''''''''
Function fShellRun(sCommandStringToExecute)
' This function will accept a string as a DOS command to execute.
' It will then execute the command in a shell, and capture the output into a file.
' That file is then read in and its contents are returned as the value the function returns.
' "myIP" is a user-selected global variable
Dim oShellObject, oFileSystemObject, sShellRndTmpFile
Dim oShellOutputFileToRead, iErr
Set oShellObject = CreateObject("Wscript.Shell")
Set oFileSystemObject = CreateObject("Scripting.FileSystemObject")
sShellRndTmpFile = oShellObject.ExpandEnvironmentStrings("%temp%") & oFileSystemObject.GetTempName
On Error Resume Next
oShellObject.Run sCommandStringToExecute & " > " & sShellRndTmpFile, 0, True
iErr = Err.Number
On Error GoTo 0
If iErr <> 0 Then
fShellRun = ""
Exit Function
End If
On Error GoTo err_skip
fShellRun = oFileSystemObject.OpenTextFile(sShellRndTmpFile, 1).ReadAll
oFileSystemObject.DeleteFile sShellRndTmpFile, True
Exit Function
err_skip:
fShellRun = ""
oFileSystemObject.DeleteFile sShellRndTmpFile, True
End Function
the run method of wscript already contains argumewnts to run minimized. So without all that effort shown above simply use
old code
oShellObject.Run sCommandStringToExecute & " > " & sShellRndTmpFile, 0, True
new code
oShellObject.Run sCommandStringToExecute & " > " & sShellRndTmpFile, 7, True
see Microsoft help for using the run method in wscript.
regards
Ytracks