Solved

Calling default programs for Win NT users

Posted on 1998-10-30
2
155 Views
Last Modified: 2010-04-30
Hi All,

I have a subroutine in my VB6 program where I want to shell to MS Exchange (exchng32.exe) on a Win NT 4 users system, however, not all users have the program on the same drive.  How do I get this path and pass it in code to open the program properly for all users?  Code would be helpful!
Thanks!
0
Comment
Question by:KIRK50
2 Comments
 
LVL 14

Accepted Solution

by:
waty earned 20 total points
ID: 1442561
You could use the associated file to MSExchange :
   FindExecutable, ExecuteWithAssociate

Option Explicit

' File and Disk functions.
Private Const DRIVE_CDROM = 5
Private Const DRIVE_FIXED = 3
Private Const DRIVE_RAMDISK = 6
Private Const DRIVE_REMOTE = 4
Private Const DRIVE_REMOVABLE = 2
Private Const DRIVE_UNKNOWN = 0    'Unknown, or unable to be determined.

Private Declare Function GetDriveTypeA Lib "kernel32" (ByVal nDrive As String) As Long

Private Declare Function GetVolumeInformation& Lib "kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal pVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long)
Private Declare Function GetWindowsDirectoryA Lib "kernel32" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function GetTempPathA Lib "kernel32" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function GetTempFileNameA Lib "kernel32" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
Private Declare Function GetSystemDirectoryA Lib "kernel32" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

Private Const UNIQUE_NAME = &H0

Private Declare Function ShellExecute 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

Private Const SW_HIDE = 0             ' = vbHide
Private Const SW_SHOWNORMAL = 1       ' = vbNormal
Private Const SW_SHOWMINIMIZED = 2    ' = vbMinimizeFocus
Private Const SW_SHOWMAXIMIZED = 3    ' = vbMaximizedFocus
Private Const SW_SHOWNOACTIVATE = 4   ' = vbNormalNoFocus
Private Const SW_MINIMIZE = 6         ' = vbMinimizedNofocus

Private Declare Function GetShortPathNameA Lib "kernel32" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long

Private Type SHFILEOPSTRUCT
   hwnd           As Long
   wFunc          As Long
   pFrom          As String
   pTo            As String
   fFlags         As Integer
   fAborted       As Boolean
   hNameMaps      As Long
   sProgress      As String
End Type

Private Const FO_DELETE = &H3
Private Const FOF_ALLOWUNDO = &H40
Private Const FOF_SILENT = &H4
Private Const FOF_NOCONFIRMATION = &H10

Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long

Private Type STARTUPINFO
   cb                As Long
   lpReserved        As String
   lpDesktop         As String
   lpTitle           As String
   dwX               As Long
   dwY               As Long
   dwXSize           As Long
   dwYSize           As Long
   dwXCountChars     As Long
   dwYCountChars     As Long
   dwFillAttribute   As Long
   dwFlags           As Long
   wShowWindow       As Integer
   cbReserved2       As Integer
   lpReserved2       As Long
   hStdInput         As Long
   hStdOutput        As Long
   hStdError         As Long
End Type

Private Type PROCESS_INFORMATION
   hProcess As Long
   hThread As Long
   dwProcessID As Long
   dwThreadID As Long
