Make VBA wait until batch file is finished - vba

I am using VBA in my Access DB to launch a batch file which is linked to PS1 script.
That all works as intended. The issue is that I want to run some queries after that action is completed, but as it stands I need to babysit the whole thing. So I am looking for a solution to keep the VBA paused while the batch is running.
I found this article: https://danwagner.co/how-to-run-a-batch-file-and-wait-until-it-finishes-with-vba/
But the solution doesn't work for me for some reason. The batch runs, but the VBA just steams on ahead without pausing.
Here is my code:
Private Sub Button_UpdateOffline_Click()
Dim strCommand As String
Dim lngErrorCode As Long
Dim wsh As WshShell
Set wsh = New WshShell
DoCmd.OpenForm "Please_Wait"
'Run the batch file using the WshShell object
strCommand = Chr(34) & _
"C:\Users\Rip\Q_Update.bat" & _
Chr(34)
lngErrorCode = wsh.Run(strCommand, _
WindowStyle:=0, _
WaitOnReturn:=True)
If lngErrorCode <> 0 Then
MsgBox "Uh oh! Something went wrong with the batch file!"
Exit Sub
End If
DoCmd.Close acForm, "Please_Wait"
End Sub
Here is my batch code if that helps:
START PowerShell.exe -ExecutionPolicy Bypass -Command "& 'C:\Users\Rip\PS1\OfflineFAQ_Update.ps1' "

Your batch code launches PowerShell, then closes.
VBA waits until your batch code has launched PowerShell, then continues. It has no way to know you actually want to wait until PowerShell has finished, since if you want to wait on that, you'd have to make your batch script wait as well.
So, either change the batch code to include /WAIT, in addition to the changes suggested in the comments:
START /wait PowerShell.exe -ExecutionPolicy Bypass -Command "& 'C:\Users\Rip\PS1\OfflineFAQ_Update.ps1' "
Or, open PowerShell directly without the batch file in between:
strCommand = "PowerShell.exe -ExecutionPolicy Bypass -Command ""& 'C:\Users\Rip\PS1\OfflineFAQ_Update.ps1' """

