Attribute VB_Name = "modCommon" Option Explicit '============================================================================================================= ' ' modCommon Module ' ---------------- ' ' Created By : Kevin Wilson ' http://www.TheVBZone.com ( The VB Zone ) ' http://www.TheVBZone.net ( The VB Zone .net ) ' ' Created On : July 1, 2000 ' Last Update : Fabruary 19, 2003 ' ' VB Versions : 5.0 / 6.0 ' ' Requires : NOTHING ' ' Description : This module is a combination of all of the Windows API's that I use most often. I kept ' having to add them every time I created a new project, so I figured I'd save myself some ' time by creating a reusable module that can be used in any program. ' '============================================================================================================= ' ' LEGAL: ' ' You are free to use this code as long as you keep the above heading information intact and unchanged. Credit ' given where credit is due. Also, it is not required, but it would be appreciated if you would mention ' somewhere in your compiled program that that your program makes use of code written and distributed by ' Kevin Wilson (www.TheVBZone.com). Feel free to link to this code via your web site or articles. ' ' You may NOT take this code and pass it off as your own. You may NOT distribute this code on your own server ' or web site. You may NOT take code created by Kevin Wilson (www.TheVBZone.com) and use it to create products, ' utilities, or applications that directly compete with products, utilities, and applications created by Kevin ' Wilson, TheVBZone.com, or Wilson Media. You may NOT take this code and sell it for profit without first ' obtaining the written consent of the author Kevin Wilson. ' ' These conditions are subject to change at the discretion of the owner Kevin Wilson at any time without ' warning or notice. Copyright© by Kevin Wilson. All rights reserved. ' '============================================================================================================= ' Types / Enumerations Private Type POINTAPI X As Long Y As Long End Type Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Type BROWSEINFO hwndOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfnCALLBACK As Long lParam As Long iImage As Long End Type Private Type OFSTRUCT cBytes As Byte '//BYTE fFixedDisk As Byte '//BYTE nErrCode As Integer '//WORD Reserved1 As Integer '//WORD Reserved2 As Integer '//WORD szPathName As String * 128 '//CHAR [OFS_MAXPATHNAME] End Type ' Constants - General Private Const MAX_PATH = 260 ' Constants - SetFileAttributes.dwFileAttributes Private Const FILE_ATTRIBUTE_ARCHIVE = &H20 Private Const FILE_ATTRIBUTE_COMPRESSED = &H800 Private Const FILE_ATTRIBUTE_DIRECTORY = &H10 Private Const FILE_ATTRIBUTE_HIDDEN = &H2 Private Const FILE_ATTRIBUTE_NORMAL = &H80 Private Const FILE_ATTRIBUTE_READONLY = &H1 Private Const FILE_ATTRIBUTE_SYSTEM = &H4 Private Const FILE_ATTRIBUTE_TEMPORARY = &H100 ' Constants - SetWindowPos.wFlags Private Const SWP_FRAMECHANGED = &H20 ' Forces a WM_NCCALCSIZE message to go to the window even if its size does not change. Private Const SWP_DRAWFRAME = SWP_FRAMECHANGED ' Draws a frame around the window. Private Const SWP_HIDEWINDOW = &H80 ' Hides the window. Private Const SWP_NOACTIVATE = &H10 ' Does not activate the window. Private Const SWP_NOMOVE = &H2 ' Retains current position (x and y are ignored). Private Const SWP_NOREDRAW = &H8 ' Window is not automatically redrawn. Private Const SWP_NOSIZE = &H1 ' Retains current size (cx and cy are ignored). Private Const SWP_NOZORDER = &H4 ' Retains current position in the window list (hWndInsertAfter is ignored). Private Const SWP_SHOWWINDOW = &H40 ' Displays the window. Private Const SWP_FLAGS = SWP_NOMOVE Or SWP_NOSIZE Private Const HWND_TOP = 0 ' Place window at the top of the Z-order, the order in which windows are displayed for the given level of the window in the hierarchy Private Const HWND_BOTTOM = 1 ' Place window at bottom of the window list Private Const HWND_TOPMOST = -1 ' Place window at the top of the list, ahead of any topmost windows Private Const HWND_NOTOPMOST = -2 ' Place window at the top of the list, behind any topmost windows ' Constants - RemoveMenu.wFlags Private Const MF_BYCOMMAND = &H0& ' Indicates that the uPosition parameter gives the identifier of the menu item. The MF_BYCOMMAND flag is the default if neither the MF_BYCOMMAND nor MF_BYPOSITION flag is specified. Private Const MF_BYPOSITION = &H400& ' Indicates that the uPosition parameter gives the zero-based relative position of the menu item. ' Constants - SHBrowseForFolder.lpbi Private Const BIF_BROWSEFORCOMPUTER = &H1000 ' * Browsing for Computers Private Const BIF_BROWSEFORPRINTER = &H2000 ' * Browsing for Printers Private Const BIF_BROWSEINCLUDEFILES = &H4000 ' * Browsing for Everything Private Const BIF_RETURNONLYFSDIRS = &H1 ' Only returns file system directories. If the user selects folders that are not part of the file system, the OK button is grayed. Private Const BIF_DONTGOBELOWDOMAIN = &H2 ' Does not include network folders below the domain level in the tree view control. Private Const BIF_STATUSTEXT = &H4 ' Includes a status area in the dialog box. The callback function can set the status text by sending messages to the dialog box. Private Const BIF_RETURNFSANCESTORS = &H8 ' Only returns file system ancestors. If the user selects anything other than a file system ancestor, the OK button is grayed. Private Const BIF_VALIDATE = &H20 ' Insist on valid result (or CANCEL) Private Const BIF_EDITBOX = &H10 ' Displays an editable TextBox control in the dialog ' Constants - ShowWindow.nCmdShow Private Const SW_HIDE = 0 ' Hides the window and activates another window. Private Const SW_MAXIMIZE = 3 ' Maximizes the specified window. Private Const SW_MINIMIZE = 6 ' Minimizes the specified window and activates the next top-level window in the Z order. Private Const SW_RESTORE = 9 ' Activates and displays the window. If the window is minimized or maximized, Windows restores it to its original size and position. An application should specify this flag when restoring a minimized window. Private Const SW_SHOW = 5 ' Activates the window and displays it in its current size and position. Private Const SW_SHOWDEFAULT = 10 ' Sets the show state based on the SW_ flag specified in the STARTUPINFO structure passed to the CreateProcess function by the program that started the application. Private Const SW_SHOWMAXIMIZED = 3 ' Activates the window and displays it as a maximized window. Private Const SW_SHOWMINIMIZED = 2 ' Activates the window and displays it as a minimized window. Private Const SW_SHOWMINNOACTIVE = 7 ' Displays the window as a minimized window. The active window remains active. Private Const SW_SHOWNA = 8 ' Displays the window in its current state. The active window remains active. Private Const SW_SHOWNOACTIVATE = 4 ' Displays a window in its most recent size and position. The active window remains active. Private Const SW_SHOWNORMAL = 1 ' Activates and displays a window. If the window is minimized or maximized, Windows restores it to its original size and position. An application should specify this flag when displaying the window for the first time. ' Constants - OpenFile.uStyle Private Const OF_READ = &H0 'Opens the file for reading only. Private Const OF_WRITE = &H1 'Opens the file for writing only. Private Const OF_READWRITE = &H2 'Opens the file for reading and writing. Private Const OF_SHARE_COMPAT = &H0 'For MS-DOS-based file systems using the Win32 API, opens the file with compatibility mode, allowing any process on a specified computer to open the file any number of times. Other efforts to open with any other sharing mode fail. Windows NT: This flag is mapped to the CreateFile function's FILE_SHARE_READ | FILE_SHARE_WRITE flags. Private Const OF_SHARE_EXCLUSIVE = &H10 'Opens the file with exclusive mode, denying both read and write access to other processes. If the file has been opened in any other mode for read or write access, even by the current process, the function fails. Private Const OF_SHARE_DENY_WRITE = &H20 'Opens the file and denies write access to other processes. On MS-DOS-based file systems using the Win32 API, if the file has been opened in compatibility mode or for write access by any other process, the function fails. Windows NT: This flag is mapped to the CreateFile function's FILE_SHARE_READ flag. Private Const OF_SHARE_DENY_READ = &H30 'Opens the file and denies read access to other processes. On MS-DOS-based file systems using the Win32 API, if the file has been opened in compatibility mode or for read access by any other process, the function fails. Windows NT: This flag is mapped to the CreateFile function's FILE_SHARE_WRITE flag. Private Const OF_SHARE_DENY_NONE = &H40 'Opens the file without denying read or write access to other processes. On MS-DOS-based file systems using the Win32 API, if the file has been opened in compatibility mode by any other process, the function fails. Windows NT: This flag is mapped to the CreateFile function's FILE_SHARE_READ | FILE_SHARE_WRITE flags. Private Const OF_PARSE = &H100 'Fills the OFSTRUCT structure but carries out no other action. Private Const OF_DELETE = &H200 'Deletes the file. Private Const OF_VERIFY = &H400 'Verifies that the date and time of the file are the same as when it was previously opened. This is useful as an extra check for read-only files. Private Const OF_CANCEL = &H800 'Ignored. In the Win32 application programming interface (API), the OF_PROMPT style produces a dialog box containing a Cancel button. Private Const OF_CREATE = &H1000 'Creates a new file. If the file already exists, it is truncated to zero length. Private Const OF_PROMPT = &H2000 'Displays a dialog box if the requested file does not exist. The dialog box informs the user that Windows cannot find the file, and it contains Retry and Cancel buttons. Choosing the Cancel button directs OpenFile to return a file-not-found error message. Private Const OF_EXIST = &H4000 'Opens the file and then closes it. Used to test for a file’s existence. Private Const OF_REOPEN = &H8000 'Opens the file using information in the reopen buffer. ' Private Variables Private ExitingProgram As Boolean ' Win32 API Declarations Declarations Public Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long) Private Declare Sub CoTaskMemFree Lib "OLE32.DLL" (ByVal hMem As Long) Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long 'BOOL Private Declare Function FindWindow Lib "USER32.DLL" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function GetCursorPos Lib "USER32.DLL" (lpPOINT As POINTAPI) As Long Private Declare Function GetPrivateProfileString Lib "kernel32.dll" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long Private Declare Function GetShortPathName Lib "KERNEL32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long Private Declare Function GetSystemMenu Lib "USER32.DLL" (ByVal hWnd As Long, ByVal bRevert As Long) As Long Private Declare Function GetSystemDirectory Lib "kernel32.dll" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long Private Declare Function GetTempPath Lib "kernel32.dll" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long Private Declare Function GetWindowsDirectory Lib "kernel32.dll" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long Private Declare Function GetWindowRect Lib "USER32" (ByVal hWnd As Long, lpRect As RECT) As Long Private Declare Function lstrCat Lib "kernel32.dll" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long Private Declare Function MoveFile Lib "KERNEL32" Alias "MoveFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As Long 'BOOL Private Declare Function MoveWindow Lib "USER32" (ByVal hWnd As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long Private Declare Function OpenFile Lib "KERNEL32" (ByVal lpFileName As String, ByRef lpReOpenBuff As OFSTRUCT, ByVal uStyle As Long) As Long Private Declare Function RemoveMenu Lib "USER32.DLL" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long Private Declare Function SendMessage Lib "USER32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Private Declare Function SetForegroundWindow Lib "USER32.DLL" (ByVal hWnd As Long) As Long Private Declare Function SetWindowPos Lib "USER32.DLL" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long Private Declare Function SHBrowseForFolder Lib "SHELL32.DLL" (lpbi As BROWSEINFO) As Long Private Declare Function SHGetPathFromIDList Lib "SHELL32.DLL" (ByVal pidList As Long, ByVal lpBuffer As String) As Long Private Declare Function SHGetIDListFromPath Lib "SHELL32.DLL" Alias "#162" (ByVal szPath As String) As Long Private Declare Function ShowWindow Lib "USER32.DLL" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long Private Declare Function WritePrivateProfileString Lib "kernel32.dll" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal LPString As String, ByVal lpFileName As String) As Long '==================================================================================== ' AutoComplete ' ' Description: ' ------------ ' Searches a specified ComboBox for the closest match to what is being typed. This ' functionality is similar to the nagivation ComboBox in both Netscape and MSIE. ' ' Param Description ' --------------------------------- ' Title Optional. Specifies the titlebar caption of the window to ' activate. If this is not specified, the ClassName param ' must be specified. ' ClassName Optional. Specifies the class name of the window to actiave. ' If this is not specified, the Title param must be specified. ' RestoreWindow Optional. If set to TRUE, this function will make sure the ' specified window is neither minimized nor maximized and is ' visible before trying to activate it. ' ' Example Use: ' ------------ ' ' ' Put the following code in the KeyUp event of the ComboBox: ' Select Case KeyCode ' Case 32, &H30 To &H6F, Is > &H7F ' AutoComplete Combo1 ' End Select ' ' Return: ' ------- ' NOTHING ' '==================================================================================== Public Sub AutoComplete(ByRef CboBox As ComboBox) On Error Resume Next Dim ReturnValue As Long Dim lngPosition As Long With CboBox lngPosition = Len(.Text) If lngPosition <> 0 Then ReturnValue = SendMessage(.hWnd, &H14C, -1&, ByVal .Text) .ListIndex = ReturnValue .SelStart = lngPosition .SelLength = Len(.Text) - lngPosition End If End With End Sub '==================================================================================== ' App_Activate ' ' Description: ' ------------ ' Programatically force the specified window to be active. ' ' Param Description ' --------------------------------- ' Title Optional. Specifies the titlebar caption of the window to ' activate. If this is not specified, the ClassName param ' must be specified. ' ClassName Optional. Specifies the class name of the window to actiave. ' If this is not specified, the Title param must be specified. ' RestoreWindow Optional. If set to TRUE, this function will make sure the ' specified window is neither minimized nor maximized and is ' visible before trying to activate it. ' ' Return: ' ------- ' TRUE = Succeeded ' FALSE = Failed ' '==================================================================================== Public Function App_Activate(Optional ByVal Title As String, Optional ByVal ClassName As String = "", Optional ByVal RestoreWindow As Boolean = False) As Boolean On Error GoTo ErrorTrap Dim ReturnValue As Long ' Check for valid parameters, then get the handle of the specified window 20 If ClassName <> "" Then 30 ReturnValue = FindWindow(ClassName, vbNullString) 40 If (ReturnValue = 0 Or ReturnValue = vbNull) And Title = "" Then 50 App_Activate = False 60 Exit Function 70 ElseIf (ReturnValue = 0 Or ReturnValue = vbNull) And Title <> "" Then 80 ReturnValue = FindWindow(vbNullString, Title) 90 If ReturnValue = 0 Or ReturnValue = vbNull Then 100 App_Activate = False 110 Exit Function 120 End If 130 End If 140 ElseIf Title <> "" Then 150 ReturnValue = FindWindow(vbNullString, Title) 160 If ReturnValue = 0 Or ReturnValue = vbNull Then 170 App_Activate = False 180 Exit Function 190 End If 200 Else 210 App_Activate = False 220 Exit Function 230 End If ' Restore the window first if the user specifies to 240 If RestoreWindow = True Then 250 ShowWindow ReturnValue, SW_SHOW 260 ShowWindow ReturnValue, SW_RESTORE 270 End If 280 DoEvents ' Force the specified window to the forground 290 ReturnValue = SetForegroundWindow(ReturnValue) 300 If ReturnValue = 0 Then 310 App_Activate = False 320 Else 330 App_Activate = True 340 End If 350 Exit Function ErrorTrap: 360 If Err.Number = 0 Then 370 Resume Next 380 ElseIf Err.Number = 20 Then 390 Resume Next 400 Else '410 MsgBox "The following error occured while trying to set the following window to the foreground:" & Chr(13) & Chr(13) & "'" & Title & "'" & Chr(13) & Chr(13) & "Error Number = " & CStr(Err.Number) & Chr(13) & "Error Description = " & Err.Description & Chr(13) & "Error Line = " & Erl, vbOKOnly + vbExclamation, " Error Activating Window" 420 Err.Clear 430 App_Activate = False 440 Exit Function 450 End If End Function '==================================================================================== ' BrowseForFolder ' ' Description: ' ------------ ' Displays the standard Windows "Browse For Folder" dialog box. ' ' Param Description ' --------------------------------- ' ReturnPath Returns the selected folder. This returns vbNullString if ' the user CANCEL'd the dialog, or an error occured. ' ReturnTitle Optional. Returns the "Display Name" of the selected folder. ' OwnerHandle Optional. Defines the owner of the dialog box. ' Prompt Optional. Specifies the text to display in the dialog ' RootDir Optional. Specifies the TOP folder of the dialog. The ' default is the Windows Desktop. ' ' Return: ' ------- ' TRUE = Succeeded ' FALSE = Failed ' '==================================================================================== Public Function BrowseForFolder(ByRef ReturnPath As String, Optional ByRef ReturnTitle As String, Optional ByVal OwnerHandle As Long, Optional ByVal Prompt As String, Optional ByVal RootDir As String) As Boolean On Error Resume Next ' Declare variables to be used Dim ReturnValue As Long Dim TempPath As String Dim TheBrowseInfo As BROWSEINFO Dim DisplayName As String Dim ImageIndex As Long Dim Flags As Long Dim MyAnswer As VbMsgBoxResult Dim IDListRoot As Long ' Create a buffer to recieve the DisplayName = String(MAX_PATH, Chr(0)) ' Get the IDList for the specified root If RootDir = "" Then IDListRoot = 0 Else If Dir(RootDir, vbDirectory) <> "" Then IDListRoot = SHGetIDListFromPath(RootDir) End If End If ' Initialise variables With TheBrowseInfo .hwndOwner = OwnerHandle .pidlRoot = IDListRoot .pszDisplayName = DisplayName .lpszTitle = Prompt .ulFlags = BIF_RETURNONLYFSDIRS Or BIF_VALIDATE .lpfnCALLBACK = 0 .lParam = 0 .iImage = ImageIndex End With ' Call the browse for folder API ReturnValue = SHBrowseForFolder(TheBrowseInfo) ' Check if user canceled... and if the user did NOT, get the path selected If ReturnValue <> 0 Then ' Create a buffer for the path TempPath = String(MAX_PATH, 0) ' Get the path from the pointer SHGetPathFromIDList ReturnValue, TempPath ' Clean up the paths If InStr(TempPath, Chr(0)) > 0 Then TempPath = Left(TempPath, InStr(TempPath, Chr(0)) - 1) End If DisplayName = TheBrowseInfo.pszDisplayName If InStr(DisplayName, Chr(0)) > 0 Then DisplayName = Left(DisplayName, InStr(DisplayName, Chr(0)) - 1) End If ' Free up memory used CoTaskMemFree ReturnValue ' Return the path ReturnPath = TempPath ReturnTitle = DisplayName BrowseForFolder = True Else ' Clear the return values due to invalid selection / CANCEL ReturnPath = "" ReturnTitle = "" BrowseForFolder = False End If End Function '==================================================================================== ' CenterWindow ' ' Description: ' ------------ ' Centers the window specified in the middle of the screen. ' ' Param Description ' --------------------------------- ' Handle Optional. Specifies the handle of the window to center. If ' this is not specified, the Title or ClassName param must be. ' Title Optional. Specifies the titlebar caption of the window to ' center. If this is not specified, the Handle or ClassName ' param must be. ' ClassName Optional. Specifies the class name of the window to center. ' If this is not specified, the Handle or Title param must be. ' ' Return: ' ------- ' TRUE = Succeeded ' FALSE = Failed ' '==================================================================================== Public Function CenterWindow(Optional ByVal Handle As Long, Optional ByVal Title As String = "", Optional ByVal ClassName As String = "") As Boolean On Error GoTo ErrorTrap Dim TheHandle As Long Dim ReturnValue As Long Dim W_Top As Integer Dim W_Left As Integer Dim W_Width As Integer Dim W_Height As Integer Dim rct As RECT ' Check for valid parameters, then get the handle of the specified window If ClassName = "" And Title = "" And Handle = 0 Then Exit Function ElseIf Handle <> 0 Then TheHandle = Handle ElseIf ClassName = "" Then TheHandle = FindWindow(vbNullString, Title) Else TheHandle = FindWindow(ClassName, vbNullString) End If If TheHandle = 0 Then Exit Function End If ' Get the coordinates of the window ReturnValue = GetWindowRect(TheHandle, rct) If ReturnValue = 0 Then ' Error Exit Function End If W_Top = rct.Top W_Left = rct.Left W_Height = rct.Bottom - rct.Top W_Width = rct.Right - rct.Left W_Top = ((Screen.Height / Screen.TwipsPerPixelY) - W_Height) / 2 W_Left = ((Screen.Width / Screen.TwipsPerPixelX) - W_Width) / 2 ShowWindow TheHandle, SW_SHOW ShowWindow TheHandle, SW_RESTORE MoveWindow TheHandle, W_Left, W_Top, W_Width, W_Height, True CenterWindow = True Exit Function ErrorTrap: If Err.Number = 0 Then ' No Error Resume Next ElseIf Err.Number = 20 Then ' Resume Without Error Resume Next Else ' Other Error 'MsgBox Err.Source & " encountered the following error:" & Chr(13) & Chr(13) & "Error Number = " & CStr(Err.Number) & Chr(13) & "Error Description = " & Err.Description, vbOKOnly + vbExclamation, " Error - " & Err.Description Err.Clear CenterWindow = False Exit Function End If End Function '==================================================================================== ' ConvertLong2Short ' ' Description: ' ------------ ' Takes a 32bit file or directory path and converts it to the 16bit equivelant path ' ' Param Description ' --------------------------------- ' strFullPath Specifies the full 32-bit path to the file or directory ' ' Return: ' ------- ' If the file exists, returns the 16-bit file path ' If the file doesn't exist, returns BLANK STRING ("") ' '==================================================================================== Public Function ConvertLong2Short(ByVal strFullPath As String) As String On Error Resume Next ' Validate parameters strFullPath = Trim(strFullPath) If strFullPath = "" Then Exit Function strFullPath = strFullPath & Chr(0) ' For this API to work, the file must exist If Dir(strFullPath, vbArchive Or vbHidden Or vbNormal Or vbReadOnly Or vbSystem) = "" Then Exit Function ' Convert the path ConvertLong2Short = String(MAX_PATH, Chr(0)) If GetShortPathName(strFullPath, ConvertLong2Short, MAX_PATH) <> 0 Then ConvertLong2Short = UCase(Left(ConvertLong2Short, InStr(ConvertLong2Short, Chr(0)) - 1)) Else ConvertLong2Short = "" End If End Function '==================================================================================== ' EndTheProgram ' ' Description: ' ------------ ' Unloads all open forms and ends the program. The ExitingProgram variable is set ' to TRUE to let the rest of the program know that it's trying to end the program. ' ' Param Description ' --------------------------------- ' CallEnd Optional. If set to TRUE, the "End" function is called ' to make sure the program is ended. If the program being ' ended contains any kind of sub-classing, this should be ' set to FALSE to avoid the program crashing. ' ' Return: ' ------- ' Program ends ' '==================================================================================== Public Sub EndTheProgram(Optional ByVal CallEnd As Boolean = False) On Error Resume Next Dim Form As Form ExitingProgram = True For Each Form In Forms Unload Form Set Form = Nothing Next If CallEnd = True Then End End If End Sub '==================================================================================== ' KillDir ' ' Description: ' ------------ ' Function that will delete a directory and all of it's contents reguardless of it's ' attributes or the attributes of the files within it. ' ' Param Description ' --------------------------------- ' strPath Specifies the full path to the folder to delete ' blnPromptUser Optional. If set to TRUE, the user will be prompted to delete ' the folder and it's contents ' Return_ErrNum If an error occurs, this will return the error number ' Return_ErrDesc If an error occurs, this will return the error description ' ' Return: ' ------- ' TRUE = Succeeded ' FALSE = Failed ' '==================================================================================== Public Function KillDir(ByVal strPath As String, _ Optional ByVal blnPromptUser As Boolean = False, _ Optional ByRef Return_ErrNum As Long, _ Optional ByRef Return_ErrDesc As String) As Boolean On Error GoTo ErrorTrap Dim strReturn As String ' Clear return values Return_ErrNum = 0 Return_ErrDesc = "" ' Validate parameters strPath = Trim(strPath) If strPath = "" Then Return_ErrNum = -1 Return_ErrDesc = "No directory specified to delete" Exit Function End If If Right(strPath, 1) <> "\" Then strPath = strPath & "\" ' If specified path doesn't exist, or was previously delete, just exit If Dir(strPath, vbDirectory Or vbArchive Or vbHidden Or vbNormal Or vbReadOnly Or vbSystem) = "" Then KillDir = True Exit Function End If ' Ask the user if it's ok to delete the directory If blnPromptUser = True Then If MsgBox(strPath & Chr(13) & Chr(13) & "Are you sure you want to remove this folder and all of it's contents?", vbYesNo + vbExclamation, " Confirm Folder Delete") <> vbYes Then KillDir = True Exit Function End If End If ' Loop through all files and sub-directories in the specified directory. Recurse through dir's and delete files. StartOver: strReturn = Dir(strPath, vbDirectory Or vbArchive Or vbHidden Or vbNormal Or vbReadOnly Or vbSystem) Do While strReturn <> "" If strReturn <> "." And strReturn <> ".." Then If (GetAttr(strPath & strReturn) And vbDirectory) = vbDirectory Then If ClearDirectory(strPath & strReturn, Return_ErrNum, Return_ErrDesc) = False Then Exit Function Else GoTo StartOver End If Else SetAttr strPath & strReturn, vbNormal Kill strPath & strReturn End If End If strReturn = Dir Loop ' Last step, remove the main directory SetAttr strPath, vbNormal RmDir strPath ' Function succeeded KillDir = True Exit Function ErrorTrap: Return_ErrNum = Err.Number Return_ErrDesc = Err.Description Err.Clear If Return_ErrNum = 0 Or Return_ErrNum = 20 Then Resume Next End Function '==================================================================================== ' FileDelete ' ' Description: ' ------------ ' Function that will delete the specified file reguardless of it's attributes. The ' VB funtion "Kill()" alone will not delete files with the "Read-Only" attribute set. ' ' Param Description ' --------------------------------- ' FilePath Specifies the file to delete. If only a file is specified, and ' not the full path, the current directory will be assumed. ' blnPromptUser Optional. If set to TRUE, the user will be prompted to delete ' the folder and it's contents ' Return_ErrNum If an error occurs, this will return the error number ' Return_ErrDesc If an error occurs, this will return the error description ' ' Return: ' ------- ' TRUE = Succeeded ' FALSE = Failed ' '==================================================================================== Public Function FileDelete(ByVal FilePath As String, _ Optional ByVal blnPromptUser As Boolean = False, _ Optional ByRef Return_ErrNum As Long, _ Optional ByRef Return_ErrDesc As String) As Boolean On Error GoTo ErrorTrap Dim lngErrNum As Long Dim strErrDesc As String ' Clear return values Return_ErrNum = 0 Return_ErrDesc = "" ' Validate parameters FilePath = Trim(FilePath) If FilePath = "" Then Return_ErrNum = -1 Return_ErrDesc = "No file specified to delete" Exit Function ElseIf FileExists(FilePath) = False Then FileDelete = True Exit Function End If ' Ask the user if it's ok to delete the directory If blnPromptUser = True Then If MsgBox(FilePath & Chr(13) & Chr(13) & "Are you sure you want to delete this file?", vbYesNo + vbExclamation, " Confirm File Delete") <> vbYes Then FileDelete = True Exit Function End If End If ' Set the file attribute to normal and delete the file SetAttr FilePath, vbNormal Kill FilePath ' Function executed correctly FileDelete = True Exit Function ErrorTrap: Return_ErrNum = Err.Number Return_ErrDesc = Err.Description Err.Clear If Return_ErrNum = 0 Or Return_ErrNum = 20 Then Resume Next End Function '==================================================================================== ' FileInUse ' ' Description: ' ------------ ' Checks to see if the specified file is currently in use. ' ' Param Description ' --------------------------------- ' strFilePath Fully qualified path to the file to check. ' ' Return: ' ------- ' TRUE = Succeeded ' FALSE = Failed ' '==================================================================================== Public Function FileInUse(ByVal strFilePath As String) As Boolean Dim hFile As Long Dim FileInfo As OFSTRUCT ' Validate parameters strFilePath = Trim(strFilePath) If strFilePath = "" Then Exit Function If Dir(strFilePath, vbArchive Or vbHidden Or vbNormal Or vbReadOnly Or vbSystem) = "" Then Exit Function If Right(strFilePath, 1) <> Chr(0) Then strFilePath = strFilePath & Chr(0) ' Attempt to open the file EXCLUSIVELY... if this fails, another process is using the file FileInfo.cBytes = Len(FileInfo) hFile = OpenFile(strFilePath, FileInfo, OF_SHARE_EXCLUSIVE) If hFile = -1 And Err.LastDllError = 32 Then FileInUse = True Else CloseHandle hFile End If End Function '==================================================================================== ' FileExists ' ' Description: ' ------------ ' Checks to see if the specified file exists or not ' ' Param Description ' --------------------------------- ' strFilePath Fully qualified path to the file to check. ' ' Return: ' ------- ' TRUE = Succeeded ' FALSE = Failed ' '==================================================================================== Public Function FileExists(ByVal strFilePath As String) As Boolean ' Validate parameters strFilePath = Trim(strFilePath) If strFilePath = "" Then Exit Function ' Check if the file exists (reguardless of it's attributes) If Dir(strFilePath, vbArchive Or vbHidden Or vbNormal Or vbReadOnly Or vbSystem) <> "" Then FileExists = True End Function '==================================================================================== ' FormPosition ' ' Description: ' ------------ ' Function that sets the specified window to TOP MOST, or NOT. ' ' Param Description ' --------------------------------- ' FormHandle Specifies the window to set to TOP MOST / NOT TOPMOST ' MakeTopMost TRUE = Specified window is brought to the top of the ' Z Order and stays on top of all other windows ' regardless of which window has the focus. ' FALSE = Specified window keeps it's current Z Order ' and gives / takes focus normally. ' ' Return: ' ------- ' TRUE = Succeeded ' FALSE = Failed ' '==================================================================================== Public Function FormPosition(ByVal FormHandle As Long, ByVal MakeTopMost As Boolean) As Boolean On Error GoTo ErrorTrap Dim ReturnValue As Long Dim flag As Long If MakeTopMost = True Then flag = HWND_TOPMOST Else flag = HWND_NOTOPMOST End If ReturnValue = SetWindowPos(FormHandle, flag, 0, 0, 0, 0, SWP_FLAGS) If ReturnValue <> 0 Then FormPosition = True End If Exit Function ErrorTrap: If Err.Number = 0 Then ' No Error Resume Next ElseIf Err.Number = 20 Then ' Resume Without Error Resume Next Else ' Other Error 'MsgBox Err.Source & " encountered the following error:" & Chr(13) & Chr(13) & "Error Number = " & CStr(Err.Number) & Chr(13) & "Error Description = " & Err.Description, vbOKOnly + vbExclamation, " Error - " & Err.Description Err.Clear FormPosition = False Exit Function End If End Function '==================================================================================== ' FormPosition ' ' Description: ' ------------ ' Perminently removes the "X" close button from the upper right corner of the ' specified window. ' ' NOTE : This should be called in the Form_Load event, or the window should be ' refreshed after this function is called to ensure proper drawing of the ' "X" close button on the window. ' ' Param Description ' --------------------------------- ' FormHandle Specifies the window to remove the "X" close button from ' ' Return: ' ------- ' TRUE = Succeeded ' FALSE = Failed ' '==================================================================================== Public Function FormRemoveX(ByVal FormHandle As Long) As Boolean On Error GoTo ErrorTrap Dim SystemMenu As Long Dim ReturnValue As Long SystemMenu = GetSystemMenu(FormHandle, 0) If SystemMenu = 0 Then FormRemoveX = False Exit Function Else ReturnValue = RemoveMenu(SystemMenu, 6, MF_BYPOSITION) If ReturnValue = 0 Then FormRemoveX = False Exit Function End If End If FormRemoveX = True Exit Function ErrorTrap: If Err.Number = 0 Then ' No Error Resume Next ElseIf Err.Number = 20 Then ' Resume Without Error Resume Next Else ' Other Error 'MsgBox Err.Source & " encountered the following error:" & Chr(13) & Chr(13) & "Error Number = " & CStr(Err.Number) & Chr(13) & "Error Description = " & Err.Description, vbOKOnly + vbExclamation, " Error - " & Err.Description Err.Clear FormRemoveX = False Exit Function End If End Function '==================================================================================== ' GetAppVersion ' ' Description: ' ------------ ' Function that returns the full version number of the current application (1.0.43) ' ' Param Description ' --------------------------------- ' (none) ' ' Return: ' ------- ' Returns a string representing the full version number ' '==================================================================================== Public Function GetAppVersion() As String On Error Resume Next GetAppVersion = CStr(App.Major) & "." & CStr(App.Minor) & "." & CStr(App.Revision) End Function '==================================================================================== ' GetWinPath ' ' Description: ' ------------ ' Returns the user's Windows install directory. ' ' Param Description ' --------------------------------- ' NONE ' ' Return: ' ------- ' Succeeded = Returns full 32bit path to the Windows install directory ' Failed = Returns vbNullString ' '==================================================================================== Public Function GetWinPath() As String On Error Resume Next Dim strFolder As String Dim lngResult As Long strFolder = String(MAX_PATH, 0) lngResult = GetWindowsDirectory(strFolder, MAX_PATH) If lngResult <> 0 Then GetWinPath = Left(strFolder, InStr(strFolder, Chr(0)) - 1) Else GetWinPath = "" End If End Function '==================================================================================== ' GetWinSysPath ' ' Description: ' ------------ ' Windows 95 : Returns the user's Windows\System install directory ' Windows NT : Returns the user's Windows\System32 install directory. ' ' Param Description ' --------------------------------- ' NONE ' ' Return: ' ------- ' Succeeded = Returns full 32bit path to the Windows\System install directory ' Failed = Returns vbNullString ' '==================================================================================== Public Function GetWinSysPath() As String On Error Resume Next Dim strFolder As String Dim lngResult As Long strFolder = String(MAX_PATH, 0) lngResult = GetSystemDirectory(strFolder, MAX_PATH) If lngResult <> 0 Then GetWinSysPath = Left(strFolder, InStr(strFolder, Chr(0)) - 1) Else GetWinSysPath = "" End If End Function '==================================================================================== ' GetWinPath ' ' Description: ' ------------ ' Returns the user's Windows install directory. ' ' Param Description ' --------------------------------- ' NONE ' ' Return: ' ------- ' Succeeded = Returns the temporary file path as follows: ' 1. The path specified by the TMP environment variable. ' 2. The path specified by the TEMP environment variable, ' if TMP is not defined. ' 3. The current directory, if both TMP and TEMP are not defined. ' Failed = Returns vbNullString ' '==================================================================================== Public Function GetWinTemp() As String On Error Resume Next Dim strFolder As String Dim lngResult As Long strFolder = String(MAX_PATH, 0) lngResult = GetTempPath(MAX_PATH, strFolder) If lngResult <> 0 Then GetWinTemp = Left(strFolder, InStr(strFolder, Chr(0)) - 1) Else GetWinTemp = "" End If End Function '==================================================================================== ' GetX ' ' Description: ' ------------ ' Returns the current X axis location of the cursor on the screen. The upper left ' corner of the screen is the start point (0,0). ' ' Param Description ' --------------------------------- ' NONE ' ' Return: ' ------- ' Succeeded = Returns the current X coordinate of the cursor in pixels ' Failed = Returns -1 ' '==================================================================================== Public Function GetX() As Long On Error Resume Next Dim MyPoint As POINTAPI Dim ReturnValue As Long ReturnValue = GetCursorPos(MyPoint) If ReturnValue <> 0 Then GetX = MyPoint.X Else GetX = -1 End If End Function '==================================================================================== ' GetY ' ' Description: ' ------------ ' Returns the current Y axis location of the cursor on the screen. The upper left ' corner of the screen is the start point (0,0). ' ' Param Description ' --------------------------------- ' NONE ' ' Return: ' ------- ' Succeeded = Returns the current Y coordinate of the cursor in pixels ' Failed = Returns -1 ' '==================================================================================== Public Function GetY() As Long On Error Resume Next Dim MyPoint As POINTAPI Dim ReturnValue As Long ReturnValue = GetCursorPos(MyPoint) If ReturnValue <> 0 Then GetY = MyPoint.Y Else GetY = -1 End If End Function '============================================================================================================= ' INI_Read ' ' Description: ' ------------ ' Returns the value of the specified key in the specified section. If you look at the WIN.INI file, it will ' look something like this : ' ' [Windows] ' Load= ' Run= ' NullPort = None ' MouseTrails = -7 ' Device=HP LaserJet 4,HPPCL5MS,\\NTSERVER\HPLaserJ ' ' In this case, "Windows" is the section name, "MouseTrails" is the key name... the return value would be "-7" ' ' Param Description ' --------------------------------- ' SectionName Specifies the section to find the specified key in ' KeyName Specifies the key to get the value from ' INIPath Specifies the full path to the .INI file to get the value from ' DefaultValue Optional. Specifies a default value to return. If the ' specified file does not exist, if the section is does not ' exist, if the specified key does not exist, or if the value ' of the specified key is vbNullString, then this value is returned ' ' Return: ' ------- ' Returns the specified key value, or the specified DefaultValue ' '============================================================================================================= Public Function INI_Read(ByVal SectionName As String, ByVal KeyName As String, ByVal INIPath As String, Optional ByVal DefaultValue As String = "") As String On Error Resume Next Dim lngLength As Long INI_Read = String(MAX_PATH, Chr(0)) lngLength = GetPrivateProfileString(SectionName & Chr(0), KeyName & Chr(0), DefaultValue & Chr(0), INI_Read, Len(INI_Read), INIPath & Chr(0)) INI_Read = Left(INI_Read, lngLength) End Function '============================================================================================================= ' INI_Write ' ' Description: ' ------------ ' Returns the value of the specified key in the specified section. If you look at the WIN.INI file, it will ' look something like this : ' ' [Windows] ' Load= ' Run= ' NullPort = None ' MouseTrails = -7 ' Device=HP LaserJet 4,HPPCL5MS,\\NTSERVER\HPLaserJ ' ' In this case, "Windows" is the section name, "MouseTrails" is the key name... the return value would be "-7" ' ' Param Description ' --------------------------------- ' SectionName Specifies the section to find the specified key in ' KeyName Specifies the key to write the value to ' Value Specifies the value to write to the .INI file ' INIPath Specifies the full path to the .INI file to write to ' blnDeleteKeyIfBlank Optional. If TRUE and a blank string is passed as the "Value"... the key will be ' deleted from the .INI file. If FALSE (default) and a blank string is passed as the ' "Value"... the key will simply hold a blank string value. ' ' Return: ' ------- ' TRUE = Succeeded ' FALSE = Failed ' '============================================================================================================= Public Function INI_Write(ByVal SectionName As String, ByVal KeyName As String, ByVal Value As String, ByVal INIPath As String, Optional ByVal blnDeleteKeyIfBlank As Boolean = False) As Boolean On Error Resume Next If blnDeleteKeyIfBlank = True Then If SectionName = "" Then SectionName = vbNullString Else SectionName = SectionName & Chr(0) If KeyName = "" Then KeyName = vbNullString Else KeyName = KeyName & Chr(0) If Value = "" Then Value = vbNullString Else Value = Value & Chr(0) Else SectionName = SectionName & Chr(0) KeyName = KeyName & Chr(0) Value = Value & Chr(0) End If If WritePrivateProfileString(SectionName, KeyName, Value, INIPath & Chr(0)) <> 0 Then INI_Write = True End Function '==================================================================================== ' RenameFile ' ' Description: ' ------------ ' This function takes the specified file or directory and renames it to the new ' name specified ' ' NOTE : The new file may be on a different file system or drive. The new directory ' must be on the same drive. ' ' Param Description ' --------------------------------- ' strOldFilePath Specifies the path to the file or directory to rename ' strNewFileName Specifies the name of the new file or directory (without it's ' path because the file or directory is renamed within the same path) ' Return_ErrNum If an error occurs, this returns the error number ' Return_ErrDesc If an error occurs, this returns the error description ' ' Return: ' ------- ' TRUE = Succeeded ' FALSE = Failed ' '==================================================================================== Public Function RenameFile(ByVal strOldFilePath As String, ByVal strNewFileName As String, Optional ByRef Return_ErrNum As Long, Optional ByRef Return_ErrDesc As String) As Boolean On Error Resume Next Dim strPath As String Dim strFileName As String Dim strFileExt As String ' Clear return values Return_ErrNum = 0 Return_ErrDesc = "" ' Validate parameters strOldFilePath = Trim(strOldFilePath) strNewFileName = Trim(strNewFileName) If strOldFilePath = "" Then Return_ErrNum = -1 Return_ErrDesc = "No file specified to rename" Exit Function ElseIf strNewFileName = "" Then Return_ErrNum = -1 Return_ErrDesc = "No file specified to rename the file to" Exit Function ElseIf FileExists(strOldFilePath) = False Then Return_ErrNum = -1 Return_ErrDesc = "The file specified to rename does not exist" Exit Function ElseIf FileExists(strNewFileName) = True Then Return_ErrNum = -1 Return_ErrDesc = "The file name specified to rename to already exists" Exit Function ElseIf InStr(strNewFileName, "\") <> 0 Or _ InStr(strNewFileName, "/") <> 0 Or _ InStr(strNewFileName, ":") <> 0 Or _ InStr(strNewFileName, "*") <> 0 Or _ InStr(strNewFileName, "?") <> 0 Or _ InStr(strNewFileName, Chr(34)) <> 0 Or _ InStr(strNewFileName, "<") <> 0 Or _ InStr(strNewFileName, ">") <> 0 Or _ InStr(strNewFileName, "|") <> 0 Then Return_ErrNum = -1 Return_ErrDesc = "New file name contains one or more of the followin invalid characters: \ / : * ? " & Chr(34) & " < > |" Exit Function ElseIf FileInUse(strOldFilePath) = True Then Return_ErrNum = -1 Return_ErrDesc = "The specified file to rename is currently in use by another process so it can not be renamed" Exit Function End If ' Rename the files to 16bit names to avoid file system problems with long file names strOldFilePath = ConvertLong2Short(strOldFilePath) If strOldFilePath = "" Then Return_ErrNum = -1 Return_ErrDesc = "An error occured while changing the path to a 16-bit path." Exit Function End If ' Get the path of specified file so we can create a path for the new file If GetFileNameAndExt(strOldFilePath, strFileName, strFileExt) = False Then Return_ErrNum = -1 Return_ErrDesc = "An error occured while trying to get the specified file's path" Exit Function Else strPath = Left(strOldFilePath, Len(strOldFilePath) - Len(strFileName) - Len(".") - Len(strFileExt)) End If ' Rename the files If MoveFile(strOldFilePath & Chr(0), strPath & strNewFileName & Chr(0)) = 0 Then Return_ErrNum = Err.LastDllError Return_ErrDesc = "An error occured while trying to rename the specified file" Else RenameFile = True End If End Function '==================================================================================== ' GetFileNameAndExt ' ' Description: ' ------------ ' This function takes a file name, file path, or web path and strips out the file name ' and extention from it. ' ' Param Description ' --------------------------------- ' strFilePath Specifies the file name, full file path, or web path to the file to get. ' Return_FileName Returns the name of the file WITHOUT it's extention ' Return_FileExtention Returns the extention of the file (the characters of the string ' to the right of the last period (.) in the file path specified ' ' Return: ' ------- ' TRUE = Succeeded ' FALSE = Failed ' '==================================================================================== Public Function GetFileNameAndExt(ByVal strFilePath As String, ByRef Return_FileName As String, ByRef Return_FileExtention As String) As Boolean Dim StringSoFar As String Dim CharLeft As String Dim CharRight As String Dim lngCounter As Long Dim blnFoundExt As Boolean ' Clear return variables Return_FileName = "" Return_FileExtention = "" ' Validate parameters strFilePath = Trim(strFilePath) If strFilePath = "" Then Exit Function If InStr(strFilePath, "\") = 0 And InStr(strFilePath, "/") = 0 And InStr(strFilePath, ".") = 0 Then Return_FileName = strFilePath Exit Function End If ' Loop through the file and get it's extention and name For lngCounter = 1 To Len(strFilePath) CharRight = Right(strFilePath, lngCounter) CharLeft = Left(CharRight, 1) If CharLeft = "." And blnFoundExt = False Then blnFoundExt = True Return_FileExtention = StringSoFar StringSoFar = "" ElseIf CharLeft = "\" Or CharLeft = "/" Then Return_FileName = StringSoFar GetFileNameAndExt = True Exit Function Else StringSoFar = CharLeft & StringSoFar End If Next ' If a single file name was passed without a PATH, this returns the correct values Return_FileName = StringSoFar GetFileNameAndExt = True End Function 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX ' WARNING: This function is a recursion function and should only be called by the "KillDir" function Private Function ClearDirectory(ByVal strPath As String, _ Optional ByRef Return_ErrNum As Long, _ Optional ByRef Return_ErrDesc As String) As Boolean On Error GoTo ErrorTrap Dim strReturn As String ' Clear return values Return_ErrNum = 0 Return_ErrDesc = "" ' Validate parameter strPath = Trim(strPath) If Right(strPath, 1) <> "\" Then strPath = strPath & "\" ' Check for files or folders under the specified directory StartOver: strReturn = Dir(strPath, vbDirectory Or vbArchive Or vbHidden Or vbNormal Or vbReadOnly Or vbSystem) Do While strReturn <> "" If strReturn <> "." And strReturn <> ".." Then If (GetAttr(strPath & strReturn) And vbDirectory) = vbDirectory Then If ClearDirectory(strPath & strReturn, Return_ErrNum, Return_ErrDesc) = False Then Exit Function Else GoTo StartOver End If Else SetAttr strPath & strReturn, vbNormal Kill strPath & strReturn End If End If strReturn = Dir Loop ' Last step, remove the main directory SetAttr strPath, vbNormal RmDir strPath ' Function succeeded ClearDirectory = True Exit Function ErrorTrap: Return_ErrNum = Err.Number Return_ErrDesc = Err.Description Err.Clear If Return_ErrNum = 0 Or Return_ErrNum = 20 Then Resume Next End Function