End Type

Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const INFINITE = -1&
Private Const SYNCHRONIZE = &H100000

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 CreateProcessA Lib "kernel32" (ByVal lpApplicationName As Long, ByVal lpCommandLine As String, ByVal lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function FindExecutableA Lib "shell32.dll" (ByVal lpFile As String, ByVal lpdirectory As String, ByVal lpResult As String) As Long
Private Declare Function SetVolumeLabelA Lib "kernel32" (ByVal lpRootPathName As String, ByVal lpVolumeName As String) As Long

' *** Get running applications
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long

Const GW_CHILD = 5
Const GW_HWNDFIRST = 0
Const GW_HWNDLAST = 1
Const GW_HWNDNEXT = 2
Const GW_HWNDPREV = 3
Const GW_MAX = 5
Const GW_OWNER = 4

' *** Infos about files
Private Declare Function OpenFile Lib "kernel32" (ByVal lpFileName As String, lpReOpenBuff As OFSTRUCT, ByVal wStyle As Long) As Long
Private Declare Function GetFileInformationByHandle Lib "kernel32" (ByVal hFile As Long, lpFileInformation As BY_HANDLE_FILE_INFORMATION) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Public Const OFS_MAXPATHNAME = 128
Public Const OF_READ = &H0

Type OFSTRUCT
   cBytes As Byte
   fFixedDisk As Byte
   nErrCode As Integer
   Reserved1 As Integer
   Reserved2 As Integer
   szPathName(OFS_MAXPATHNAME) As Byte
End Type

Type FILETIME
   dwLowDateTime As Long
   dwHighDateTime As Long
End Type

Type BY_HANDLE_FILE_INFORMATION
   dwFileAttributes As Long
   ftCreationTime As FILETIME
   ftLastAccessTime As FILETIME
   ftLastWriteTime As FILETIME
   dwVolumeSerialNumber As Long
   nFileSizeHigh As Long
   nFileSizeLow As Long
   nNumberOfLinks As Long
   nFileIndexHigh As Long
   nFileIndexLow As Long
End Type

' *** RegisterAsServiceProcess
Public Declare Function RegisterServiceProcess Lib "kernel32.dll" (ByVal dwProcessID As Long, ByVal dwType As Long) As Long
Public Declare Function GetCurrentProcessId Lib "kernel32.dll" () As Long

Public Function FindExecutable(s As String) As String
   '  Finds the executable associated with a file
   '
   '  Returns "" if no file is found.
   
   Dim i As Integer
   Dim s2 As String

   s2 = String(256, 32) & Chr$(0)

   i = FindExecutableA(s & Chr$(0), vbNullString, s2)

   If i > 32 Then
      FindExecutable = Left$(s2, InStr(s2, Chr$(0)) - 1)
   Else
      FindExecutable = ""
   End If

End Function

Public Function ShellDelete(ParamArray vntFileName() As Variant) As Boolean
   '
   '  Deletes a single file, or an array of files to the trashcan.
   '
   Dim i As Integer
   Dim sFileNames As String
   Dim SHFileOp As SHFILEOPSTRUCT

   For i = LBound(vntFileName) To UBound(vntFileName)
      sFileNames = sFileNames & vntFileName(i) & vbNullChar
   Next

   sFileNames = sFileNames & vbNullChar

   With SHFileOp
      .wFunc = FO_DELETE
      .pFrom = sFileNames
      .fFlags = FOF_ALLOWUNDO + FOF_SILENT + FOF_NOCONFIRMATION
   End With

   i = SHFileOperation(SHFileOp)

   If i = 0 Then
      ShellDelete = True
   Else
      ShellDelete = False
   End If
   
End Function

Public Function ShellWait(cCommandLine As String) As Boolean
   ' #VBIDEUtils#************************************************************
   ' * Programmer Name  : Waty Thierry
   ' * Web Site         : www.geocities.com/ResearchTriangle/6311/
   ' * E-Mail           : waty.thierry@usa.net
   ' * Date             : 2/10/98
   ' * Time             : 09:48
   ' * Module Name      : Execute_Module
   ' * Module Filename  : Execute.bas
   ' * Procedure Name   : ShellWait
   ' * Parameters       :
   ' *                    cCommandLine As String
   ' **********************************************************************
   ' * Comments         :
   ' * Runs a command as the Shell command does but waits for the command
   ' * to finish before returning.  Note: The full path and filename extention
   ' * is required.
   ' * You might want to use Environ$("COMSPEC") & " /c " & command
   ' * if you wish to run it under the command shell (and thus it)
   ' * will search the path etc...
   ' *
   ' * returns false if the shell failed
   ' *
   ' **********************************************************************
   
   Dim NameOfProc    As PROCESS_INFORMATION
   Dim NameStart     As STARTUPINFO
   Dim i             As Long

   NameStart.cb = Len(NameStart)
   i = CreateProcessA(0&, cCommandLine, 0&, 0&, 1&, NORMAL_PRIORITY_CLASS, 0&, 0&, NameStart, NameOfProc)

   If i <> 0 Then
      Call WaitForSingleObject(NameOfProc.hProcess, INFINITE)
      Call CloseHandle(NameOfProc.hProcess)
      ShellWait = True
   Else
      ShellWait = False
   End If

End Function

Public Sub MonitorProcess(sProcess As String)
   ' *** check if another application is still running

   Dim pId        As Long
   Dim pHnd       As Long

   pId = Shell(sProcess, vbNormalFocus)

   pHnd = OpenProcess(SYNCHRONIZE, 0, pId) ' get Process Handle
   If pHnd <> 0 Then
      Call WaitForSingleObject(pHnd, INFINITE) ' Wait until shelled prog ends
      Call CloseHandle(pHnd)
   End If

End Sub

Public Function ExecuteWait(s As String, Optional Param As Variant) As Boolean
   '
   '  As the Execute function but waits for the process to finish before
   '  returning
   '
   '  returns true on success.
   
   Dim s2 As String

   s2 = FindExecutable(s)

   If s2 <> "" Then
      ExecuteWait = ShellWait(s2 & IIf(IsMissing(Param), " ", " " & CStr(Param) & " ") & s)
   Else
      ExecuteWait = False
   End If
   
End Function

Public Function AddBackslash(s As String) As String
   '
   '  Adds a backslash if the string doesn't have one already.
   '
   
   If Len(s) > 0 Then
      If Right$(s, 1) <> "\" Then
         AddBackslash = s + "\"
      Else
         AddBackslash = s
      End If
   Else
      AddBackslash = "\"
   End If

End Function

Public Function ExecuteWithAssociate(ByVal hwnd As Long, sExecute As String, Optional Param As Variant, Optional windowstyle As Variant) As Boolean
   ' #VBIDEUtils#************************************************************
   ' * Programmer Name  : Waty Thierry
   ' * Web Site         : www.geocities.com/ResearchTriangle/6311/
   ' * E-Mail           : waty.thierry@usa.net
   ' * Date             : 9/10/98
   ' * Time             : 11:48
   ' * Module Name      : Execute_Module
   ' * Module Filename  :Execute.bas
   ' * Procedure Name   : ExecuteWithAssociate
   ' * Parameters       :
   ' *                    ByVal hWnd As Long
   ' *                    S As String
   ' *                    Optional Param As Variant
   ' *                    Optional windowstyle As Variant
   ' **********************************************************************
   ' * Comments         :
   ' * Executes a file with it's associated program.
   ' *   windowstyle uses the same constants as the Shell function:
   ' *      vbHide   0
   ' *      vbNormalFocus  1
   ' *      vbMinimizedFocus  2
   ' *      vbMaximizedFocus  3
   ' *      vbNormalNoFocus   4
   ' *      vbMinimizedNoFocus   6
   ' *
   ' *  returns true on success
   ' *
   ' *
   ' **********************************************************************
   
   Dim i As Long

   If IsMissing(windowstyle) Then windowstyle = vbNormalFocus

   i = ShellExecute(hwnd, vbNullString, sExecute, IIf(IsMissing(Param) Or (Param = ""), vbNullString, CStr(Param)), GetPath(sExecute), CLng(windowstyle))
   If i > 32 Then
      ExecuteWithAssociate = True
   Else
      ExecuteWithAssociate = False
   End If
   
End Function

Public Function GetFile(s As String) As String
   '
   '  Returns the file portion of a file + pathname
   '
   
   Dim i As Integer
   Dim J As Integer

   i = 0
   J = 0

   i = InStr(s, "\")
   Do While i <> 0
      J = i
      i = InStr(J + 1, s, "\")
   Loop

   If J = 0 Then
      GetFile = ""
   Else
      GetFile = Right$(s, Len(s) - J)
   End If

End Function

Public Function GetPath(s As String) As String
   '
   '  Returns the path portion of a file + pathname
   '
   
   Dim i As Integer
   Dim J As Integer

   i = 0
   J = 0

   i = InStr(s, "\")
   Do While i <> 0
      J = i
      i = InStr(J + 1, s, "\")
   Loop

   If J = 0 Then
      GetPath = ""
   Else
      GetPath = Left$(s, J)
   End If
End Function

Public Function GetSerialNumber(sDrive As String) As Long
   ' *** Retrieve a disks serial number
   ' *** Whenever a disk is formatted, the operating system writes a serial number onto it.
   ' *** This number is not guaranteed to be unique, but as it is a 32 bit integer
   ' *** it is unlikely to find a duplicate!
   ' *** The number is often used as part of a copy protection system.

   Dim nSerial       As Long
   Dim sTmp          As String * 256
   Dim sTmp2         As String * 256
   Dim nI            As Long
   Dim nJ            As Long

   sTmp = String$(255, Chr$(0))
   sTmp2 = String$(255, Chr$(0))
   Call GetVolumeInformation(sDrive + ":\" & Chr$(0), sTmp, 256, nSerial, nI, nJ, sTmp2, 256)
   GetSerialNumber = nSerial

End Function

Public Function GetSerialNumber2() As String
   '
   '  Returns a volume's serial number
   '
   Dim lpReOpenBuff       As OFSTRUCT
   Dim FileHandle         As Long
   Dim FileInfo           As BY_HANDLE_FILE_INFORMATION
   Dim ret As Long

   FileHandle = OpenFile("c:\autoexec.bat", lpReOpenBuff, OF_READ)
   ret = GetFileInformationByHandle(FileHandle, FileInfo)
   GetSerialNumber2 = CStr(FileInfo.dwVolumeSerialNumber)
   ret = CloseHandle(FileHandle)

End Function

Public Function GetShortPathName(longpath As String) As String
   Dim s As String
   Dim i As Long

   i = Len(longpath) + 1
   s = String(i, 0)
   GetShortPathNameA longpath, s, i

   GetShortPathName = Left$(s, InStr(s, Chr$(0)) - 1)
End Function

Public Function GetVolumeName(sDrive As String) As String
   Dim ser As Long
   Dim s As String * 256
   Dim s2 As String * 256
   Dim i As Long
   Dim J As Long

   Call GetVolumeInformation(sDrive + ":\" & Chr$(0), s, 256, ser, i, J, s2, 256)
   GetVolumeName = Left$(s, InStr(s, Chr$(0)) - 1)
End Function

Public Function SetVolumeName(sDrive As String, n As String) As Boolean
   '
   '  Sets the volume name.  Returns true on success, false on failure.
   '
   Dim i As Long

   i = SetVolumeLabelA(sDrive + ":\" & Chr$(0), n & Chr$(0))

   SetVolumeName = IIf(i = 0, False, True)
End Function

Public Function GetSystemDirectory() As String
   '
   '  Returns the system directory.
   '
   Dim s As String
   Dim i As Integer
   i = GetSystemDirectoryA("", 0)
   s = Space(i)
   Call GetSystemDirectoryA(s, i)
   GetSystemDirectory = AddBackslash(Left$(s, i - 1))
End Function

'
'  Returns the path to the temp directory.
'
Public Function GetTempPath() As String
   Dim s As String
   Dim i As Integer
   i = GetTempPathA(0, "")
   s = Space(i)
   Call GetTempPathA(i, s)
   GetTempPath = AddBackslash(Left$(s, i - 1))
End Function

Public Function GetWindowsDirectory() As String
   '
   '  Returns the windows directory.
   '
   Dim s As String
   Dim i As Integer
   i = GetWindowsDirectoryA("", 0)
   s = Space(i)
   Call GetWindowsDirectoryA(s, i)
   GetWindowsDirectory = AddBackslash(Left$(s, i - 1))
End Function

Public Function RemoveBackslash(s As String) As String
   '
   '  Removes the backslash from the string if it has one.
   '
   Dim i As Integer
   i = Len(s)
   If i <> 0 Then
      If Right$(s, 1) = "\" Then
         RemoveBackslash = Left$(s, i - 1)
      Else
         RemoveBackslash = s
      End If
   Else
      RemoveBackslash = ""
   End If
End Function

Public Function sDriveType(sDrive As String) As String
   '
   ' Returns the drive type if possible.
   '
   Dim lRet As Long

   lRet = GetDriveTypeA(sDrive & ":\")
   Select Case lRet
      Case 0
         'sDriveType = "Cannot be determined!"
         sDriveType = "Unknown"

      Case 1
         'sDriveType = "The root directory does not exist!"
         sDriveType = "Unknown"
      Case DRIVE_CDROM:
         sDriveType = "CD-ROM Drive"

      Case DRIVE_REMOVABLE:
         sDriveType = "Removable Drive"

      Case DRIVE_FIXED:
         sDriveType = "Fixed Drive"

      Case DRIVE_REMOTE:
         sDriveType = "Remote Drive"
   End Select

End Function

Public Function GetDriveType(sDrive As String) As Long

   Dim lRet As Long
   lRet = GetDriveTypeA(sDrive & ":\")

   If lRet = 1 Then
      lRet = 0
   End If

   GetDriveType = lRet

End Function

Public Sub GetRunningApplications(nhwnd As Long)
   ' *** Show all the running applications

   Dim lLgthChild    As Long
   Dim sNameChild    As String
   Dim lLgthOwner    As Long
   Dim sNameOwner    As String
   Dim lHwnd         As Long
   Dim lHwnd2        As Long
   Dim lProssId   As Long

   Const vbTextCompare = 1

   lHwnd = GetWindow(nhwnd, GW_HWNDFIRST)
   While lHwnd <> 0
      lHwnd2 = GetWindow(lHwnd, GW_OWNER)
      lLgthOwner = GetWindowTextLength(lHwnd2)
      sNameOwner = String$(lLgthOwner + 1, Chr$(0))
      lLgthOwner = GetWindowText(lHwnd2, sNameOwner, lLgthOwner + 1)

      If lLgthOwner <> 0 Then
         sNameOwner = Left$(sNameOwner, InStr(1, sNameOwner, Chr$(0), vbTextCompare) - 1)
         Call GetWindowThreadProcessId(lHwnd2, lProssId)
         Debug.Print sNameOwner, lProssId
      End If

      lLgthChild = GetWindowTextLength(lHwnd)
      sNameChild = String$(lLgthChild + 1, Chr$(0))
      lLgthChild = GetWindowText(lHwnd, sNameChild, lLgthChild + 1)
      If lLgthChild <> 0 Then
         sNameChild = Left$(sNameChild, InStr(1, sNameChild, Chr$(0), vbTextCompare) - 1)
         Call GetWindowThreadProcessId(lHwnd, lProssId)
         Debug.Print sNameChild, lProssId
      End If

      lHwnd = GetWindow(lHwnd, GW_HWNDNEXT)
      DoEvents

   Wend

End Sub

Public Function RegisterAsServiceProcess(bRegister As Boolean) As Boolean
   ' #VBIDEUtils#************************************************************
   ' * Programmer Name  : Waty Thierry
   ' * Web Site         : www.geocities.com/ResearchTriangle/6311/
   ' * E-Mail           : waty.thierry@usa.net
   ' * Date             : 25/09/98
   ' * Time             : 11:36
   ' * Module Name      : Execute
   ' * Module Filename  : Execute_Module
   ' * Procedure Name   : RegisterAsServiceProcess
   ' * Parameters       :
   ' **********************************************************************
   ' * Comments         : This code allows the programer to register
   ' * the application as a service process.
   ' * To put it in simpler terms, a service process does not appear in the "End Task"
   ' * dialog box. Using this call does not let the user of your application terminate
   ' * the program using Ctrl-Alt-Del.
   ' *
   ' **********************************************************************

   RegisterAsServiceProcess = RegisterServiceProcess(GetCurrentProcessId, IIf(bRegister, 1, 0)) = 1

End Function


0
 

Author Comment

by:KIRK50
ID: 1442562
Waty,

Thanks (again)... I assume I use the first example, and the others are to play with?  Okay, I'll try it out and if I have
a problem I'll drop you a line.  Thanks!

-- Kirk
0

Featured Post

6 Surprising Benefits of Threat Intelligence

All sorts of threat intelligence is available on the web. Intelligence you can learn from, and use to anticipate and prepare for future attacks.

Join & Write a Comment

Have you ever wanted to restrict the users input in a textbox to numbers, and while doing that make sure that they can't 'cheat' by pasting in non-numeric text? Of course you can do that with code you write yourself but it's tedious and error-prone …
If you need to start windows update installation remotely or as a scheduled task you will find this very helpful.
Get people started with the utilization of class modules. Class modules can be a powerful tool in Microsoft Access. They allow you to create self-contained objects that encapsulate functionality. They can easily hide the complexity of a process from…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

746 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

11 Experts available now in Live!

Get 1:1 Help Now