Use the WaitForSingleObject API call. It takes a bit lengthy code, but is very simple to implement when wrapped in a function like ShellWait below.
This way, you can call the PowerShell command directly as in this example:
' Unblock a file or all files of a folder.
'
' 2022-10-18. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function UnblockFiles( _
ByVal Path As String) _
As Boolean
Const CommandMask As String = "PowerShell -command {0}"
Const ArgumentMask As String = "Dir ""{0}"" -Recurse | Unblock-File"
Const WindowStyle As Long = VbAppWinStyle.vbHide
Dim Argument As String
Dim Command As String
Dim Result As Long
Dim Success As Boolean
If Dir(Path, vbDirectory) = "" Then
' Path is neither a file nor a folder.
Else
' Continue.
Argument = Replace(ArgumentMask, "{0}", Path)
Command = Replace(CommandMask, "{0}", Argument)
Result = ShellWait(Command, WindowStyle)
Success = Not CBool(Result)
End If
UnblockFiles = Success
End Function
You'll see, that the command is assembled from the top two constants and a variable. You should be able to modify those for your command.
The ShellWait I use:
' General constants.
'
' Wait forever.
Private Const Infinite As Long = &HFFFF
' Process Security and Access Rights.
'
' The right to use the object for synchronization.
' This enables a thread to wait until the object is in the signaled state.
Private Const Synchronize As Long = &H100000
' Constants for WaitForSingleObject.
'
' The specified object is a mutex object that was not released by the thread
' that owned the mutex object before the owning thread terminated.
' Ownership of the mutex object is granted to the calling thread and the
' mutex state is set to nonsignaled.
Private Const StatusAbandonedWait0 As Long = &H80
Private Const WaitAbandoned As Long = StatusAbandonedWait0 + 0
' The state of the specified object is signaled.
Private Const StatusWait0 As Long = &H0
Private Const WaitObject0 As Long = StatusWait0 + 0
' The time-out interval elapsed, and the object's state is nonsignaled.
Private Const WaitTimeout As Long = &H102
' The function has failed. To get extended error information, call GetLastError.
Private Const WaitFailed As Long = &HFFFFFFFF
' Missing enum when using late binding.
'
#If EarlyBinding = False Then
Public Enum IOMode
ForAppending = 8
ForReading = 1
ForWriting = 2
End Enum
#End If
' API declarations.
' Opens an existing local process object.
' If the function succeeds, the return value is an open handle
' to the specified process.
' If the function fails, the return value is NULL (0).
' To get extended error information, call GetLastError.
'
#If VBA7 Then
Private Declare PtrSafe Function OpenProcess Lib "kernel32" ( _
ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) _
As LongPtr
#Else
Private Declare Function OpenProcess Lib "kernel32" ( _
ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) _
As Long
#End If
' The WaitForSingleObject function returns when one of the following occurs:
' - the specified object is in the signaled state.
' - the time-out interval elapses.
'
' The dwMilliseconds parameter specifies the time-out interval, in milliseconds.
' The function returns if the interval elapses, even if the object's state is
' nonsignaled.
' If dwMilliseconds is zero, the function tests the object's state and returns
' immediately.
' If dwMilliseconds is Infinite, the function's time-out interval never elapses.
'
#If VBA7 Then
Private Declare PtrSafe Function WaitForSingleObject Lib "kernel32" ( _
ByVal hHandle As LongPtr, _
ByVal dwMilliseconds As Long) _
As Long
#Else
Private Declare Function WaitForSingleObject Lib "kernel32" ( _
ByVal hHandle As Long, _
ByVal dwMilliseconds As Long) _
As Long
#End If
' Closes an open object handle.
' If the function succeeds, the return value is nonzero.
' If the function fails, the return value is zero.
' To get extended error information, call GetLastError.
'
#If VBA7 Then
Private Declare PtrSafe Function CloseHandle Lib "kernel32" ( _
ByVal hObject As LongPtr) _
As Long
#Else
Private Declare Function CloseHandle Lib "kernel32" ( _
ByVal hObject As Long) _
As Long
#End If
' Shells out to an external process and waits until the process ends.
' Returns 0 (zero) for no errors, or an error code.
'
' The call will wait for an infinite amount of time for the process to end.
' The process will seem frozen until the shelled process terminates. Thus,
' if the shelled process hangs, so will this.
'
' A better approach could be to wait a specific amount of time and, when the
' time-out interval expires, test the return value. If it is WaitTimeout, the
' process is still not signaled. Then either wait again or continue with the
' processing.
'
' Waiting for a DOS application is different, as the DOS window doesn't close
' when the application is done.
' To avoid this, prefix the application command called (shelled to) with:
' "command.com /c " or "cmd.exe /c ".
'
' For example:
' Command = "cmd.exe /c " & Command
' Result = ShellWait(Command)
'
' 2018-04-06. Gustav Brock. Cactus Data ApS, CPH.
'
Public Function ShellWait( _
ByVal Command As String, _
Optional ByVal WindowStyle As VbAppWinStyle = vbNormalNoFocus) _
As Long
Const InheritHandle As Long = &H0
Const NoProcess As Long = 0
Const NoHandle As Long = 0
#If VBA7 Then
Dim ProcessHandle As LongPtr
#Else
Dim ProcessHandle As Long
#End If
Dim DesiredAccess As Long
Dim ProcessId As Long
Dim WaitTime As Long
Dim Closed As Boolean
Dim Result As Long
If Len(Trim(Command)) = 0 Then
' Nothing to do. Exit.
Else
ProcessId = Shell(Command, WindowStyle)
If ProcessId = NoProcess Then
' Process could not be started.
Else
' Get a handle to the shelled process.
DesiredAccess = Synchronize
ProcessHandle = OpenProcess(DesiredAccess, InheritHandle, ProcessId)
' Wait "forever".
WaitTime = Infinite
' If successful, wait for the application to end and close the handle.
If ProcessHandle = NoHandle Then
' Should not happen.
Else
' Process is running.
Result = WaitForSingleObject(ProcessHandle, WaitTime)
' Process ended.
Select Case Result
Case WaitObject0
' Success.
Case WaitAbandoned, WaitTimeout, WaitFailed
' Know error.
Case Else
' Other error.
End Select
' Close process.
Closed = CBool(CloseHandle(ProcessHandle))
If Result = WaitObject0 Then
' Return error if not closed.
Result = Not Closed
End If
End If
End If
End If
ShellWait = Result
End Function

Related

How to pass parameters between vba and vb

