I am using vba code to open an access database from another access database using the following codes
Public Declare Function ShellExecuteA Lib "shell32.dll" _
(ByVal hWnd As Long, ByVal strOperation As String, _
ByVal strFile As String, ByVal strParameters As String, ByVal strDirectory As _
String, ByVal nShowCmd As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Dim lngreturn As Long
lngreturn = ShellExecuteA(GetDesktopWindow(), "OPEN", strFilePath, "", "", vbNormalFocus)
It works fine except that it keeps opening new instances of the database even if there is one already open in the background. I need codes to bring the opened database to the foreground. NB:- I have used AppActivate and it does not work because I am already in msaccess and the other database that I want to bring to the foreground is also in access.
Set an Application title for the second database in File - Options - Current database.
Then use that title with AppActivate.
Alternatively, instead of using ShellExecuteA, build a full command line (including the path to msaccess.exe), and use the Shell() function to start the second database:
Runs an executable program and returns a Variant (Double) representing the program's task ID if successful
Store this task ID in a public or static variable, and use it with AppActivate.
Related
I need to be able to list all current Access applications. The GetObject command is well thought out, but it is not very efficient when it comes to simultaneously processing batches of read/write accdb files and ensure that there is only one Access instance per file. I found approaches to my problem in some rare places on the Net and I was actually able to tinker with exactly what I needed.
But my solution has some rather strange and annoying side effects: when I use it, Access instances don't really close but get invisible while keeping applications opened: I can't even make them visible again with .Visible= True, the action just don't work and I must kill them by hand. I have even seen remaining Access instances mixing in the task manager with the Excel instance Workbooks...
The fact is that I have very little knowledge of the Windows APIs that it implements: it's by chance if my solution works.
So I'm asking you here to help me finalize this code that does a simple thing, return a collection of Applications Access objects currently opened.
Here is the code:
Option Explicit
Private Declare Function GetDesktopWindow Lib "user32" () As Long
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 PtrSafe Function AccessibleObjectFromWindow Lib "oleacc" (ByVal hWnd As LongPtr, ByVal dwId As Long, riid As UUID, ppvObject As Object) As Long
Private Declare Function IIDFromString Lib "ole32" (ByVal lpsz As Long, ByRef lpiid As UUID) As Long
Private Type UUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Const IID_IDispatch As String = "{00020400-0000-0000-C000-000000000046}"
Private Const OBJID_NATIVEOM As Long = &HFFFFFFF0
Public Function AccessInstances() As Collection
Dim hWndDesk As LongPtr, hWnd As LongPtr
Dim iid As UUID, obj As Object
Dim acApp As Access.Application
Set AccessInstances = New Collection
hWndDesk = GetDesktopWindow
Do
hWnd = FindWindowEx(hWndDesk, hWnd, "OMain", vbNullString)
Call IIDFromString(StrPtr(IID_IDispatch), iid)
If AccessibleObjectFromWindow(hWnd, OBJID_NATIVEOM, iid, obj) = 0 Then
Set acApp = obj
AccessInstances.Add acApp
End If
Loop Until hWnd = 0
Set acApp = Nothing
End Function
The command that triggers the problems is AccessibleObjectFromWindow. I understand that there is an intermediate FindWindowEx call to do before invoking this command, but I ignore how it must be done, this totally out of my scope.
I thought that the Application Objects reserved by the collection could be what forces the application to stay open, but I never use them in a static or module level private variable, which implies that they are necessarily set to Nothing when the program stops, whether I do it myself explicitly or not, like in this example:
Sub ListAccessInstances()
Dim acApp As Access.Application
For Each acApp In AccessInstances
Debug.Print acApp.Name
Next
End Sub
Edit / additional information :
I was able to highlight the seemingly systematic problem that the function produces.
The principle is that the function produces side effects that do not exist when it is not used: Access instances remain open. A question that arises is whether or not these instances are empty. It seems to me that closing the last instance will totally close this leftover, but I am still uncertain when this may depend on the answer to the previous question.
The test procedure I have used is two-stage. A first procedure located in an Access database opens with the Shell command about ten other Access databases and a second one closes them (Getobject(aFile).Quit) . Thus an Access database remains always open.
The test consists in using or not using the incriminated function between the two procedures and to note what differs in the application manager, and also in the result of the function itself. This test is considered successful if there is no other instance left than the current one having used this function between the openings and closings. I remind you that this function is supposed to be purely readable and therefore without any consequence on the system.
1°) The test described above is generally positive: the instances are cleaned after they are closed. Nevertheless, I still saw one or two of them dragging.
2°) When you close the bases manually instead of using the closing procedure, the instances remain. Alexandru, could you try this test and tell me if you observe the same thing?
This is the demonstration, whose reproducibility I don't know yet, that the function does produce a system malfunction. In real work I had noticed that sometimes some instances still had their base (CurrentDb) open under the conditions I have described: locked in their invisibility. In fact, other visible effects in the task manager occur more or less randomly. For example to have an open and functional Access instance that does not appear in the task manager.
My approach to build this function has been very empirical. In particular, I learned from a code that allows the same thing with Excel. Since Excel is now mono-instance, I could not test this function, but I assume nevertheless that it is well written and that it works without side effects.
Here is the excerpt of the code we are interested in:
Function GetXLapp(hWinXL As Long, xlApp As Object) As Boolean
Dim hWinDesk As Long, hWin7 As Long
Dim obj As Object
Dim iid As GUID
Call IIDFromString(StrPtr(IID_IDispatch), iid)
hWinDesk = FindWindowEx(hWinXL, 0&, "XLDESK", vbNullString)
hWin7 = FindWindowEx(hWinDesk, 0&, "EXCEL7", vbNullString)
If AccessibleObjectFromWindow(hWin7, OBJID_NATIVEOM, iid, obj) = S_OK Then
Set xlApp = obj.Application
GetXLapp = True
End If
End Function
One can see that there are two successive window calls, this is the aspect I shunted in an experiment that was not supposed to work, but it still gave the result I have here. Functional, but producing instability. That's it, my question is whole, should we make this intermediate call with Access and if so how? Is it something else?, etc.
Try this
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
Public Function getAccessInstanceList() As Collection
Dim GUID&(0 To 3), acc As Object, hWnd
GUID(0) = &H20400
GUID(1) = &H0
GUID(2) = &HC0
GUID(3) = &H46000000
Set getAccessInstanceList = New Collection
Do
hWnd = FindWindowExA(0, hWnd, "OMain", vbNullString)
If hWnd = 0 Then Exit Do
If AccessibleObjectFromWindow(hWnd, &HFFFFFFF0, GUID(0), acc) = 0 Then
getAccessInstanceList.add acc.Application
End If
Loop
End Function
I am trying to find a specific window-class and want to send a custom message to it via a DNS command. I have trouble locating the window.
This is a working example for Notepad:
Declare Function FindWindow Lib "USER32" _
(ByVal lpszClassName As String, ByVal lpszWindow As String) As Long
Sub Main
Dim hWnd As Long
hWnd = FindWindow("Notepad", "Unbenannt - Editor") '<-- german title; change it
Debug.Print CStr(hWnd)
End Sub
However, It will not find the handle if I use the following:
hWnd = FindWindow("Notepad", vbNullString)
And I think it should. Here is the MSDN-Entry for it. It states, that the window name is optionally. Am I missing something?
I think that getting the window name is not an option in my case, as the target is an rich-edit-control which will not have a static window name as it send it's content rather than a static title (which is standard behavior). So I need to get this to work wthout supplying a window name.
I have a table of products where there is say a pdf for a specific products user manual. I'm storing the model name and it's file path in my products table (in Access). I've created a form in Access that allows the user to search by product name and it narrows down the number of files and shows the results from the search in a list box. However my biggest problem is opening the actual PDF. It opens the file, but I have to store the file path exactly how it is and the path of the files are long. Is there a way to open the PDF hyperlinks without using the Followhyperlink command? Or is there a way that I can show only the file name of the pdf in my list box rather than the entire path name? If I change the display text in my products table it doesn't open the hyperlink, I get an error. Any help would be greatly appreciated!
Application.FollowHyperLink() has problems with security, especially when opening files on a network drive. See e.g. here: http://blogannath.blogspot.de/2011/04/microsoft-access-tips-tricks-opening.html
A better method is the ShellExecute() API function.
Essentially it looks like this (trimmed from http://access.mvps.org/access/api/api0018.htm ):
' This code was originally written by Dev Ashish.
' http://access.mvps.org/access/api/api0018.htm
Private Declare Function apiShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" _
(ByVal hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) _
As Long
Public Const WIN_NORMAL = 1 'Open Normal
Private Const ERROR_SUCCESS = 32&
Public Function fHandleFile(stFile As String) As Boolean
Dim lRet As Long
lRet = apiShellExecute(hWndAccessApp(), "Open", stFile, vbNullString, vbNullString, WIN_NORMAL)
If lRet > ERROR_SUCCESS Then
' OK
fHandleFile = True
Else
Select Case lRet
' Handle various errors
End Select
fHandleFile = False
End If
End Function
Now for your listbox:
Set it to 2 columns, the first being the model name, the second the file path.
Set the column width of the second column to 0, so it will be invisible.
And in the doubleclick event, call fHandleFile with the second column (file path):
Private Sub lstManuals_DblClick(Cancel As Integer)
Call fHandleFile(Me.lstManuals.Column(1))
End Sub
I've been spending the last few hours trying to figure out how to save a file onto the computer using VBA. The code template below that I found on another forum seems promising, except when I go to the desktop to access it, the .csv file has what looks like the page's source code instead of the actual file I want. This may be because when I go to the URL, it doesn't automatically download the file; rather, I am asked to save the file to a certain location (since I don't know the path name of the uploaded file on the site).
Is there any way to alter this code to accommodate this, or will I have to use a different code entirely?
Sub Test()
Dim FileNum As Long
Dim FileData() As Byte
Dim MyFile As String
Dim WHTTP As Object
On Error Resume Next
Set WHTTP = CreateObject("WinHTTP.WinHTTPrequest.5")
If Err.Number <> 0 Then
Set WHTTP = CreateObject("WinHTTP.WinHTTPrequest.5.1")
End If
On Error GoTo 0
MyFile = "MY_URL_HERE"
WHTTP.Open "GET", MyFile, False
WHTTP.send
FileData = WHTTP.responseBody
Set WHTTP = Nothing
If Dir("C:\Users\BLAHBLAH\Desktop", vbDirectory) = Empty Then MkDir "C:\Users\BLAHBLAH\Desktop"
FileNum = FreeFile
Open "C:\Users\BLAHBLAH\Desktop\memberdatabase.csv" For Binary Access Write As #FileNum
Put #FileNum, 1, FileData
Close #FileNum
End Sub
Cross posts:
http://www.ozgrid.com/forum/showthread.php?t=178884
http://www.excelforum.com/excel-programming-vba-macros/925352-vba-go-to-website-and-download-file-from-save-prompt.html
I found over the years more ways how to save/download data using vba:
The firs option witch I prefer and would recommend is to use the URLDownloadToFile function of the user32 library using the following solution
The second one which was also mentioned be yourself. The point here is to use the Microsoft WinHTTP Services (Interop.WinHttp) COM library. In order to achieve this you can also add the Interop.WinHttp reference to your project link. After that you are able to use simpler notation like here link
The third option I aware is to ask the browser to save it for us and then using the Save_Over_Existing_Click_Yes function was mentioned by Santosh. In this case we open an Internet Explorer using the COM interface and navigate to the proper site. So we have to add the Microsoft Internet Controls (Interop.SHDocVw) and the Microsoft HTML Object Library (Microsoft.mshtml) references to our project in order to gain intellisense feature of the editor.
I don't like this download method because this is a work around by hacking. BUT if your IE session was already established authenticated etc. this gonna work nicely. The save function of the Internet Controls was dropped because of security concern. See for example: link
Newer the less you have to have the correct url to download what you want. If you pick the wrong one you will download something else :)
So please try to make sure the the url you use is correct by enter it in a browser. If it opens the right .csv file than your source could work too.
Also please try to send some more information: for example the url to the .csv file
Try below code :
Copied from here (Not tested)
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
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 SetForegroundWindow Lib "user32" Alias "SetForegroundWindow" (ByVal hwnd As Long) As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Declare Sub Sleep Lib "kernel32" Alias "Sleep" (ByVal dwMilliseconds As Long)
Private Sub Save_Over_Existing_Click_Yes()
Dim hWnd As Long
Dim timeout As Date
Debug.Print "Save_Over_Existing_Click_Yes"
'Find the Download complete window, waiting a maximum of 30 seconds for it to appear. Timeout value is dependent on the
'size of the download, so make it longer for bigger files
timeout = Now + TimeValue("00:00:30")
Do
hWnd = FindWindow(vbNullString, "Save As")
DoEvents
Sleep 200
Loop Until hWnd Or Now > timeout
Debug.Print " Save As window "; Hex(hWnd)
If hWnd Then
'Find the child Close button
hWnd = FindWindowEx(hWnd, 0, "Button", "&Yes")
Debug.Print " Yes button "; Hex(hWnd)
End If
If hWnd Then
'Click the Close button
SetForegroundWindow (hWnd)
Sleep 600 'this sleep is required and 600 miiliseconds seems to be the minimum that works
SendMessage hWnd, BM_CLICK, 0, 0
End If
End Sub
I have code that needs to run on both Excel 2003 and Excel 2007, and there are a few spots where changes in the versions cause the code to halt. I tried separating these lines out with If-Else statements, but the code won't compile on either because it doesn't recognize the code used for the other. Is there any way I could tell one version to ignore a block of code, similar to a C or C++-style #ifdef, in VBA?
This is a good starting point, but it won't work with the version of Excel that its running on, since that can only be figured out at run-time, not compile time.
If you need to branch your code based on information only discoverable at run time you might consider late binding as a solution. There are two ways you can sneak around version problems.
The first way can be used if you need to Access a property or method that only exists in certain versions, you can use CallByName. The advantage of call by name is that it allows you to preserve early binding (and intellisense) for your objects as much as possible.
To give an example, Excel 2007 has a new TintAndShade property. If you wanted to change the color of a range, and for Excel 2007 also ensure TintAndShade was set to 0 you would run into trouble because your code won't compile in Excel 2003 which does not have TintAndShade as a property of the range object. If you access the property that you know is not in all versions using CallByName, you code will compile in all versions fine, but only run in the versions you specify. See below:
Sub Test()
ColorRange Selection, Excel.Application.version, 6
End Sub
Sub ColorRange(rng As Excel.Range, version As Double, ParamArray args() As Variant)
With rng.Interior
.colorIndex = 6
.Pattern = xlSolid
If version >= 12# Then
'Because the property name is stored in a string this will still compile.
'And it will only get called if the correct version is in use.
CallByName rng.Interior, "TintAndShade", VbLet, 0
End If
End With
End Sub
The second way is for classes that have to be instantiated via "New" and don't even exist in old versions. You won't run into this problem with Excel, but I will give a quickie demo so you can see what I mean:
Imagine that you wanted to do File IO, and for some bizarre reason not all of the computers had the Microsoft Scripting Runtime on them. But for some equally bizarre reason you wanted to make sure it was used whenever it was available. If set a reference to it and use early binding in your code, the code won't compile on systems that don't have the file. So you use late binding instead:
Public Sub test()
Dim strMyString As String
Dim strMyPath As String
strMyPath = "C:\Test\Junk.txt"
strMyString = "Foo"
If LenB(Dir("C:\Windows\System32\scrrun.dll")) Then
WriteString strMyPath, strMyString
Else
WriteStringNative strMyPath, strMyString
End If
End Sub
Public Sub WriteString(ByVal path As String, ByVal value As String)
Dim fso As Object '<-Use generic object
'This is late binding:
Set fso = CreateObject("Scripting.FileSystemObject")
fso.CreateTextFile(path, True, False).Write value
End Sub
Public Sub WriteStringNative(ByVal path As String, ByVal value As String)
Dim lngFileNum As Long
lngFileNum = FreeFile
If LenB(Dir(path)) Then Kill path
Open path For Binary Access Write Lock Read Write As #lngFileNum
Put #lngFileNum, , value
Close #lngFileNum
End Sub
There is a comprehensive list of all Adds and Changes to Excel Object Model since 2003:
http://msdn.microsoft.com/en-us/library/bb149069.aspx
For changes between 1997 and 2000 go here:
http://msdn.microsoft.com/en-us/library/aa140068(office.10).aspx
Yes it is possible to do conditional compilation in Excel VBA. Below is a brief resource and some example code:
Conditional Compilation
#If Win32 Then
' Profile String functions:
Private Declare Function WritePrivateProfileString Lib "KERNEL32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
Private Declare Function GetPrivateProfileString Lib "KERNEL32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As Any, ByVal lpKeyName As Any, ByVal lpDefault As Any, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
#Else
' Profile String functions:
Private Declare Function WritePrivateProfileString Lib "Kernel" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Integer
Private Declare Function GetPrivateProfileString Lib "Kernel" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As Any, ByVal lpReturnedString As String, ByVal nSize As Integer, ByVal lpFileName As String) As Integer
#End If
Can you post the offending lines of code?
If it is a constant like vbYes or xlFileFormat or whatever, use the corresponding numeric value.
Show me what you got, I'll see if I can refactor it.
Bill