Attribute VB_Name = "Common" Option Explicit Private Type MSGBOXPARAMS cbSize As Long hwndOwner As Long hInstance As Long lpszText As Long lpszCaption As Long dwStyle As Long lpszIcon As Long dwContextHelpID As Long lpfnMsgBoxCallback As Long dwLanguageId As Long End Type Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Type BITMAP BMType As Long BMWidth As Long BMHeight As Long BMWidthBytes As Long BMPlanes As Integer BMBitsPixel As Integer BMBits As Long End Type Private Type SAFEARRAYBOUND cElements As Long lLbound As Long End Type Private Type SAFEARRAY1D cDims As Integer fFeatures As Integer cbElements As Long cLocks As Long pvData As Long Bounds As SAFEARRAYBOUND End Type Private Type PICTDESC cbSizeOfStruct As Long PicType As Long hImage As Long XExt As Long YExt As Long End Type Private Type CLSID Data1 As Long Data2 As Integer Data3 As Integer Data4(0 To 7) As Byte End Type Private Type FILETIME dwLowDateTime As Long dwHighDateTime As Long End Type Private Type SYSTEMTIME wYear As Integer wMonth As Integer wDayOfWeek As Integer wDay As Integer wHour As Integer wMinute As Integer wSecond As Integer wMilliseconds As Integer End Type Private Const MAX_PATH As Long = 260 Private Type WIN32_FIND_DATA dwFileAttributes As Long FTCreationTime As FILETIME FTLastAccessTime As FILETIME FTLastWriteTime As FILETIME nFileSizeHigh As Long nFileSizeLow As Long dwReserved0 As Long dwReserved1 As Long lpszFileName(0 To ((MAX_PATH * 2) - 1)) As Byte lpszAlternateFileName(0 To ((14 * 2) - 1)) As Byte End Type Private Type VS_FIXEDFILEINFO dwSignature As Long dwStrucVersionLo As Integer dwStrucVersionHi As Integer dwFileVersionMSLo As Integer dwFileVersionMSHi As Integer dwFileVersionLSLo As Integer dwFileVersionLSHi As Integer dwProductVersionMSLo As Integer dwProductVersionMSHi As Integer dwProductVersionLSLo As Integer dwProductVersionLSHi As Integer dwFileFlagsMask As Long dwFileFlags As Long dwFileOS As Long dwFileType As Long dwFileSubtype As Long dwFileDateMS As Long dwFileDateLS As Long End Type Private Type MONITORINFO cbSize As Long RCMonitor As RECT RCWork As RECT dwFlags As Long End Type Private Type FLASHWINFO cbSize As Long hWnd As Long dwFlags As Long uCount As Long dwTimeout As Long End Type Private Const LF_FACESIZE As Long = 32 Private Const DEFAULT_QUALITY As Long = 0 Private Type LOGFONT lfHeight As Long lfWidth As Long lfEscapement As Long lfOrientation As Long lfWeight As Long lfItalic As Byte lfUnderline As Byte lfStrikeOut As Byte lfCharSet As Byte lfOutPrecision As Byte lfClipPrecision As Byte lfQuality As Byte lfPitchAndFamily As Byte lfFaceName(0 To ((LF_FACESIZE * 2) - 1)) As Byte 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 Declare Function ArrPtr Lib "msvbvm60.dll" Alias "VarPtr" (ByRef Var() As Any) As Long Private Declare Function CloseClipboard Lib "USER32" () As Long Private Declare Function CloseHandle Lib "KERNEL32" (ByVal hObject As Long) As Long Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long Private Declare Function CreateDirectory Lib "KERNEL32" Alias "CreateDirectoryW" (ByVal lpPathName As Long, ByVal lpSecurityAttributes As Long) As Long Private Declare Function CreateFile Lib "KERNEL32" Alias "CreateFileW" (ByVal lpFileName As Long, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectW" (ByRef lpLogFont As LOGFONT) As Long Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long Private Declare Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As Long, ByRef pStream As IUnknown) As Long Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function DrawIconEx Lib "USER32" (ByVal hDC As Long, ByVal XLeft As Long, ByVal YTop As Long, ByVal hIcon As Long, ByVal CXWidth As Long, ByVal CYWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long Private Declare Function EmptyClipboard Lib "USER32" () As Long Private Declare Function FileTimeToLocalFileTime Lib "KERNEL32" (ByVal lpFileTime As Long, ByVal lpLocalFileTime As Long) As Long Private Declare Function FileTimeToSystemTime Lib "KERNEL32" (ByVal lpFileTime As Long, ByVal lpSystemTime As Long) As Long Private Declare Function FillRect Lib "USER32" (ByVal hDC As Long, ByRef lpRect As RECT, ByVal hBrush As Long) As Long Private Declare Function FindClose Lib "KERNEL32" (ByVal hFindFile As Long) As Long Private Declare Function FindFirstFile Lib "KERNEL32" Alias "FindFirstFileW" (ByVal lpFileName As Long, ByRef lpFindFileData As WIN32_FIND_DATA) As Long Private Declare Function FindNextFile Lib "KERNEL32" Alias "FindNextFileW" (ByVal hFindFile As Long, ByRef lpFindFileData As WIN32_FIND_DATA) As Long Private Declare Function FindWindow Lib "USER32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function FlashWindowEx Lib "USER32" (ByRef pFWI As FLASHWINFO) As Long Private Declare Function GdiAlphaBlend Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal nWidthSrc As Long, ByVal nHeightSrc As Long, ByVal BlendFunc As Long) As Long Private Declare Function GetActiveWindow Lib "USER32" () As Long Private Declare Function GetAsyncKeyState Lib "USER32" (ByVal vKey As Long) As Integer Private Declare Function GetClassName Lib "USER32" Alias "GetClassNameW" (ByVal hWnd As Long, ByVal lpClassName As Long, ByVal nMaxCount As Long) As Long Private Declare Function GetClipboardData Lib "USER32" (ByVal wFormat As Long) As Long Private Declare Function GetCommandLine Lib "KERNEL32" Alias "GetCommandLineW" () As Long Private Declare Function GetDC Lib "USER32" (ByVal hWnd As Long) As Long Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long Private Declare Function GetFileAttributes Lib "KERNEL32" Alias "GetFileAttributesW" (ByVal lpFileName As Long) As Long Private Declare Function GetFileSize Lib "KERNEL32" (ByVal hFile As Long, ByRef lpFileSizeHigh As Long) As Long Private Declare Function GetFileTime Lib "KERNEL32" (ByVal hFile As Long, ByVal lpCreationTime As Long, ByVal lpLastAccessTime As Long, ByVal lpLastWriteTime As Long) As Long Private Declare Function GetFileVersionInfo Lib "Version" Alias "GetFileVersionInfoW" (ByVal lpFileName As Long, ByVal dwHandle As Long, ByVal dwLen As Long, ByVal lpData As Long) As Long Private Declare Function GetFileVersionInfoSize Lib "Version" Alias "GetFileVersionInfoSizeW" (ByVal lpFileName As Long, ByVal lpdwHandle As Long) As Long Private Declare Function GetForegroundWindow Lib "USER32" () As Long Private Declare Function GetKeyState Lib "USER32" (ByVal nVirtKey As Long) As Integer Private Declare Function GetMenu Lib "USER32" (ByVal hWnd As Long) As Long Private Declare Function GetModuleFileName Lib "KERNEL32" Alias "GetModuleFileNameW" (ByVal hModule As Long, ByVal lpFileName As Long, ByVal nSize As Long) As Long Private Declare Function GetMonitorInfo Lib "USER32" Alias "GetMonitorInfoW" (ByVal hMonitor As Long, ByRef lpMI As MONITORINFO) As Long Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectW" (ByVal hObject As Long, ByVal nCount As Long, ByRef lpObject As Any) As Long Private Declare Function GetSystemDirectory Lib "KERNEL32" Alias "GetSystemDirectoryW" (ByVal lpBuffer As Long, ByVal nSize As Long) As Long Private Declare Function GetSystemMetrics Lib "USER32" (ByVal nIndex As Long) As Long Private Declare Function GetSystemWindowsDirectory Lib "KERNEL32" Alias "GetSystemWindowsDirectoryW" (ByVal lpBuffer As Long, 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 GetVolumeInformation Lib "KERNEL32" Alias "GetVolumeInformationW" (ByVal lpRootPathName As Long, ByVal lpVolumeNameBuffer As Long, ByVal nVolumeNameSize As Long, ByRef lpVolumeSerialNumber As Long, ByRef lpMaximumComponentLength As Long, ByRef lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As Long, ByVal nFileSystemNameSize As Long) As Long Private Declare Function GetVolumePathName Lib "KERNEL32" Alias "GetVolumePathNameW" (ByVal lpFileName As Long, ByVal lpVolumePathName As Long, ByVal cch As Long) As Long Private Declare Function GetWindowRect Lib "USER32" (ByVal hWnd As Long, ByRef lpRect As RECT) As Long Private Declare Function GetWindowText Lib "USER32" Alias "GetWindowTextW" (ByVal hWnd As Long, ByVal LPString As Long, ByVal cch As Long) As Long Private Declare Function GetWindowTextLength Lib "USER32" Alias "GetWindowTextLengthW" (ByVal hWnd As Long) As Long Private Declare Function GlobalAlloc Lib "KERNEL32" (ByVal uFlags As Long, ByVal dwBytes As Long) As Long Private Declare Function GlobalLock Lib "KERNEL32" (ByVal hMem As Long) As Long Private Declare Function GlobalSize Lib "KERNEL32" (ByVal hMem As Long) As Long Private Declare Function GlobalUnlock Lib "KERNEL32" (ByVal hMem As Long) As Long Private Declare Function IsClipboardFormatAvailable Lib "USER32" (ByVal wFormat As Long) As Long Private Declare Function KillTimer Lib "USER32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long Private Declare Function lstrcpy Lib "KERNEL32" Alias "lstrcpyW" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long Private Declare Function lstrlen Lib "KERNEL32" Alias "lstrlenW" (ByVal LPString As Long) As Long Private Declare Function MessageBoxIndirect Lib "USER32" Alias "MessageBoxIndirectW" (ByRef lpMsgBoxParams As MSGBOXPARAMS) As Long Private Declare Function MonitorFromWindow Lib "USER32" (ByVal hWnd As Long, ByVal dwFlags As Long) As Long Private Declare Function MulDiv Lib "KERNEL32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long Private Declare Function MultiByteToWideChar Lib "KERNEL32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As Long, ByVal cbMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long Private Declare Function OleCreatePictureIndirect Lib "olepro32" (ByRef pPictDesc As PICTDESC, ByRef riid As Any, ByVal fPictureOwnsHandle As Long, ByRef pIPicture As IPicture) As Long Private Declare Function OleLoadPicture Lib "oleaut32" (ByVal pStream As IUnknown, ByVal lSize As Long, ByVal fRunmode As Long, ByRef riid As Any, ByRef pIPicture As IPicture) As Long Private Declare Function OleLoadPicturePath Lib "oleaut32" (ByVal lpszPath As Long, ByVal pUnkCaller As Long, ByVal dwReserved As Long, ByVal ClrReserved As OLE_COLOR, ByRef riid As CLSID, ByRef pIPicture As IPicture) As Long Private Declare Function OleTranslateColor Lib "oleaut32" (ByVal Color As Long, ByVal hPal As Long, ByRef rgbResult As Long) As Long Private Declare Function OpenClipboard Lib "USER32" (ByVal hWnd As Long) As Long Private Declare Function PathGetArgs Lib "shlwapi" Alias "PathGetArgsW" (ByVal lpszPath As Long) As Long Private Declare Function RedrawWindow Lib "USER32" (ByVal hWnd As Long, ByVal lprcUpdate As Long, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long Private Declare Function ReleaseDC Lib "USER32" (ByVal hWnd As Long, ByVal hDC As Long) As Long Private Declare Function RemoveDirectory Lib "KERNEL32" Alias "RemoveDirectoryW" (ByVal lpPathName As Long) As Long Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long Private Declare Function SendMessage Lib "USER32" Alias "SendMessageW" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long Private Declare Function SetClipboardData Lib "USER32" (ByVal wFormat As Long, ByVal hMem As Long) As Long Private Declare Function SetFileAttributes Lib "KERNEL32" Alias "SetFileAttributesW" (ByVal lpFileName As Long, ByVal dwFileAttributes As Long) As Long Private Declare Function SetForegroundWindow Lib "USER32" (ByVal hWnd As Long) As Long Private Declare Function SetTimer Lib "USER32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long Private Declare Function SetWindowPos Lib "USER32" (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 SysReAllocString Lib "oleaut32" (ByVal pbString As Long, ByVal pszStrPtr As Long) As Long Private Declare Function VarDecFromI8 Lib "oleaut32" (ByVal LoDWord As Long, ByVal HiDWord As Long, ByRef pDecOut As Variant) As Long Private Declare Function VerQueryValue Lib "Version" Alias "VerQueryValueW" (ByVal lpBlock As Long, ByVal lpSubBlock As Long, ByRef lplpBuffer As Long, ByRef puLen As Long) As Long Private Declare Function WideCharToMultiByte Lib "KERNEL32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByVal lpMultiByteStr As Long, ByVal cbMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long) Private Const NV_CLOSEMSGBOX = &H5000& Private Const NV_MOVEMSGBOX = &H5001& Private Const HWND_TOPMOST = -1 Private Const SWP_NOSIZE = &H1 Private mTitle As String Private mX As Long Private mY As Long Private mPause As Long Private mHandle As Long 'Public Function MsgBoxMove(ByVal hwnd As Long, ByVal inPrompt As String, _ ' ByVal inTitle As String, ByVal inButtons As Long, _ ' ByVal inX As Long, ByVal inY As Long) As Integer ' mTitle = inTitle: mX = inX: mY = inY ' SetTimer hwnd, NV_MOVEMSGBOX, 0&, AddressOf NewTimerProc ' MsgBoxMove = MessageBox(hwnd, inPrompt, inTitle, inButtons) 'End Function Public Function NewTimerProc(ByVal hWnd As Long, ByVal MSG As Long, ByVal wParam As Long, _ ByVal lParam As Long) As Long KillTimer hWnd, wParam Select Case wParam Case NV_CLOSEMSGBOX ' A system class is a window class registered by the system which cannot ' be destroyed by a processed, e.g. #32768 (a menu), #32769 (desktop ' window), #32770 (dialog box), #32771 (task switch window). mHandle = FindWindow("#32770", mTitle) If mHandle <> 0 Then SetForegroundWindow mHandle SendKeys "{enter}" End If Case NV_MOVEMSGBOX mHandle = FindWindow("#32770", mTitle) If mHandle <> 0 Then Dim w As Single, h As Single Dim mBox As RECT w = Screen.Width / Screen.TwipsPerPixelX h = Screen.Height / Screen.TwipsPerPixelY GetWindowRect mHandle, mBox If mX > (w - (mBox.Right - mBox.Left) - 1) Then mX = (w - (mBox.Right - mBox.Left) - 1) If mY > (h - (mBox.Bottom - mBox.Top) - 1) Then mY = (h - (mBox.Bottom - mBox.Top) - 1) If mX < 1 Then mX = 1: If mY < 1 Then mY = 1 ' SWP_NOSIZE is to use current size, ignoring 3rd & 4th parameters. SetWindowPos mHandle, HWND_TOPMOST, mX, mY, 0, 0, SWP_NOSIZE End If End Select End Function ' (VB-Overwrite) ' Use MessageBoxIndirect as an Advanced msgbox. ' MessageBoxIndirect is the most powerful, allowing you to add a Help button, custom icon, and specific language for the button text. ' Public Function MsgBox(ByVal Prompt As String, Optional ByVal Buttons As VbMsgBoxStyle = vbOKOnly, Optional ByVal Title As String, Optional ByVal TimeOut As Integer) As VbMsgBoxResult Dim MSGBOXP As MSGBOXPARAMS With MSGBOXP .cbSize = LenB(MSGBOXP) If (Buttons And vbSystemModal) = 0 Then If Not Screen.ActiveForm Is Nothing Then .hwndOwner = Screen.ActiveForm.hWnd Else .hwndOwner = GetActiveWindow() End If Else .hwndOwner = GetForegroundWindow() End If .hInstance = App.hInstance .lpszText = StrPtr(Prompt) If Title = vbNullString Then Title = App.Title .lpszCaption = StrPtr(Title) .dwStyle = Buttons If TimeOut > 0 Then mTitle = Title: mPause = TimeOut * 1000 SetTimer .hInstance, NV_CLOSEMSGBOX, mPause, AddressOf NewTimerProc End If End With MsgBox = MessageBoxIndirect(MSGBOXP) End Function ' (VB-Overwrite) Public Sub SendKeys(ByRef Text As String, Optional ByRef Wait As Boolean) CreateObject("WScript.Shell").SendKeys Text, Wait End Sub ' (VB-Overwrite) Public Function GetAttr(ByVal PathName As String) As VbFileAttribute Const INVALID_FILE_ATTRIBUTES As Long = (-1) Const FILE_ATTRIBUTE_NORMAL As Long = &H80 If Left$(PathName, 2) = "\\" Then PathName = "UNC\" & Mid$(PathName, 3) Dim dwAttributes As Long dwAttributes = GetFileAttributes(StrPtr("\\?\" & PathName)) If dwAttributes = INVALID_FILE_ATTRIBUTES Then Err.Raise 53 ElseIf dwAttributes = FILE_ATTRIBUTE_NORMAL Then GetAttr = vbNormal Else GetAttr = dwAttributes End If End Function ' (VB-Overwrite) Public Sub SetAttr(ByVal PathName As String, ByVal Attributes As VbFileAttribute) Const FILE_ATTRIBUTE_NORMAL As Long = &H80 Dim dwAttributes As Long If Attributes = vbNormal Then dwAttributes = FILE_ATTRIBUTE_NORMAL Else If (Attributes And (vbVolume Or vbDirectory Or vbAlias)) <> 0 Then Err.Raise 5 dwAttributes = Attributes End If If Left$(PathName, 2) = "\\" Then PathName = "UNC\" & Mid$(PathName, 3) If SetFileAttributes(StrPtr("\\?\" & PathName), dwAttributes) = 0 Then Err.Raise 53 End Sub ' (VB-Overwrite) Public Function Dir(Optional ByVal PathMask As String, Optional ByVal Attributes As VbFileAttribute = vbNormal) As String Const INVALID_HANDLE_VALUE As Long = (-1) Const FILE_ATTRIBUTE_NORMAL As Long = &H80 Static hFindFile As Long, AttributesCache As VbFileAttribute If Attributes = vbVolume Then ' Exact match ' If any other attribute is specified, vbVolume is ignored. If hFindFile <> 0 Then FindClose hFindFile hFindFile = 0 End If Dim VolumePathBuffer As String, VolumeNameBuffer As String If Len(PathMask) = 0 Then VolumeNameBuffer = String$(MAX_PATH, vbNullChar) If GetVolumeInformation(0, StrPtr(VolumeNameBuffer), Len(VolumeNameBuffer), ByVal 0, ByVal 0, ByVal 0, 0, 0) <> 0 Then Dir = Left$(VolumeNameBuffer, InStr(VolumeNameBuffer, vbNullChar) - 1) Else VolumePathBuffer = String$(MAX_PATH, vbNullChar) If Left$(PathMask, 2) = "\\" Then PathMask = "UNC\" & Mid$(PathMask, 3) If GetVolumePathName(StrPtr("\\?\" & PathMask), StrPtr(VolumePathBuffer), Len(VolumePathBuffer)) <> 0 Then VolumePathBuffer = Left$(VolumePathBuffer, InStr(VolumePathBuffer, vbNullChar) - 1) VolumeNameBuffer = String$(MAX_PATH, vbNullChar) If GetVolumeInformation(StrPtr(VolumePathBuffer), StrPtr(VolumeNameBuffer), Len(VolumeNameBuffer), ByVal 0, ByVal 0, ByVal 0, 0, 0) <> 0 Then Dir = Left$(VolumeNameBuffer, InStr(VolumeNameBuffer, vbNullChar) - 1) End If End If Else Dim FD As WIN32_FIND_DATA, dwMask As Long If Len(PathMask) = 0 Then If hFindFile <> 0 Then If FindNextFile(hFindFile, FD) = 0 Then FindClose hFindFile hFindFile = 0 Exit Function End If Else Err.Raise 5 Exit Function End If Else If hFindFile <> 0 Then FindClose hFindFile hFindFile = 0 End If Select Case Right$(PathMask, 1) Case "\", ":", "/" PathMask = PathMask & "*.*" End Select AttributesCache = Attributes If Left$(PathMask, 2) = "\\" Then PathMask = "UNC\" & Mid$(PathMask, 3) hFindFile = FindFirstFile(StrPtr("\\?\" & PathMask), FD) If hFindFile = INVALID_HANDLE_VALUE Then hFindFile = 0 If Err.LastDllError > 12 Then Err.Raise 52 Exit Function End If End If Do If FD.dwFileAttributes = FILE_ATTRIBUTE_NORMAL Then dwMask = 0 ' Found Else dwMask = FD.dwFileAttributes And (Not AttributesCache) And &H16 End If If dwMask = 0 Then Dir = Left$(FD.lpszFileName(), InStr(FD.lpszFileName(), vbNullChar) - 1) If FD.dwFileAttributes And vbDirectory Then If Dir <> "." And Dir <> ".." Then Exit Do ' Exclude self and relative path aliases Else Exit Do End If End If If FindNextFile(hFindFile, FD) = 0 Then FindClose hFindFile hFindFile = 0 Exit Do End If Loop End If End Function ' (VB-Overwrite) Public Sub MkDir(ByVal PathName As String) If Left$(PathName, 2) = "\\" Then PathName = "UNC\" & Mid$(PathName, 3) If CreateDirectory(StrPtr("\\?\" & PathName), 0) = 0 Then Const ERROR_PATH_NOT_FOUND As Long = 3 If Err.LastDllError = ERROR_PATH_NOT_FOUND Then Err.Raise 76 Else Err.Raise 75 End If End If End Sub ' (VB-Overwrite) Public Sub RmDir(ByVal PathName As String) If Left$(PathName, 2) = "\\" Then PathName = "UNC\" & Mid$(PathName, 3) If RemoveDirectory(StrPtr("\\?\" & PathName)) = 0 Then Const ERROR_FILE_NOT_FOUND As Long = 2 If Err.LastDllError = ERROR_FILE_NOT_FOUND Then Err.Raise 76 Else Err.Raise 75 End If End If End Sub ' (VB-Overwrite) Public Function FileLen(ByVal PathName As String) As Variant Const INVALID_HANDLE_VALUE As Long = (-1), INVALID_FILE_SIZE As Long = (-1) Const GENERIC_READ As Long = &H80000000, FILE_SHARE_READ As Long = &H1, OPEN_EXISTING As Long = 3, FILE_FLAG_SEQUENTIAL_SCAN As Long = &H8000000 Dim hFile As Long If Left$(PathName, 2) = "\\" Then PathName = "UNC\" & Mid$(PathName, 3) hFile = CreateFile(StrPtr("\\?\" & PathName), GENERIC_READ, FILE_SHARE_READ, 0, OPEN_EXISTING, FILE_FLAG_SEQUENTIAL_SCAN, 0) If hFile <> INVALID_HANDLE_VALUE Then Dim LoDWord As Long, HiDWord As Long LoDWord = GetFileSize(hFile, HiDWord) CloseHandle hFile If LoDWord <> INVALID_FILE_SIZE Then FileLen = CDec(0) VarDecFromI8 LoDWord, HiDWord, FileLen Else FileLen = Null End If Else Err.Raise number:=53, Description:="File not found: '" & PathName & "'" End If End Function ' (VB-Overwrite) Public Function FileDateTime(ByVal PathName As String) As Date Const INVALID_HANDLE_VALUE As Long = (-1) Const GENERIC_READ As Long = &H80000000, FILE_SHARE_READ As Long = &H1, OPEN_EXISTING As Long = 3, FILE_FLAG_SEQUENTIAL_SCAN As Long = &H8000000 Dim hFile As Long If Left$(PathName, 2) = "\\" Then PathName = "UNC\" & Mid$(PathName, 3) hFile = CreateFile(StrPtr("\\?\" & PathName), GENERIC_READ, FILE_SHARE_READ, 0, OPEN_EXISTING, FILE_FLAG_SEQUENTIAL_SCAN, 0) If hFile <> INVALID_HANDLE_VALUE Then Dim FT(0 To 1) As FILETIME, ST As SYSTEMTIME GetFileTime hFile, 0, 0, VarPtr(FT(0)) FileTimeToLocalFileTime VarPtr(FT(0)), VarPtr(FT(1)) FileTimeToSystemTime VarPtr(FT(1)), VarPtr(ST) FileDateTime = DateSerial(ST.wYear, ST.wMonth, ST.wDay) + TimeSerial(ST.wHour, ST.wMinute, ST.wSecond) CloseHandle hFile Else Err.Raise number:=53, Description:="File not found: '" & PathName & "'" End If End Function ' (VB-Overwrite) Public Function Command$() If InIDE() = False Then SysReAllocString VarPtr(Command$), PathGetArgs(GetCommandLine()) Command$ = LTrim$(Command$) Else Command$ = VBA.Command$() 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 PathName As String) As Boolean On Error Resume Next Dim Attributes As VbFileAttribute, ErrVal As Long Attributes = GetAttr(PathName) ErrVal = Err.number On Error GoTo 0 If (Attributes And (vbDirectory Or vbVolume)) = 0 And ErrVal = 0 Then FileExists = True End Function Public Function AppPath() As String If InIDE() = False Then Const MAX_PATH_W As Long = 32767 Dim Buffer As String, RetVal As Long Buffer = String(MAX_PATH, vbNullChar) RetVal = GetModuleFileName(0, StrPtr(Buffer), MAX_PATH) If RetVal = MAX_PATH Then ' Path > MAX_PATH Buffer = String(MAX_PATH_W, vbNullChar) RetVal = GetModuleFileName(0, StrPtr(Buffer), MAX_PATH_W) End If If RetVal > 0 Then Buffer = Left$(Buffer, RetVal) AppPath = Left$(Buffer, InStrRev(Buffer, "\")) Else AppPath = App.Path & IIf(Right$(App.Path, 1) = "\", "", "\") End If Else AppPath = App.Path & IIf(Right$(App.Path, 1) = "\", "", "\") End If End Function Public Function AppEXEName() As String If InIDE() = False Then Const MAX_PATH_W As Long = 32767 Dim Buffer As String, RetVal As Long Buffer = String(MAX_PATH, vbNullChar) RetVal = GetModuleFileName(0, StrPtr(Buffer), MAX_PATH) If RetVal = MAX_PATH Then ' Path > MAX_PATH Buffer = String(MAX_PATH_W, vbNullChar) RetVal = GetModuleFileName(0, StrPtr(Buffer), MAX_PATH_W) End If If RetVal > 0 Then Buffer = Left$(Buffer, RetVal) Buffer = Right$(Buffer, Len(Buffer) - InStrRev(Buffer, "\")) AppEXEName = Left$(Buffer, InStrRev(Buffer, ".") - 1) Else AppEXEName = App.EXEName End If Else AppEXEName = App.EXEName End If End Function Public Function AppMajor() As Integer If InIDE() = False Then With GetAppVersionInfo() AppMajor = .dwFileVersionMSHi End With Else AppMajor = App.Major End If End Function Public Function AppMinor() As Integer If InIDE() = False Then With GetAppVersionInfo() AppMinor = .dwFileVersionMSLo End With Else AppMinor = App.Minor End If End Function Public Function AppRevision() As Integer If InIDE() = False Then With GetAppVersionInfo() AppRevision = .dwFileVersionLSLo End With Else AppRevision = App.Revision End If End Function Private Function GetAppVersionInfo() As VS_FIXEDFILEINFO Static Done As Boolean, Value As VS_FIXEDFILEINFO If Done = False Then Const MAX_PATH_W As Long = 32767 Dim Buffer As String, RetVal As Long Buffer = String(MAX_PATH, vbNullChar) RetVal = GetModuleFileName(0, StrPtr(Buffer), MAX_PATH) If RetVal = MAX_PATH Then ' Path > MAX_PATH Buffer = String(MAX_PATH_W, vbNullChar) RetVal = GetModuleFileName(0, StrPtr(Buffer), MAX_PATH_W) End If If RetVal > 0 Then Dim ImagePath As String, Length As Long ImagePath = Left$(Buffer, RetVal) Length = GetFileVersionInfoSize(StrPtr(ImagePath), 0) If Length > 0 Then Dim DataBuffer() As Byte ReDim DataBuffer(0 To (Length - 1)) As Byte If GetFileVersionInfo(StrPtr(ImagePath), 0, Length, VarPtr(DataBuffer(0))) <> 0 Then Dim hData As Long If VerQueryValue(VarPtr(DataBuffer(0)), StrPtr("\"), hData, Length) <> 0 Then If hData <> 0 Then CopyMemory Value, ByVal hData, LenB(Value) End If End If End If End If Done = True End If LSet GetAppVersionInfo = Value End Function Public Function GetClipboardText() As String Const CF_UNICODETEXT As Long = 13 Dim lpText As Long, lpMem As Long, Length As Long If OpenClipboard(0) <> 0 Then If IsClipboardFormatAvailable(CF_UNICODETEXT) <> 0 Then lpText = GetClipboardData(CF_UNICODETEXT) If lpText <> 0 Then lpMem = GlobalLock(lpText) If lpMem <> 0 Then Length = lstrlen(lpMem) If Length > 0 Then GetClipboardText = String(Length, vbNullChar) lstrcpy StrPtr(GetClipboardText), lpMem End If GlobalUnlock lpMem End If End If End If CloseClipboard End If End Function Public Sub SetClipboardText(ByRef Text As String) Const CF_UNICODETEXT As Long = 13 Const GMEM_MOVEABLE As Long = &H2 Dim Buffer As String, Length As Long Dim hMem As Long, lpMem As Long If OpenClipboard(0) <> 0 Then EmptyClipboard Buffer = Text & vbNullChar Length = LenB(Buffer) hMem = GlobalAlloc(GMEM_MOVEABLE, Length) If hMem <> 0 Then lpMem = GlobalLock(hMem) If lpMem <> 0 Then CopyMemory ByVal lpMem, ByVal StrPtr(Buffer), Length GlobalUnlock hMem SetClipboardData CF_UNICODETEXT, hMem End If End If CloseClipboard End If End Sub Public Function AccelCharCode(ByVal Caption As String) As Integer If Caption = vbNullString Then Exit Function Dim Pos As Long, Length As Long Length = Len(Caption) Pos = Length Do If Mid$(Caption, Pos, 1) = "&" And Pos < Length Then AccelCharCode = Asc(UCase$(Mid$(Caption, Pos + 1, 1))) If Pos > 1 Then If Mid$(Caption, Pos - 1, 1) = "&" Then AccelCharCode = 0 Else If AccelCharCode = vbKeyUp Then AccelCharCode = 0 End If If AccelCharCode <> 0 Then Exit Do End If Pos = Pos - 1 Loop Until Pos = 0 End Function Public Function ProperControlName(ByVal Control As VB.Control) As String Dim Index As Long On Error Resume Next Index = Control.Index If Err.number <> 0 Or Index < 0 Then ProperControlName = Control.Name Else ProperControlName = Control.Name & "(" & Index & ")" On Error GoTo 0 End Function Public Function GetTopUserControl(ByVal UserControl As Object) As VB.UserControl If UserControl Is Nothing Then Exit Function Dim TopUserControl As VB.UserControl, TempUserControl As VB.UserControl CopyMemory TempUserControl, ObjPtr(UserControl), 4 Set TopUserControl = TempUserControl CopyMemory TempUserControl, 0&, 4 With TopUserControl If .ParentControls.Count > 0 Then Dim OldParentControlsType As VBRUN.ParentControlsType OldParentControlsType = .ParentControls.ParentControlsType .ParentControls.ParentControlsType = vbExtender If TypeOf .ParentControls(0) Is VB.VBControlExtender Then .ParentControls.ParentControlsType = vbNoExtender CopyMemory TempUserControl, ObjPtr(.ParentControls(0)), 4 Set TopUserControl = TempUserControl CopyMemory TempUserControl, 0&, 4 Dim TempParentControlsType As VBRUN.ParentControlsType Do With TopUserControl If .ParentControls.Count = 0 Then Exit Do TempParentControlsType = .ParentControls.ParentControlsType .ParentControls.ParentControlsType = vbExtender If TypeOf .ParentControls(0) Is VB.VBControlExtender Then .ParentControls.ParentControlsType = vbNoExtender CopyMemory TempUserControl, ObjPtr(.ParentControls(0)), 4 Set TopUserControl = TempUserControl CopyMemory TempUserControl, 0&, 4 .ParentControls.ParentControlsType = TempParentControlsType Else .ParentControls.ParentControlsType = TempParentControlsType Exit Do End If End With Loop End If .ParentControls.ParentControlsType = OldParentControlsType End If End With Set GetTopUserControl = TopUserControl End Function Public Function MousePointerID(ByVal MousePointer As Integer) As Long Select Case MousePointer Case vbArrow Const IDC_ARROW As Long = 32512 MousePointerID = IDC_ARROW Case vbCrosshair Const IDC_CROSS As Long = 32515 MousePointerID = IDC_CROSS Case vbIbeam Const IDC_IBEAM As Long = 32513 MousePointerID = IDC_IBEAM Case vbIconPointer ' Obselete, replaced Icon with Hand Const IDC_HAND As Long = 32649 MousePointerID = IDC_HAND Case vbSizePointer, vbSizeAll Const IDC_SIZEALL As Long = 32646 MousePointerID = IDC_SIZEALL Case vbSizeNESW Const IDC_SIZENESW As Long = 32643 MousePointerID = IDC_SIZENESW Case vbSizeNS Const IDC_SIZENS As Long = 32645 MousePointerID = IDC_SIZENS Case vbSizeNWSE Const IDC_SIZENWSE As Long = 32642 MousePointerID = IDC_SIZENWSE Case vbSizeWE Const IDC_SIZEWE As Long = 32644 MousePointerID = IDC_SIZEWE Case vbUpArrow Const IDC_UPARROW As Long = 32516 MousePointerID = IDC_UPARROW Case vbHourglass Const IDC_WAIT As Long = 32514 MousePointerID = IDC_WAIT Case vbNoDrop Const IDC_NO As Long = 32648 MousePointerID = IDC_NO Case vbArrowHourglass Const IDC_APPSTARTING As Long = 32650 MousePointerID = IDC_APPSTARTING Case vbArrowQuestion Const IDC_HELP As Long = 32651 MousePointerID = IDC_HELP Case 16 Const IDC_WAITCD As Long = 32663 ' Undocumented MousePointerID = IDC_WAITCD End Select End Function Public Function OLEFontIsEqual(ByVal Font As StdFont, ByVal FontOther As StdFont) As Boolean If Font Is Nothing Then If FontOther Is Nothing Then OLEFontIsEqual = True ElseIf FontOther Is Nothing Then If Font Is Nothing Then OLEFontIsEqual = True Else If Font.Name = FontOther.Name And Font.Size = FontOther.Size And Font.Charset = FontOther.Charset And Font.Weight = FontOther.Weight And _ Font.Underline = FontOther.Underline And Font.Italic = FontOther.Italic And Font.Strikethrough = FontOther.Strikethrough Then OLEFontIsEqual = True End If End If End Function Public Function CreateGDIFontFromOLEFont(ByVal Font As StdFont) As Long Dim LF As LOGFONT, fontName As String With LF fontName = Left$(Font.Name, LF_FACESIZE) CopyMemory .lfFaceName(0), ByVal StrPtr(fontName), LenB(fontName) .lfHeight = -MulDiv(CLng(Font.Size), DPI_Y(), 72) .lfWeight = Font.Weight If Font.Italic = True Then .lfItalic = 1 Else .lfItalic = 0 If Font.Strikethrough = True Then .lfStrikeOut = 1 Else .lfStrikeOut = 0 If Font.Underline = True Then .lfUnderline = 1 Else .lfUnderline = 0 .lfQuality = DEFAULT_QUALITY .lfCharSet = CByte(Font.Charset And &HFF) End With CreateGDIFontFromOLEFont = CreateFontIndirect(LF) End Function Public Function CloneOLEFont(ByVal Font As IFont) As StdFont Font.Clone CloneOLEFont End Function Public Function GDIFontFromOLEFont(ByVal Font As IFont) As Long GDIFontFromOLEFont = Font.hFont End Function Public Function GetNumberGroupDigit() As String GetNumberGroupDigit = Mid$(FormatNumber(1000, 0, , , vbTrue), 2, 1) If GetNumberGroupDigit = "0" Then GetNumberGroupDigit = vbNullString End Function Public Function GetDecimalChar() As String GetDecimalChar = Mid$(CStr(1.1), 2, 1) End Function Public Function IsFormLoaded(ByVal FormName As String) As Boolean Dim i As Integer For i = 0 To Forms.Count - 1 If StrComp(Forms(i).Name, FormName, vbTextCompare) = 0 Then IsFormLoaded = True Exit For End If Next i End Function Public Function GetWindowTitle(ByVal hWnd As Long) As String Dim Buffer As String Buffer = String(GetWindowTextLength(hWnd) + 1, vbNullChar) GetWindowText hWnd, StrPtr(Buffer), Len(Buffer) GetWindowTitle = Left$(Buffer, Len(Buffer) - 1) End Function Public Function GetWindowClassName(ByVal hWnd As Long) As String Dim Buffer As String, RetVal As Long Buffer = String(256, vbNullChar) RetVal = GetClassName(hWnd, StrPtr(Buffer), Len(Buffer)) If RetVal <> 0 Then GetWindowClassName = Left$(Buffer, RetVal) End Function Public Sub CenterFormToScreen(ByVal Form As VB.Form, Optional ByVal RefForm As VB.Form) Const MONITOR_DEFAULTTOPRIMARY As Long = &H1 If RefForm Is Nothing Then Set RefForm = Form Dim hMonitor As Long, MI As MONITORINFO, WndRect As RECT hMonitor = MonitorFromWindow(RefForm.hWnd, MONITOR_DEFAULTTOPRIMARY) MI.cbSize = LenB(MI) GetMonitorInfo hMonitor, MI GetWindowRect Form.hWnd, WndRect If TypeOf Form Is VB.MDIForm Then Dim MDIForm As VB.MDIForm Set MDIForm = Form MDIForm.Move (MI.RCMonitor.Left + (((MI.RCMonitor.Right - MI.RCMonitor.Left) - (WndRect.Right - WndRect.Left)) \ 2)) * (1440 / DPI_X()), (MI.RCMonitor.Top + (((MI.RCMonitor.Bottom - MI.RCMonitor.Top) - (WndRect.Bottom - WndRect.Top)) \ 2)) * (1440 / DPI_Y()) Else Form.Move (MI.RCMonitor.Left + (((MI.RCMonitor.Right - MI.RCMonitor.Left) - (WndRect.Right - WndRect.Left)) \ 2)) * (1440 / DPI_X()), (MI.RCMonitor.Top + (((MI.RCMonitor.Bottom - MI.RCMonitor.Top) - (WndRect.Bottom - WndRect.Top)) \ 2)) * (1440 / DPI_Y()) End If End Sub Public Sub FlashForm(ByVal Form As VB.Form) Const FLASHW_CAPTION As Long = &H1, FLASHW_TRAY As Long = &H2, FLASHW_TIMERNOFG As Long = &HC Dim FWI As FLASHWINFO With FWI .cbSize = LenB(FWI) .dwFlags = FLASHW_CAPTION Or FLASHW_TRAY Or FLASHW_TIMERNOFG .hWnd = Form.hWnd .dwTimeout = 0 ' Default cursor blink rate .uCount = 0 End With FlashWindowEx FWI End Sub Public Function GetFormTitleBarHeight(ByVal Form As VB.Form) As Single Const SM_CYCAPTION As Long = 4, SM_CYMENU As Long = 15 Const SM_CYSIZEFRAME As Long = 33, SM_CYFIXEDFRAME As Long = 8 Dim CY As Long CY = GetSystemMetrics(SM_CYCAPTION) If GetMenu(Form.hWnd) <> 0 Then CY = CY + GetSystemMetrics(SM_CYMENU) Select Case Form.BorderStyle Case vbSizable, vbSizableToolWindow CY = CY + GetSystemMetrics(SM_CYSIZEFRAME) Case vbFixedSingle, vbFixedDialog, vbFixedToolWindow CY = CY + GetSystemMetrics(SM_CYFIXEDFRAME) End Select If CY > 0 Then GetFormTitleBarHeight = Form.ScaleY(CY, vbPixels, Form.ScaleMode) End Function Public Function GetFormNonScaleHeight(ByVal Form As VB.Form) As Single Const SM_CYCAPTION As Long = 4, SM_CYMENU As Long = 15 Const SM_CYSIZEFRAME As Long = 33, SM_CYFIXEDFRAME As Long = 8 Dim CY As Long CY = GetSystemMetrics(SM_CYCAPTION) If GetMenu(Form.hWnd) <> 0 Then CY = CY + GetSystemMetrics(SM_CYMENU) Select Case Form.BorderStyle Case vbSizable, vbSizableToolWindow CY = CY + (GetSystemMetrics(SM_CYSIZEFRAME) * 2) Case vbFixedSingle, vbFixedDialog, vbFixedToolWindow CY = CY + (GetSystemMetrics(SM_CYFIXEDFRAME) * 2) End Select If CY > 0 Then GetFormNonScaleHeight = Form.ScaleY(CY, vbPixels, Form.ScaleMode) End Function Public Sub SetWindowRedraw(ByVal hWnd As Long, ByVal Enabled As Boolean) Const WM_SETREDRAW As Long = &HB SendMessage hWnd, WM_SETREDRAW, IIf(Enabled = True, 1, 0), ByVal 0& If Enabled = True Then Const RDW_UPDATENOW As Long = &H100, RDW_INVALIDATE As Long = &H1, RDW_ERASE As Long = &H4, RDW_ALLCHILDREN As Long = &H80 RedrawWindow hWnd, 0, 0, RDW_UPDATENOW Or RDW_INVALIDATE Or RDW_ERASE Or RDW_ALLCHILDREN End If End Sub Public Function GetWindowsDir() As String Static Done As Boolean, Value As String If Done = False Then Dim Buffer As String Buffer = String(MAX_PATH, vbNullChar) If GetSystemWindowsDirectory(StrPtr(Buffer), MAX_PATH) <> 0 Then Value = Left$(Buffer, InStr(Buffer, vbNullChar) - 1) Value = Value & IIf(Right$(Value, 1) = "\", "", "\") End If Done = True End If GetWindowsDir = Value End Function Public Function GetSystemDir() As String Static Done As Boolean, Value As String If Done = False Then Dim Buffer As String Buffer = String(MAX_PATH, vbNullChar) If GetSystemDirectory(StrPtr(Buffer), MAX_PATH) <> 0 Then Value = Left$(Buffer, InStr(Buffer, vbNullChar) - 1) Value = Value & IIf(Right$(Value, 1) = "\", "", "\") End If Done = True End If GetSystemDir = Value End Function '==================================================================================== ' GetTempDir ' ' 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 GetTempDir() As String Static Done As Boolean, Value As String If Done = False Then Dim Buffer As String Buffer = String(MAX_PATH, vbNullChar) If GetTempPath(MAX_PATH, StrPtr(Buffer)) <> 0 Then Value = Left$(Buffer, InStr(Buffer, vbNullChar) - 1) Value = Value & IIf(Right$(Value, 1) = "\", "", "\") End If Done = True End If GetTempDir = Value End Function Public Function GetShiftStateFromParam(ByVal wParam As Long) As ShiftConstants Const MK_SHIFT As Long = &H4, MK_CONTROL As Long = &H8 If (wParam And MK_SHIFT) = MK_SHIFT Then GetShiftStateFromParam = vbShiftMask If (wParam And MK_CONTROL) = MK_CONTROL Then GetShiftStateFromParam = GetShiftStateFromParam Or vbCtrlMask If GetKeyState(vbKeyMenu) < 0 Then GetShiftStateFromParam = GetShiftStateFromParam Or vbAltMask End Function Public Function GetMouseStateFromParam(ByVal wParam As Long) As MouseButtonConstants Const MK_LBUTTON As Long = &H1, MK_RBUTTON As Long = &H2, MK_MBUTTON As Long = &H10 If (wParam And MK_LBUTTON) = MK_LBUTTON Then GetMouseStateFromParam = vbLeftButton If (wParam And MK_RBUTTON) = MK_RBUTTON Then GetMouseStateFromParam = GetMouseStateFromParam Or vbRightButton If (wParam And MK_MBUTTON) = MK_MBUTTON Then GetMouseStateFromParam = GetMouseStateFromParam Or vbMiddleButton End Function Public Function GetShiftStateFromMsg() As ShiftConstants If GetKeyState(vbKeyShift) < 0 Then GetShiftStateFromMsg = vbShiftMask If GetKeyState(vbKeyControl) < 0 Then GetShiftStateFromMsg = GetShiftStateFromMsg Or vbCtrlMask If GetKeyState(vbKeyMenu) < 0 Then GetShiftStateFromMsg = GetShiftStateFromMsg Or vbAltMask End Function Public Function GetMouseStateFromMsg() As MouseButtonConstants If GetKeyState(vbLeftButton) < 0 Then GetMouseStateFromMsg = vbLeftButton If GetKeyState(vbRightButton) < 0 Then GetMouseStateFromMsg = GetMouseStateFromMsg Or vbRightButton If GetKeyState(vbMiddleButton) < 0 Then GetMouseStateFromMsg = GetMouseStateFromMsg Or vbMiddleButton End Function Public Function GetShiftState() As ShiftConstants GetShiftState = (-vbShiftMask * KeyPressed(vbKeyShift)) GetShiftState = GetShiftState Or (-vbCtrlMask * KeyPressed(vbKeyControl)) GetShiftState = GetShiftState Or (-vbAltMask * KeyPressed(vbKeyMenu)) End Function Public Function GetMouseState() As MouseButtonConstants Const SM_SWAPBUTTON As Long = 23 ' GetAsyncKeyState requires a mapping of physical mouse buttons to logical mouse buttons. GetMouseState = (-vbLeftButton * KeyPressed(IIf(GetSystemMetrics(SM_SWAPBUTTON) = 0, vbLeftButton, vbRightButton))) GetMouseState = GetMouseState Or (-vbRightButton * KeyPressed(IIf(GetSystemMetrics(SM_SWAPBUTTON) = 0, vbRightButton, vbLeftButton))) GetMouseState = GetMouseState Or (-vbMiddleButton * KeyPressed(vbMiddleButton)) End Function Public Function KeyToggled(ByVal KeyCode As KeyCodeConstants) As Boolean KeyToggled = CBool(LoByte(GetKeyState(KeyCode)) = 1) End Function Public Function KeyPressed(ByVal KeyCode As KeyCodeConstants) As Boolean KeyPressed = CBool((GetAsyncKeyState(KeyCode) And &H8000&) = &H8000&) End Function Public Function InIDE(Optional ByRef b As Boolean = True) As Boolean If b = True Then Debug.Assert Not InIDE(InIDE) Else b = True End Function Public Function PtrToObj(ByVal ObjectPointer As Long) As Object Dim TempObj As Object CopyMemory TempObj, ObjectPointer, 4 Set PtrToObj = TempObj CopyMemory TempObj, 0&, 4 End Function Public Function ProcPtr(ByVal Address As Long) As Long ProcPtr = Address End Function Public Function LoByte(ByVal Word As Integer) As Byte LoByte = Word And &HFF End Function Public Function HiByte(ByVal Word As Integer) As Byte HiByte = (Word And &HFF00&) \ &H100 End Function Public Function MakeWord(ByVal LoByte As Byte, ByVal HiByte As Byte) As Integer If (HiByte And &H80) <> 0 Then MakeWord = ((HiByte * &H100&) Or LoByte) Or &HFFFF0000 Else MakeWord = (HiByte * &H100) Or LoByte End If End Function Public Function LoWord(ByVal DWord As Long) As Integer If DWord And &H8000& Then LoWord = DWord Or &HFFFF0000 Else LoWord = DWord And &HFFFF& End If End Function Public Function HiWord(ByVal DWord As Long) As Integer HiWord = (DWord And &HFFFF0000) \ &H10000 End Function Public Function MakeDWord(ByVal LoWord As Integer, ByVal HiWord As Integer) As Long MakeDWord = (CLng(HiWord) * &H10000) Or (LoWord And &HFFFF&) End Function Public Function Get_X_lParam(ByVal lParam As Long) As Long Get_X_lParam = lParam And &H7FFF& If lParam And &H8000& Then Get_X_lParam = Get_X_lParam Or &HFFFF8000 End Function Public Function Get_Y_lParam(ByVal lParam As Long) As Long Get_Y_lParam = (lParam And &H7FFF0000) \ &H10000 If lParam And &H80000000 Then Get_Y_lParam = Get_Y_lParam Or &HFFFF8000 End Function Public Function UTF32CodePoint_To_UTF16(ByVal CodePoint As Long) As String If CodePoint >= &HFFFF8000 And CodePoint <= &H10FFFF Then Dim HW As Integer, LW As Integer If CodePoint < &H10000 Then HW = 0 LW = CUIntToInt(CodePoint And &HFFFF&) Else CodePoint = CodePoint - &H10000 HW = (CodePoint \ &H400) + &HD800 LW = (CodePoint Mod &H400) + &HDC00 End If If HW = 0 Then UTF32CodePoint_To_UTF16 = ChrW(LW) Else UTF32CodePoint_To_UTF16 = ChrW(HW) & ChrW(LW) End If End Function Public Function UTF16_To_UTF8(ByRef Source As String) As Byte() Const CP_UTF8 As Long = 65001 Dim Length As Long, Pointer As Long, Size As Long Length = Len(Source) Pointer = StrPtr(Source) Size = WideCharToMultiByte(CP_UTF8, 0, Pointer, Length, 0, 0, 0, 0) If Size > 0 Then Dim Buffer() As Byte ReDim Buffer(0 To Size - 1) As Byte WideCharToMultiByte CP_UTF8, 0, Pointer, Length, VarPtr(Buffer(0)), Size, 0, 0 UTF16_To_UTF8 = Buffer() End If End Function Public Function UTF8_To_UTF16(ByRef Source() As Byte) As String If (0 / 1) + (Not Not Source()) = 0 Then Exit Function Const CP_UTF8 As Long = 65001 Dim Size As Long, Pointer As Long, Length As Long Size = UBound(Source) - LBound(Source) + 1 Pointer = VarPtr(Source(LBound(Source))) Length = MultiByteToWideChar(CP_UTF8, 0, Pointer, Size, 0, 0) If Length > 0 Then UTF8_To_UTF16 = Space$(Length) MultiByteToWideChar CP_UTF8, 0, Pointer, Size, StrPtr(UTF8_To_UTF16), Length End If End Function Public Function StrToVar(ByVal Text As String) As Variant If Text = vbNullString Then StrToVar = Empty Else Dim b() As Byte b() = Text StrToVar = b() End If End Function Public Function VarToStr(ByVal Bytes As Variant) As String If IsEmpty(Bytes) Then VarToStr = vbNullString Else Dim b() As Byte b() = Bytes VarToStr = b() End If End Function Public Function UnsignedAdd(ByVal Start As Long, ByVal Incr As Long) As Long UnsignedAdd = ((Start Xor &H80000000) + Incr) Xor &H80000000 End Function Public Function UnsignedSub(ByVal Start As Long, ByVal Decr As Long) As Long UnsignedSub = ((Start And &H7FFFFFFF) - (Decr And &H7FFFFFFF)) Xor ((Start Xor Decr) And &H80000000) End Function Public Function CUIntToInt(ByVal Value As Long) As Integer Const OFFSET_2 As Long = 65536 Const MAXINT_2 As Integer = 32767 If Value < 0 Or Value >= OFFSET_2 Then Err.Raise 6 If Value <= MAXINT_2 Then CUIntToInt = Value Else CUIntToInt = Value - OFFSET_2 End If End Function Public Function CIntToUInt(ByVal Value As Integer) As Long Const OFFSET_2 As Long = 65536 If Value < 0 Then CIntToUInt = Value + OFFSET_2 Else CIntToUInt = Value End If End Function Public Function CULngToLng(ByVal Value As Double) As Long Const OFFSET_4 As Double = 4294967296# Const MAXINT_4 As Long = 2147483647 If Value < 0 Or Value >= OFFSET_4 Then Err.Raise 6 If Value <= MAXINT_4 Then CULngToLng = Value Else CULngToLng = Value - OFFSET_4 End If End Function Public Function CLngToULng(ByVal Value As Long) As Double Const OFFSET_4 As Double = 4294967296# If Value < 0 Then CLngToULng = Value + OFFSET_4 Else CLngToULng = Value End If End Function Public Function DPI_X() As Long Const LOGPIXELSX As Long = 88 Dim hDCScreen As Long hDCScreen = GetDC(0) If hDCScreen <> 0 Then DPI_X = GetDeviceCaps(hDCScreen, LOGPIXELSX) ReleaseDC 0, hDCScreen End If End Function Public Function DPI_Y() As Long Const LOGPIXELSY As Long = 90 Dim hDCScreen As Long hDCScreen = GetDC(0) If hDCScreen <> 0 Then DPI_Y = GetDeviceCaps(hDCScreen, LOGPIXELSY) ReleaseDC 0, hDCScreen End If End Function Public Function DPICorrectionFactor() As Single Static Done As Boolean, Value As Single If Done = False Then Value = ((96 / DPI_X()) * 15) / Screen.TwipsPerPixelX Done = True End If ' Returns exactly 1 when no corrections are required. DPICorrectionFactor = Value End Function Public Function CHimetricToPixel_X(ByVal Width As Long) As Long Const HIMETRIC_PER_INCH As Long = 2540 CHimetricToPixel_X = (Width * DPI_X()) / HIMETRIC_PER_INCH End Function Public Function CHimetricToPixel_Y(ByVal Height As Long) As Long Const HIMETRIC_PER_INCH As Long = 2540 CHimetricToPixel_Y = (Height * DPI_Y()) / HIMETRIC_PER_INCH End Function Public Function PixelsPerDIP_X() As Single Static Done As Boolean, Value As Single If Done = False Then Value = (DPI_X() / 96) Done = True End If PixelsPerDIP_X = Value End Function Public Function PixelsPerDIP_Y() As Single Static Done As Boolean, Value As Single If Done = False Then Value = (DPI_Y() / 96) Done = True End If PixelsPerDIP_Y = Value End Function Public Function WinColor(ByVal Color As Long, Optional ByVal hPal As Long) As Long If OleTranslateColor(Color, hPal, WinColor) <> 0 Then WinColor = -1 End Function Public Function PictureFromByteStream(ByRef ByteStream As Variant) As IPictureDisp Const GMEM_MOVEABLE As Long = &H2 Dim IID As CLSID, Stream As IUnknown, NewPicture As IPicture Dim b() As Byte, ByteCount As Long Dim hMem As Long, lpMem As Long With IID .Data1 = &H7BF80980 .Data2 = &HBF32 .Data3 = &H101A .Data4(0) = &H8B .Data4(1) = &HBB .Data4(3) = &HAA .Data4(5) = &H30 .Data4(6) = &HC .Data4(7) = &HAB End With If VarType(ByteStream) = (vbArray + vbByte) Then b() = ByteStream ByteCount = (UBound(b()) - LBound(b())) + 1 hMem = GlobalAlloc(GMEM_MOVEABLE, ByteCount) If hMem <> 0 Then lpMem = GlobalLock(hMem) If lpMem <> 0 Then CopyMemory ByVal lpMem, b(LBound(b())), ByteCount GlobalUnlock hMem If CreateStreamOnHGlobal(hMem, 1, Stream) = 0 Then If OleLoadPicture(Stream, ByteCount, 0, IID, NewPicture) = 0 Then Set PictureFromByteStream = NewPicture End If End If End If End If End Function Public Function PictureFromPath(ByVal PathName As String) As IPictureDisp Dim IID As CLSID, NewPicture As IPicture With IID .Data1 = &H7BF80980 .Data2 = &HBF32 .Data3 = &H101A .Data4(0) = &H8B .Data4(1) = &HBB .Data4(3) = &HAA .Data4(5) = &H30 .Data4(6) = &HC .Data4(7) = &HAB End With If OleLoadPicturePath(StrPtr(PathName), 0, 0, 0, IID, NewPicture) = 0 Then Set PictureFromPath = NewPicture End Function Public Function PictureFromHandle(ByVal Handle As Long, ByVal PicType As VBRUN.PictureTypeConstants) As IPictureDisp If Handle = 0 Then Exit Function Dim PICD As PICTDESC, IID As CLSID, NewPicture As IPicture With PICD .cbSizeOfStruct = LenB(PICD) .PicType = PicType .hImage = Handle End With With IID .Data1 = &H7BF80980 .Data2 = &HBF32 .Data3 = &H101A .Data4(0) = &H8B .Data4(1) = &HBB .Data4(3) = &HAA .Data4(5) = &H30 .Data4(6) = &HC .Data4(7) = &HAB End With If OleCreatePictureIndirect(PICD, IID, 1, NewPicture) = 0 Then Set PictureFromHandle = NewPicture End Function Public Function BitmapHandleFromPicture(ByVal Picture As IPictureDisp, Optional ByVal BackColor As OLE_COLOR) As Long If Picture Is Nothing Then Exit Function With Picture If .Handle <> 0 Then Dim hDCScreen As Long, hDC As Long, hBmp As Long, hBmpOld As Long Dim CX As Long, CY As Long, Brush As Long CX = CHimetricToPixel_X(.Width) CY = CHimetricToPixel_Y(.Height) Brush = CreateSolidBrush(WinColor(BackColor)) hDCScreen = GetDC(0) If hDCScreen <> 0 Then hDC = CreateCompatibleDC(hDCScreen) If hDC <> 0 Then hBmp = CreateCompatibleBitmap(hDCScreen, CX, CY) If hBmp <> 0 Then hBmpOld = SelectObject(hDC, hBmp) If .Type = vbPicTypeIcon Then Const DI_NORMAL As Long = &H3 DrawIconEx hDC, 0, 0, .Handle, CX, CY, 0, Brush, DI_NORMAL Else Dim RC As RECT RC.Right = CX RC.Bottom = CY FillRect hDC, RC, Brush .Render hDC Or 0&, 0&, 0&, CX Or 0&, CY Or 0&, 0&, .Height, .Width, -.Height, ByVal 0& End If SelectObject hDC, hBmpOld BitmapHandleFromPicture = hBmp End If DeleteDC hDC End If ReleaseDC 0, hDCScreen End If DeleteObject Brush End If End With End Function Public Sub RenderPicture(ByVal Picture As IPicture, ByVal hDC As Long, ByVal x As Long, ByVal Y As Long, Optional ByVal CX As Long, Optional ByVal CY As Long, Optional ByRef RenderFlag As Integer) ' RenderFlag is passed as a optional parameter ByRef. ' It is ignored for icons and metafiles. ' 0 = render method unknown, determine it and update parameter ' 1 = StdPicture.Render ' 2 = GdiAlphaBlend If Picture Is Nothing Then Exit Sub With Picture If .Handle <> 0 Then If CX = 0 Then CX = CHimetricToPixel_X(.Width) If CY = 0 Then CY = CHimetricToPixel_Y(.Height) If .Type = vbPicTypeIcon Then Const DI_NORMAL As Long = &H3 DrawIconEx hDC, x, Y, .Handle, CX, CY, 0, 0, DI_NORMAL Else Dim HasAlpha As Boolean If .Type = vbPicTypeBitmap Then If RenderFlag = 0 Then Const PICTURE_TRANSPARENT As Long = &H2 If (.Attributes And PICTURE_TRANSPARENT) = 0 Then ' Exclude GIF Dim Bmp As BITMAP GetObjectAPI .Handle, LenB(Bmp), Bmp If Bmp.BMBitsPixel = 32 And Bmp.BMBits <> 0 Then Dim SA1D As SAFEARRAY1D, b() As Byte With SA1D .cDims = 1 .fFeatures = 0 .cbElements = 1 .cLocks = 0 .pvData = Bmp.BMBits .Bounds.lLbound = 0 .Bounds.cElements = Bmp.BMWidthBytes * Bmp.BMHeight End With CopyMemory ByVal ArrPtr(b()), VarPtr(SA1D), 4 Dim i As Long, j As Long, Pos As Long For i = 0 To (Abs(Bmp.BMHeight) - 1) Pos = i * Bmp.BMWidthBytes For j = (Pos + 3) To (Pos + Bmp.BMWidthBytes - 1) Step 4 If HasAlpha = False Then HasAlpha = (b(j) > 0) If HasAlpha = True Then If b(j - 1) > b(j) Then HasAlpha = False i = Abs(Bmp.BMHeight) - 1 Exit For ElseIf b(j - 2) > b(j) Then HasAlpha = False i = Abs(Bmp.BMHeight) - 1 Exit For ElseIf b(j - 3) > b(j) Then HasAlpha = False i = Abs(Bmp.BMHeight) - 1 Exit For End If End If Next j Next i CopyMemory ByVal ArrPtr(b()), 0&, 4 End If End If If HasAlpha = False Then RenderFlag = 1 Else RenderFlag = 2 ElseIf RenderFlag = 2 Then HasAlpha = True End If End If If HasAlpha = False Then .Render hDC Or 0&, x Or 0&, Y Or 0&, CX Or 0&, CY Or 0&, 0&, .Height, .Width, -.Height, ByVal 0& Else Dim hDCBmp As Long, hBmpOld As Long hDCBmp = CreateCompatibleDC(0) If hDCBmp <> 0 Then hBmpOld = SelectObject(hDCBmp, .Handle) GdiAlphaBlend hDC, x, Y, CX, CY, hDCBmp, 0, 0, CHimetricToPixel_X(.Width), CHimetricToPixel_Y(.Height), &H1FF0000 SelectObject hDCBmp, hBmpOld DeleteDC hDCBmp End If End If End If End If End With End Sub 'Searches a listbox for a string. You can specify at what index you wish to start. 0 to start at the beginning of the list. 'Returns the listindex where the string is found. If there are no items in the list, then it will exit the function. 'Then sets the listindex, or selected item, of the list onto the string if it was found. 'If the string is not found, then a value of -1 is returned. 'Example: Listbox_Search (List1, "TEST",1) - will search List1, starting from index #1, for "TEST". 'Ex. 2: Listbox_Search (List1, "X") - searches List1 for "X" from the beginning. Case sensitive. If X is not there, then will return a value of -1. Public Function Listbox_Search(listbox As listbox, str As String, Optional ByVal starting As Integer = 0) As Integer Listbox_Search = -1 If starting >= 0 Then If listbox.ListCount > 0 Then For starting = starting To listbox.ListCount - 1 DoEvents If listbox.List(starting) = str Then Listbox_Search = starting listbox.ListIndex = starting Exit For End If Next End If End If End Function '==================================================================================== ' 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 ' --------------------------------- ' ' 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 'Get Handle wrapper for active or specified form or foreground window 'Optional frm specifies form, if not get active Public Function GetHandle(Optional ByVal frm As Form = Nothing) As Long If frm Is Nothing Then If Not Screen.ActiveForm Is Nothing Then GetHandle = Screen.ActiveForm.hWnd Else GetHandle = GetActiveWindow() If GetHandle = 0 Then GetHandle = GetForegroundWindow() If GetHandle = 0 Then Call Err.Raise(361, "GetHandle", "Unable to Get any Handle") End If Else GetHandle = frm.hWnd 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 '==================================================================================== ' 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 '==================================================================================== ' 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 Public Function FileRead(FileID As Long, Optional FileStart As Long = -1, Optional FileEnd As Long = -1) As Byte() Dim FileContents As String If FileEnd = -1 Then FileContents = Space$(LOF(FileID)) Else FileContents = Space$(LOF(FileID) - FileEnd) End If If FileStart = -1 Then Get FileID, , FileContents Else Get FileID, FileStart, FileContents End If FileRead = FileContents End Function