I'm making a tool, where I need to start a programm (which I want to code with VB) by using VBA in an Excle file. When I close that programm, it should give back a parameter to the VBA script.
I started just now with the VBA script and didn't code anything of the VB programm yet. But I need to know, what to write in the VBA script and wheter this is possible.
So it should work like this:
I'm in the Excel file and I press a button
The programm is starting (also getting a parameter from the Excel file, this is not that important yet)
In that programm I configurate some stuff
Closing that Programm it should give back a ID of that configuration
I'm getting back to the Excel file with this ID
Is this possible? And what do I need to write in the VBA script and in the Programm to give back a parameter?
I hope you understand what I mean and you can help me
You could set your VB .exe to return an Exit code. Just make sure the id isn't 0 (means ran successfully) or 259 (calling process will think process is still running). The VBA below runs an .exe, waits for it to close, then returns the exit code.
Option Explicit
' Api declarations
Private Declare Function GetExitCodeProcess Lib "Kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Private Declare Function OpenProcess Lib "Kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Public Function RunProgram(ByVal strFilename As String) As Long
'# PURPOSE: Run a program, wait until closed, and return the exit code
Dim TaskID As Long
Dim hProc As Long
Dim lExitCode As Long
Const ACCESS_TYPE = &H400
Const STILL_ACTIVE = &H103
' Open the program
TaskID = Shell(strFilename, 1)
hProc = OpenProcess(ACCESS_TYPE, False, TaskID)
If Err <> 0 Then
Debug.Print "Cannot start " & strFilename, vbCritical, "Error"
Exit Function
End If
' Wait until program is closed
Do
GetExitCodeProcess hProc, lExitCode
DoEvents
Loop While lExitCode = STILL_ACTIVE
' Return the program's exit code
RunProgram = lExitCode
End Function

Which script is better for automation of PTC Integrity application

I want to create one script that will open the windows application and use that application to perform some task. I have listed out the activity that I want to automate below:
Application is PTC integrity. It is linked with database server that has lot of files in it which have unique ID. So I need to use ID to open the document and export it.
Steps:
Open the application.
Open the document using ID.
Export the document to some specific format.
I want to know which scripting to be used to automate this process, i.e., I give array of IDs , the script will open the application and then open the document using IDs and export them till all the IDs are exported. Using Excel VBA can it be done.
Yes you can do this in VBA.
Your VBA can call a batch file via the Shell command that uses PTC Integrity Command Line Interface.
To export a document you can use the 'im exportissues' CLI command.
To call a batch file synchronously you can use the ShellandWait function below or see related StackOverflow question.
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess _
As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle _
As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Sub ShellAndWait(ByVal program_name As String, _
Optional ByVal window_style As VbAppWinStyle = vbNormalFocus, _
Optional ByVal max_wait_seconds As Long = 0)
'http://www.vbforums.com/showthread.php?t=505172
' Example:
' Private Sub Form_Load()
' Me.Show
' ShellAndWait "Notepad.exe", , 3
' Me.Caption = "done"
' End Sub
Dim lngProcessId As Long
Dim lngProcessHandle As Long
Dim datStartTime As Date
Const WAIT_TIMEOUT = &H102
Const SYNCHRONIZE As Long = &H100000
Const INFINITE As Long = &HFFFFFFFF
' Start the program.
On Error GoTo ShellError
lngProcessId = Shell(program_name, window_style)
On Error GoTo 0
DoEvents
' Wait for the program to finish.
' Get the process handle.
lngProcessHandle = OpenProcess(SYNCHRONIZE, 0, lngProcessId)
If lngProcessHandle <> 0 Then
datStartTime = Now
Do
If WaitForSingleObject(lngProcessHandle, 250) <> WAIT_TIMEOUT Then
Exit Do
End If
DoEvents
If max_wait_seconds > 0 Then
If DateDiff("s", datStartTime, Now) > max_wait_seconds Then Exit Do
End If
Loop
CloseHandle lngProcessHandle
End If
Exit Sub
ShellError:
End Sub
I Prefer Python to automate multiple processes in PTC.You can use CLI commands for all your operations.Run those CLI commands from Python using subprocess method. Get your output in your preferable format.

Environ("USERNAME") in VBA returns "User" after Windows 8 upgrade

I have an Access database that needs to check the username of the user using Environ("USERNAME").
While this works for my users who are using Win7, I have recently upgraded to Win8 and the code returns the text "User" on my laptop. I have also tried CreateObject("WScript.Network").Username with the same result.
Is this a windows 8 thing and will I have a problem when the other users upgrade?
Is there a way that I can change/configure this "User" text? My laptop is not connected to the corporate network that the other users are using so it may be that when they upgrade to Win8 their laptops will return the correct network username.
I would use this Windows API call:
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" _
(ByVal lpBuffer As String, nSize As Long) As Long
Public Function GetWindowsUserName() As String
Dim strUserName As String
strUserName = String(100, Chr$(0))
GetUserName strUserName, 100
GetWindowsUserName = Left$(strUserName, InStr(strUserName, Chr$(0)) - 1)
End Function
You should be able to do this using a WMI query.
Function GetFullName() As String
Dim computer As String
computer = "."
Dim objWMIService, colProcessList As Object
Set objWMIService = GetObject("winmgmts:\\" & computer & "\root\cimv2")
Set colProcessList = objWMIService.ExecQuery _
("SELECT TOP 1 * FROM Win32_Process WHERE Name = 'ACCESS.EXE'")
Dim uname, udomain As String
Dim objProcess As Object
For Each objProcess In colProcessList
objProcess.GetOwner uname, udomain
Next
GetFullName = UCase(udomain) & "\" & UCase(uname)
End Function
If you don't need the context, just remove "UCase(udomain) & "\" &"
I have been using the following module for a few months now. It ultimatly returns the full name of the current user, but you are ofcourse able to get all the data you need.
This code has never failed me before, including windows 8 if I'm not mistaking.
You can call the code with "GetFullNameOfLoggedUser()"
Please note that this is not my code! I have not been able to retrace where I found the code, so if someone knows, please comment to give him the credit!
Private Type ExtendedUserInfo
EUI_name As Long
EUI_password As Long ' Null, only settable
EUI_password_age As Long
EUI_priv As Long
EUI_home_dir As Long
EUI_comment As Long
EUI_flags As Long
EUI_script_path As Long
EUI_auth_flags As Long
EUI_full_name As Long
EUI_usr_comment As Long
EUI_parms As Long
EUI_workstations As Long
EUI_last_logon As Long
EUI_last_logoff As Long
EUI_acct_expires As Long
EUI_max_storage As Long
EUI_units_per_week As Long
EUI_logon_hours As Long
EUI_bad_pw_count As Long
EUI_num_logons As Long
EUI_logon_server As Long
EUI_country_code As Long
EUI_code_page As Long
End Type
'Windows API function declarations
Private Declare Function apiNetGetDCName Lib "netapi32.dll" _
Alias "NetGetDCName" (ByVal servername As Long, _
ByVal DomainName As Long, _
bufptr As Long) As Long
' function frees the memory that the NetApiBufferAllocate function allocates.
Private Declare Function apiNetAPIBufferFree Lib "netapi32.dll" _
Alias "NetApiBufferFree" (ByVal buffer As Long) As Long
' Retrieves the length of the specified Unicode string.
Private Declare Function apilstrlenW Lib "kernel32" _
Alias "lstrlenW" (ByVal lpString As Long) As Long
Private Declare Function apiNetUserGetInfo Lib "netapi32.dll" _
Alias "NetUserGetInfo" (servername As Any, _
username As Any, _
ByVal level As Long, _
bufptr As Long) As Long
' moves memory either forward or backward, aligned or unaligned,
' in 4-byte blocks, followed by any remaining bytes
Private Declare Sub sapiCopyMem Lib "kernel32" _
Alias "RtlMoveMemory" (Destination As Any, _
Source As Any, _
ByVal Length As Long)
Private Declare Function apiGetUserName Lib "advapi32.dll" _
Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Const MAXCOMMENTSZ = 256
Private Const NERR_SUCCESS = 0
Private Const ERROR_MORE_DATA = 234&
Private Const MAX_CHUNK = 25
Private Const ERROR_SUCCESS = 0&
Function GetFullNameOfLoggedUser(Optional strUserName As String) As String
'
' Returns the full name for a given network username (NT/2000/XP only)
' Omitting the argument will retrieve the full name for the currently logged on user
'
On Error GoTo Err_GetFullNameOfLoggedUser
Dim pBuf As Long
Dim dwRec As Long
Dim pTmp As ExtendedUserInfo
Dim abytPDCName() As Byte
Dim abytUserName() As Byte
Dim lngRet As Long
Dim i As Long
' Unicode
abytPDCName = GetDCName() & vbNullChar
If (Len(strUserName) = 0) Then
strUserName = GetUserName()
End If
abytUserName = strUserName & vbNullChar
' Level 2
lngRet = apiNetUserGetInfo(abytPDCName(0), abytUserName(0), 2, pBuf)
If (lngRet = ERROR_SUCCESS) Then
Call sapiCopyMem(pTmp, ByVal pBuf, Len(pTmp))
GetFullNameOfLoggedUser = StrFromPtrW(pTmp.EUI_full_name)
gvusername = abytUserName
End If
Call apiNetAPIBufferFree(pBuf)
Exit_GetFullNameOfLoggedUser:
Exit Function
Err_GetFullNameOfLoggedUser:
MsgBox Err.Description, vbExclamation
GetFullNameOfLoggedUser = vbNullString
Resume Exit_GetFullNameOfLoggedUser
End Function
Private Function GetUserName() As String
' Returns the network login name
Dim lngLen As Long, lngRet As Long
Dim strUserName As String
strUserName = String$(254, 0)
lngLen = 255
lngRet = apiGetUserName(strUserName, lngLen)
If lngRet Then
GetUserName = Left$(strUserName, lngLen - 1)
End If
End Function
Function GetDCName() As String
Dim pTmp As Long
Dim lngRet As Long
Dim abytBuf() As Byte
lngRet = apiNetGetDCName(0, 0, pTmp)
If lngRet = NERR_SUCCESS Then
GetDCName = StrFromPtrW(pTmp)
End If
Call apiNetAPIBufferFree(pTmp)
End Function
Private Function StrFromPtrW(pBuf As Long) As String
Dim lngLen As Long
Dim abytBuf() As Byte
' Get the length of the string at the memory location
lngLen = apilstrlenW(pBuf) * 2
' if it's not a ZLS
If lngLen Then
ReDim abytBuf(lngLen)
' then copy the memory contents
' into a temp buffer
Call sapiCopyMem(abytBuf(0), ByVal pBuf, lngLen)
' return the buffer
StrFromPtrW = abytBuf
End If
End Function

VB.NET Wait a DOS shell program to terminate before continuing- doesn't work

I am building a Windows Forms Application on VS2010, through which I need to execute a 3d party DOS shell program (OpenSees.exe), open a source file in it and perform an analysis. After this, some output files are created which I need to read again in my VB.NET app.
The thing is that the analysis in OpenSees may take a long time, so the VB code has to wait for it before carrying on.
For this, I have tried both "ShellandWait" sub along with "WaitForSingleObject" function and "process class" option, but neither of then works.
My DOS shell program initializes, but it closes almost immediately, not letting the analysis to complete and the required output to be created.
Here are the code snippets I used:
1st try: ShellandWait
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess _
As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle _
As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Sub ShellAndWait(ByVal program_name As String, _
Optional ByVal window_style As AppWinStyle = vbNormalFocus, _
Optional ByVal max_wait_seconds As Long = 0)
Dim lngProcessId As Long
Dim lngProcessHandle As Long
Dim datStartTime As Date
Const WAIT_TIMEOUT = &H102
Const SYNCHRONIZE As Long = &H100000
Const INFINITE As Long = &HFFFFFFFF
' Start the program.
On Error GoTo ShellError
lngProcessId = Shell(program_name, window_style)
On Error GoTo 0
Threading.Thread.Sleep(1500)
'System.Windows.Forms.Application.DoEvents()
SendKeys.Send("source " & filename & ".tcl")
SendKeys.Send("{ENTER}")
' Wait for the program to finish.
' Get the process handle.
lngProcessHandle = OpenProcess(SYNCHRONIZE, 0, lngProcessId)
If lngProcessHandle <> 0 Then
datStartTime = Now
Do
If WaitForSingleObject(lngProcessHandle, 250) <> WAIT_TIMEOUT Then
Exit Do
End If
'DoEvents()
If max_wait_seconds > 0 Then
If DateDiff("s", datStartTime, Now) > max_wait_seconds Then Exit Do
End If
Loop
CloseHandle(lngProcessHandle)
End If
Exit Sub
ShellError:
End Sub
...
ShellAndWait("OpenSees.exe", , 3)
2nd try: ProcessStart
Dim p As New Process
Dim psi As New ProcessStartInfo("OpenSees.exe", "source " & filename & ".tcl")
p.StartInfo = psi
p.Start()
p.WaitForExit()
I don't understand why this isn't working. Any help would be much appreciated!
Try this:
Shell("OpenSees.exe <arguments>",, True)

Open an html page in default browser with VBA?

How do I open an HTML page in the default browser with VBA? I know it's something like:
Shell "http://myHtmlPage.com"
But I think I have to reference the program which will open the page.
You can use the Windows API function ShellExecute to do so:
Option Explicit
Private Declare Function ShellExecute _
Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hWnd As Long, _
ByVal Operation As String, _
ByVal Filename As String, _
Optional ByVal Parameters As String, _
Optional ByVal Directory As String, _
Optional ByVal WindowStyle As Long = vbMinimizedFocus _
) As Long
Public Sub OpenUrl()
Dim lSuccess As Long
lSuccess = ShellExecute(0, "Open", "www.google.com")
End Sub
As given in comment, to make it work in 64-bit, you need add PtrSafe in the Private Declare Line as shown below:
Private Declare PtrSafe Function ShellExecute _
Just a short remark concerning security: If the URL comes from user input make sure to strictly validate that input as ShellExecute would execute any command with the user's permissions, also a format c: would be executed if the user is an administrator.
You can even say:
FollowHyperlink "www.google.com"
If you get Automation Error then use http://:
ThisWorkbook.FollowHyperlink("http://www.google.com")
If you want a more robust solution with ShellExecute that will open ANY file, folder or URL using the default OS associated program to do so, here is a function taken from http://access.mvps.org/access/api/api0018.htm:
'************ Code Start **********
' This code was originally written by Dev Ashish.
' It is not to be altered or distributed,
' except as part of an application.
' You are free to use it in any application,
' provided the copyright notice is left unchanged.
'
' Code Courtesy of
' Dev Ashish
'
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
'***App Window Constants***
Public Const WIN_NORMAL = 1 'Open Normal
Public Const WIN_MAX = 3 'Open Maximized
Public Const WIN_MIN = 2 'Open Minimized
'***Error Codes***
Private Const ERROR_SUCCESS = 32&
Private Const ERROR_NO_ASSOC = 31&
Private Const ERROR_OUT_OF_MEM = 0&
Private Const ERROR_FILE_NOT_FOUND = 2&
Private Const ERROR_PATH_NOT_FOUND = 3&
Private Const ERROR_BAD_FORMAT = 11&
'***************Usage Examples***********************
'Open a folder: ?fHandleFile("C:\TEMP\",WIN_NORMAL)
'Call Email app: ?fHandleFile("mailto:dash10#hotmail.com",WIN_NORMAL)
'Open URL: ?fHandleFile("http://home.att.net/~dashish", WIN_NORMAL)
'Handle Unknown extensions (call Open With Dialog):
' ?fHandleFile("C:\TEMP\TestThis",Win_Normal)
'Start Access instance:
' ?fHandleFile("I:\mdbs\CodeNStuff.mdb", Win_NORMAL)
'****************************************************
Function fHandleFile(stFile As String, lShowHow As Long)
Dim lRet As Long, varTaskID As Variant
Dim stRet As String
'First try ShellExecute
lRet = apiShellExecute(hWndAccessApp, vbNullString, _
stFile, vbNullString, vbNullString, lShowHow)
If lRet > ERROR_SUCCESS Then
stRet = vbNullString
lRet = -1
Else
Select Case lRet
Case ERROR_NO_ASSOC:
'Try the OpenWith dialog
varTaskID = Shell("rundll32.exe shell32.dll,OpenAs_RunDLL " _
& stFile, WIN_NORMAL)
lRet = (varTaskID <> 0)
Case ERROR_OUT_OF_MEM:
stRet = "Error: Out of Memory/Resources. Couldn't Execute!"
Case ERROR_FILE_NOT_FOUND:
stRet = "Error: File not found. Couldn't Execute!"
Case ERROR_PATH_NOT_FOUND:
stRet = "Error: Path not found. Couldn't Execute!"
Case ERROR_BAD_FORMAT:
stRet = "Error: Bad File Format. Couldn't Execute!"
Case Else:
End Select
End If
fHandleFile = lRet & _
IIf(stRet = "", vbNullString, ", " & stRet)
End Function
'************ Code End **********
Just put this into a separate module and call fHandleFile() with the right parameters.
I find the most simple is
shell "explorer.exe URL"
This also works to open local folders.
You need to call ShellExecute.