Attribute VB_Name = "GLOBALS" Attribute VB_Description = "Collection of useful parameters and functions for use by all programs." Attribute VB_Ext_KEY = "RVB_UniqueId" ,"34EE53920352" 'GLOBALS.BAS - Utility subroutines to support all VB5 projects. ' Includes declaration of entry points to the Windows API. Option Explicit Global Const CB_ERR = -1 Global Const CB_FINDSTRING = &H14C Global Const PROCESS_ALL_ACCESS = &H1F0FFF Global Const PROCESS_QUERY_INFORMATION = &H400 Global Const STILL_ACTIVE = &H103 Global Const SW_RESTORE = 9 Global Const WF_WINNT = &H4000 Public Const GW_CHILD = 5 Public Const GW_HWNDFIRST = 0 Public Const GW_HWNDLAST = 1 Public Const GW_HWNDNEXT = 2 Public Const GW_HWNDPREV = 3 Public Const GW_OWNER = 4 Public Const GWL_ID = -12 Public Const SE_ERR_NOASSOC = 31 'Declare Function GetFreeSpace Lib "Kernel" (ByVal wFlags As Integer) As Long Declare Function BringWindowToTop Lib "user32" (ByVal hWnd As Long) As Long Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Declare Function FlashWindow Lib "user32" (ByVal hWnd As Long, ByVal bInvert As Long) As Long Declare Function GetActiveWindow Lib "user32" () As Long Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long Declare Function GetDesktopWindow Lib "user32" () As Long Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long Declare Function GetPrivateProfileInt Lib "kernel32" Alias "GetPrivateProfileIntA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal nDefault As Long, ByVal lpFileName As String) As Long Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long Declare Function GetVersion Lib "kernel32" () As Long Declare Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long Declare Function GetWindowLW Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long Declare Function GetWinFlags Lib "kernel32" Alias "GetWinFlagsA" () As Long Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Declare Function SetFocusAPI Lib "user32" Alias "SetForegroundWindow" (ByVal hWnd As Long) As Long 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 Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long Declare Function WinHelp Lib "user32" Alias "WinHelpA" (ByVal hWnd As Long, ByVal lpHelpFile As String, ByVal wCommand As Long, ByVal dwData As Long) As Long Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long Declare Sub ExitProcess Lib "kernel32" (ByVal uExitCode As Long) Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'Type for SystemHeapInfo Type SYSHEAPINFO dwSize As Long wUserFreePercent As Integer wGDIFreePercent As Integer hUserSegment As Integer hGDISegment As Integer End Type Declare Function SystemHeapInfo Lib "toolhelp.dll" (shi As SYSHEAPINFO) As Integer Type OSVERSIONINFO dwOSVersionInfoSize As Long dwMajorVersion As Long dwMinorVersion As Long dwBuildNumber As Long dwPlatformId As Long szCSDVersion As String * 128 ' Maintenance string for PSS usage End Type Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long Global SystemVersionInfo As OSVERSIONINFO Global ErStr As String Global ErCode As Long Global ErLine As Integer Global ProgramName As String 'name of project/program Global ThePath As String 'the path where the program resides Global IniFileName As String 'fully qualified name of .ini file for program Global Editor As String 'Fully qualified name of the editor of choice Global UserName As String 'Name of logged on user; obtained via GetUserName 'Idle Timer variables ' Add a timer and its associated timer event to a program ' to use these items. In this event set the timer interval ' to IdleCountInterval and check IdleCount against ' via the IdleTimeExpired function. IdleTimeExpired takes ' care of incrementing IdleCount and returns TRUE when ' IdleCount > IdleLimit, it's time to stop by ' whatever mechanism the program wishes to use. The ' value of IdleCount is reset to 0 whenever the dbOpen ' function, DataBase.BAS, is executed. You can reset ' the value at any other time that indicates activity. ' The values in IdleLimit and IdleCountInterval provide ' for a 15 minute time limit. Global IdleCount As Integer 'number of consecutive 10 second intervals of no database activity Global Const IdleLimit = 900 'max number of consecutive 10 second idle database intervals Global Const IdleCountInterval = 1000 'Help Constants Global Const HELP_CONTEXT = &H1 'Display topic in ulTopic Global Const HELP_QUIT = &H2 'Terminate help Global Const HELP_INDEX = &H3 'Display index Global Const HELP_CONTENTS = &H3 Global Const HELP_HELPONHELP = &H4 'Display help on using help Global Const HELP_SETINDEX = &H5 'Set the current Index for multi index help Global Const HELP_SETCONTENTS = &H5 Global Const HELP_CONTEXTPOPUP = &H8 Global Const HELP_FORCEFILE = &H9 Global Const HELP_KEY = &H101 'Display topic for keyword Global Const HELP_COMMAND = &H102 Global Const HELP_PARTIALKEY = &H105 'call the search engine in winhelp 'RGB Color Constants Global Const Color_Aqua = "#00FFFF" Global Const Color_Black = "#000000" Global Const Color_Blue = "#0000FF" Global Const Color_Gray = "#C0C0C0" Global Const Color_Green = "#00FF00" Global Const Color_Manila = "#FFFFA0" Global Const Color_PaleAqua = "#A0FFFF" Global Const Color_Red = "#FF0000" Global Const Color_White = "#FFFFFF" Global Const Color_Yellow = "#C0C000" Sub Abort(s As String) 'Abort the current process with a Message Box displaying the string provided in S Attribute Abort.VB_Description = "Abort the current process with a Message Box displaying the string provided in S" MsgBox s, vbCritical, "We Gotta Give Up!" Call ExitProcess(999) End Sub Function AddPath(s As String) As String 'Add path value to file name if not already specified Attribute AddPath.VB_Description = "Add path value to file name if not already specified" If InStr(s, ":") = 0 And InStr(s, "\\") = 0 Then AddPath = ThePath + s 'no path given; add it Else AddPath = s 'path already provided End If End Function Function BooleanString(I) As String 'returns "True" or "False" based on the value of I Attribute BooleanString.VB_Description = "returns ""True"" or ""False"" based on the value of I" If I Then BooleanString = "True" Else BooleanString = "False" End Function Function ChangeChar(s As String, C1 As String, C2 As String) As String 'Change all occurances of C1 with C2 in the string S. Attribute ChangeChar.VB_Description = "Change all occurances of C1 with C2 in the string S" Dim ans As String 'result string Dim l As Long 'position of C1 in Lcl Dim Lcl As String 'internal copy of S Lcl = s If Lcl <> "" Then l = InStr(Lcl, C1) Else l = 0 End If While l <> 0 ans = ans + Left$(Lcl, l - 1) + C2 Lcl = Right$(Lcl, Len(Lcl) - (l - 1 + Len(C1))) l = InStr(Lcl, C1) Wend ChangeChar = ans + Lcl End Function Function ConCat(S1 As String, Sep As String, S2 As String) As String 'returns S1+Sep+S2 if S2 <> "", otherwise returns S1; if S1 = "" returns S2 Attribute ConCat.VB_Description = "returns S1+Sep+S2 if S2 <> """"; otherwise returns S1" If Trim(S2) <> "" Then If S1 = "" Then ConCat = S2 Else ConCat = S1 + Sep + S2 End If Else ConCat = S1 End If End Function Function ConCatAll(S1 As String, Sep As String, S2 As String) As String 'returns S1+Sep+S2 regardless of the content of S2; if S1 = "" returns S2 Attribute ConCatAll.VB_Description = "returns S1+Sep+S2 regardless of the content of S2; if S1 = """" returns S2" If S1 = "" Then ConCatAll = S2 Else ConCatAll = S1 + Sep + S2 End If End Function Function ConcatDistinct(S1 As String, Sep As String, S2 As String) As String 'uses ConCat to form S1+Sep+S2 only if S2 is not already contained in S1 Attribute ConcatDistinct.VB_Description = "uses ConCat to form S1+Sep+S2 only if S2 is not already contained in S1" If InStr(S1, S2) = 0 Then ConcatDistinct = ConCat(S1, Sep, S2) Else ConcatDistinct = S1 End If End Function Function ConditionPath(s) 'Guarantees trailing \ on path value S Attribute ConditionPath.VB_Description = "Guarantees trailing \\ on path value S" Dim ans As String ans = Trim(s) If ans = "\" Then ans = "" 'eliminate \ only If ans <> "" Then 'prevent \ only If Right$(ans, 1) <> "\" Then ans = ans & "\" End If ConditionPath = ans End Function Function Confirm(s) As Boolean 'get user confirmation on the action indicated by S Attribute Confirm.VB_Description = "get user confirmation on the action indicated by S" Dim Resp As Integer Resp = MsgBox(s, vbYesNo, "Please Confirm") 'Get user response. Confirm = Resp = vbYes '=True if User said yes, else False End Function Function CountChars(txt, Chrs) As Long 'Returns number of occurrances of Chrs in Txt Dim ct As Long Dim I As Long ct = 0 I = InStr(txt, Chrs) While I <> 0 ct = ct + 1 I = InStr(I + 1, txt, Chrs) Wend CountChars = ct End Function Function dbEncloseString(s As String) As String ' Enclose the string item S in apostrophes. Change any embedded appostrophe's to ' double aphostrophes Const Container = "'" dbEncloseString = Container + ChangeChar(s, "'", "''") + Container 'return our result End Function Sub Dec(A, B) 'returns A - B Attribute Dec.VB_Description = "returns A - B" A = A - B End Sub Function DeleteChar(T As String, c As String) As String 'Delete all occurances of C in string S Attribute DeleteChar.VB_Description = "Delete all occurances of C in string S" Dim I As Long Dim s As String Dim lenc As Integer If c = "" Then DeleteChar = T Exit Function End If lenc = Len(c) s = T I = InStr(s, c) While I <> 0 If I = 1 Then s = Right$(s, Len(s) - lenc) ElseIf I = Len(s) Then s = Left$(s, Len(s) - lenc) Else s = Left$(s, I - 1) + Right$(s, Len(s) - lenc - (I - 1)) End If If s <> "" Then I = InStr(s, c) Else I = 0 End If Wend DeleteChar = s End Function Sub EndOnPrevInstance() Attribute EndOnPrevInstance.VB_Description = "Terminates the application if another instance of it is already running" If App.PrevInstance Then 'application already running Call ExitProcess(0) 'terminate this instance End If End Sub Function Exists(FileName As String) As Integer 'Determine if FileName exists. Answer <> 0 (True) if it does. Attribute Exists.VB_Description = "Determine if FileName exists. Answer <> 0 (True) if it does." On Error Resume Next Exists = Len(Dir$(FileName)) <> 0 And FileName <> "" If Err <> 0 Then Exists = False On Error GoTo 0 End Function Function ExpandTab(s As String) As String 'Replaces each occurance of the Tab (#09) character in S with blanks} Attribute ExpandTab.VB_Description = "Replaces each occurance of the Tab (#09) character in S with blanks}" Dim I As Long Dim Temp As String Temp = "" 'initialize output string} For I = 1 To Len(s) 'scan through the input string} If Mid$(s, I, 1) = Chr$(9) Then 'look for a TAB character} Temp = Temp + " " 'generate the corresponding blanks} If I > 1 Then 'for all cases past the beginning of the string} While (Len(Temp) - 1) Mod 8 <> 0 'make the blanks End at a TAB stop} Temp = Left$(Temp, Len(Temp) - 1) Wend End If Else Temp = Temp + Mid$(s, I, 1) End If Next 'I ExpandTab = Temp End Function Function Extract(txt As String, Pattern As String) Attribute Extract.VB_Description = "Extract value identified by Pattern from Txt and return to caller; Format of Txt is assumed as Pattern=value followed by at least 1 blank" ' Extract value identified by Pattern from Txt and return to caller ' Format of Txt is assumed as Pattern=value followed by at least 1 blank Dim CTxt As String Dim ans As String Dim PLen As Integer Dim Indx As Integer Dim Indxe As Integer ans = "" 'initial answer is empty string If txt = "" Then Extract = ans 'return empty string if no text to search Exit Function End If CTxt = UCase$(txt) 'force source string to upper case PLen = Len(Pattern) 'get length of item to search for Indx = InStr(1, CTxt, Pattern) 'locate Pattern in capitalized Txt If Indx = 0 Then 'not found; return empty string Extract = ans Exit Function End If Indxe = InStr(Indx + PLen, CTxt, " ") 'locate first blank after Pattern If Indxe = 0 Then 'not found; return empty string Extract = ans Exit Function End If If UCase$(Pattern) = "DESC:" Then Indxe = Len(txt) + 1 txt = txt + " " End If 'return text following Pattern and before trailing blank Extract = Mid$(txt, Indx + PLen, Indxe - Indx - PLen) End Function Function FindWindowLike(hWndArray(), ByVal hWndStart As Long, WindowText As String, Classname As String, ID) As Long Attribute FindWindowLike.VB_Description = "Finds the window handles of all windows matching the specified parameters" 'Finds the window handles of all windows matching the specified parameters ' 'hwndArray() - Integer array used to return the window handles 'hWndStart - The handle of the window to search under. The ' routine searches through all of this window's ' children and their children recursively. If ' hWndStart = 0 then search through all windows. 'WindowText - Pattern used with Like op. to compare window's text. 'ClassName - Pattern used with Like op. to compare window's class name. 'ID - Child ID number used to identify a window. ' To ignore ID pass vbNull function. 'Returns - Number of windows that matched the parameters. '---------------------------------------------------------------------- Dim hWnd As Long Dim R As Long 'Hold the level of recursion: Static Level As Long 'Hold the number of matching windows: Static iFound As Long Dim sWindowText As String Dim sClassname As String Dim sID On Error GoTo FindWindowLikeError If Level = 0 Then 'Initialize if necessary: iFound = 0 ReDim hWndArray(0 To 0) If hWndStart = 0 Then hWndStart = GetDesktopWindow() End If Level = Level + 1 'Increase recursion counter: hWnd = GetWindow(hWndStart, GW_CHILD) 'Get first child window: Do Until hWnd = 0 DoEvents 'Not necessary ' Search children by recursion: R = FindWindowLike(hWndArray(), hWnd, WindowText, Classname, ID) sWindowText = Space(255) 'Get the window text and class name: R = GetWindowText(hWnd, sWindowText, 255) sWindowText = Left(sWindowText, R) sClassname = Space(255) R = GetClassName(hWnd, sClassname, 255) sClassname = Left(sClassname, R) If GetParent(hWnd) <> 0 Then 'If window is a child get the ID: R = GetWindowLW(hWnd, GWL_ID) sID = CLng("&H" & Hex(R)) Else sID = Null End If ' Check that window matches the search parameters: If sWindowText Like WindowText And sClassname Like Classname Then If IsNull(ID) Then iFound = iFound + 1 'If find a match, increment counter and add handle to array: ReDim Preserve hWndArray(0 To iFound) hWndArray(iFound) = hWnd ElseIf Not IsNull(sID) Then If CLng(sID) = CLng(ID) Then iFound = iFound + 1 'If find a match increment counter and add handle to array: ReDim Preserve hWndArray(0 To iFound) hWndArray(iFound) = hWnd End If End If Debug.Print "Window Found: " Debug.Print " Window Text : " & sWindowText Debug.Print " Window Class : " & sClassname Debug.Print " Window Handle: " & CStr(hWnd) End If hWnd = GetWindow(hWnd, GW_HWNDNEXT) 'Get next child window: Loop Level = Level - 1 'Decrement recursion counter: FindWindowLike = iFound 'Return the number of windows found: Exit Function FindWindowLikeError: FindWindowLike = iFound 'Return the number of windows found: Err.Raise Err.Number, "", "Globals.FindWindowLike Error: " + Err.Description End Function Sub FlashCaption(hWnd As Long, Count As Integer, Interval As Single) Attribute FlashCaption.VB_Description = "Flash the caption of the window identified by hWnd, Count times with\r\n Interval seconds between flashes." ' Flash the caption of the window identified by hWnd, Count times with ' Interval seconds between flashes. Dim I As Integer Dim ETime As Single For I = 0 To Count 'loop through the requested count Call FlashWindow(hWnd, True) 'start flashing If Interval >= 0.1 Then 'protect against tiny interval ETime = Timer + Interval 'compute end of next interval Else ETime = Timer + 0.1 End If Do While Timer < ETime 'wait for interval to expire DoEvents Loop Next 'I Call FlashWindow(hWnd, False) 'put window back to normal End Sub Sub FSplit(str As String, FilePath As String, FileName As String, Ext As String) 'Split FileName into its parts Dim LName As String 'local copy of FileName Dim I As Integer FileName = "" FilePath = "" Ext = "" LName = str 'get local copy of FileName I = InStr(LName, ".") If I <> 0 Then Ext = Right$(LName, Len(LName) - I + 1) LName = Left$(LName, I - 1) End If If InStr(LName, "\") = 0 Then FileName = LName Exit Sub 'no path End If I = Len(LName) While I > 0 And Mid$(LName, I, 1) <> "\" I = I - 1 Wend If I = 0 Then FileName = LName ElseIf I = Len(LName) Then FilePath = LName Else FilePath = Left$(LName, I) FileName = Right$(LName, Len(LName) - I) End If End Sub Sub FSplitLong(str As String, FilePath As String, FileNameShort As String, FileNameLong As String, Ext As String) Dim T As String Dim lt As Integer Call FSplit(str, FilePath, FileNameLong, Ext) T = Space(255) lt = Len(T) Call GetShortPathName(str, T, lt) T = ChangeChar(T, Chr$(0), " ") T = Trim(T) Call FSplit(T, FilePath, FileNameShort, Ext) End Sub Function GetCommand(Arg As Integer, Default As String) As String ' Get specified command argument for program execution ' Arg = which argument to retrieve; 1, 2, 3, etc. If specified argument ' does not exist, return empty string ' Default = string value to use if no argument given ' If a command is retrieved that begins with /, it is treated as an option and therefore ' the default string is returned. Dim tmp As String Dim ans As String Dim index As Integer Dim pos As Integer tmp = Trim(Command$) & " " 'retrieve command string from system tmp = ChangeChar(tmp, "''", "@@@") 'preserve embedded apostrophes 'WDK 30-Jun-98 11:19 ans = Default 'result initial empty index = 0 'start before first arg If Left$(tmp, 1) = "'" Then pos = InStr(2, tmp, "'") 'get position of bounding apostrophe ElseIf Left$(tmp, 1) = Chr$(34) Then pos = InStr(2, tmp, Chr$(34)) 'get position of bounding quote mark Else pos = InStr(tmp, " ") 'get position of blank End If While index < Arg And tmp <> " " 'loop until done If pos <> 0 Then 'found blank index = index + 1 'count as argument If index = Arg Then 'this requested arg ans = Left$(tmp, pos - 1) 'return arg value If InStr("'" + Chr$(34), Mid$(tmp, pos, 1)) <> 0 Then ans = Right$(ans, Len(ans) - 1) tmp = " " 'force end of loop Else tmp = Trim(Right$(tmp, Len(tmp) - pos + 1)) & " " 'remove arg from string If Left$(tmp, 1) = "'" Then pos = InStr(2, tmp, "'") + 1 'get position of bounding apostrophe ElseIf Left$(tmp, 1) = Chr$(34) Then pos = InStr(2, tmp, Chr$(34)) + 1 'get position of bounding quote mark Else pos = InStr(tmp, " ") 'get position of blank End If End If End If Wend ans = ChangeChar(ans, "@@@", "''") 'restore embedded apostrophes 'WDK 30-Jun-98 11:20 If Left$(ans, 1) = "/" Then ans = Default 'treat as option GetCommand = ans 'return what we found End Function Function GetErrorString(ErCode) As String ErCode = Err GetErrorString = "ErrorCode=" + str(ErCode) + " " + Error + "." End Function Function GetLocalProfileInt(SectionName As String, ItemName As String, Default As Integer) As Integer GetLocalProfileInt = GetPrivateProfileInt(ByVal SectionName, ByVal ItemName, Default, "Win.INI") End Function Function GetLocalProfileText(SectionName As String, ItemName As String, Default As String) As String Dim ans As String * 255 Dim Result As Integer ans = "" Result = GetPrivateProfileString(ByVal SectionName, ByVal ItemName, ByVal Default, ans, Len(ans), "Win.INI") ans = (Left$(ans, Result)) If Trim(ans) = "" Then ans = Default GetLocalProfileText = Trim(ans) End Function Function GetOption(Arg As String, Default As String) As String ' Get specified option argument from program command line. ' An option is defined as a string preceeded by / ' Arg = which argument to retrieve; a, m, -, etc. If specified argument ' does not exist, return empty string. Arg should not contain / ' Default = string value to use if no argument given Dim tmp As String Dim Opt As String Dim ans As String Dim index As Integer Dim iend As Integer tmp = UCase$(Trim(Command$)) + " " 'retrieve command string from system tmp = ChangeChar(tmp, "''", "@@@") 'preserve embedded apostrophes ans = Default 'result initial empty Opt = "/" + UCase$(Arg) 'create option string index = InStr(tmp, Opt) 'look for option in command line If index <> 0 Then 'option located; retrieve it ans = "" index = index + Len(Opt) 'point to start of option value If Mid$(tmp, index, 1) = Chr$(34) Then 'option starts with " index = index + 1 iend = InStr(index, tmp, Chr$(34)) - 1 'ergo, option ends with " ElseIf Mid$(tmp, index, 1) = "'" Then 'option starts with ' index = index + 1 iend = InStr(index, tmp, "'") - 1 'ergo, option ends with ' Else iend = InStr(index, tmp, " ") - 1 'else option ends with encountered blank End If ans = Mid$(tmp, index, iend - index + 1) End If If ans <> "" Then If InStr("'" + Chr$(34), Left$(ans, 1)) <> 0 Then ans = Mid$(ans, 2, Len(ans) - 2) ans = ChangeChar(ans, "@@@", "''") 'restore embedded apostrophes End If GetOption = ans 'return what we found End Function Function GetOSVersion() 'Returns 3 if Win3.1 or Win3.11; Returns 95 if Win95 Dim lRet As Long Dim nret As Long Dim MajorVer As Integer Dim MinorVer As Integer Const LowByteMask = &HFF& Const SecondByteMask = &HFF00& 'Get Long version code lRet = GetVersion() If lRet = 0 Then 'failed GetOSVersion = 0 Exit Function End If 'parse out major and minor version numbers MajorVer = LowByteMask And lRet MinorVer = (SecondByteMask And lRet) / 256 'Win 3.x and Win95 are both MajorVer=3 If MajorVer <> 3 Then 'don't know GetOSVersion = 0 Exit Function End If Select Case MinorVer Case 0 'Win3.0 GetOSVersion = 3 Case 10 'possibly NT nret = GetWinFlags() If nret And WF_WINNT Then GetOSVersion = 0 Else GetOSVersion = 3 'Win3.1 End If Case 11 'Win3.11 GetOSVersion = 3 Case 95 'Win95 GetOSVersion = 95 Case Else GetOSVersion = 0 'don't know End Select End Function Function GetProfileInt(PName As String, ItemName As String, Default As Long) As Long If PName = "" Then GetProfileInt = GetPrivateProfileInt(ByVal ProgramName, ByVal ItemName, Default, IniFileName) Else GetProfileInt = GetPrivateProfileInt(ByVal PName, ByVal ItemName, Default, IniFileName) End If End Function Function GetProfileSingle(PName As String, ItemName As String, Default As String) As Single GetProfileSingle = Val(GetProfileText(PName, ItemName, Default)) End Function Function GetProfileText(PName As String, ItemName As String, Default As String) As String Dim ans As String * 255 Dim Result As Integer ans = "" If PName = "" Then Result = GetPrivateProfileString(ByVal ProgramName, ByVal ItemName, ByVal Default, ans, Len(ans), IniFileName) ans = (Left$(ans, Result)) Else Result = GetPrivateProfileString(ByVal PName, ByVal ItemName, ByVal Default, ans, Len(ans), IniFileName) ans = (Left$(ans, Result)) End If If Trim(ans) = "" Then ans = Default GetProfileText = Trim(ans) End Function Function GetSeqNum(SeqFileName As String, Base, Limit) As Long 'Returns next sequence number from SeqFileName. Base is the minimum value and 'Limit is the upper limit of the generated sequence number. Dim SeqHandle As Integer Dim Seq As String Dim SeqNum As Long Seq = Format$(Base, "000000") SeqHandle = FreeFile If Exists(SeqFileName) Then Open SeqFileName For Input As #SeqHandle Line Input #SeqHandle, Seq Close (SeqHandle) SeqNum = Val(Trim(Seq)) If SeqNum >= Limit Then SeqNum = Base - 1 SeqNum = SeqNum + 1 Seq = Format$(SeqNum, "000000") End If Open SeqFileName For Output As #SeqHandle Print #SeqHandle, Seq Close (SeqHandle) GetSeqNum = Val(Trim(Seq)) End Function Public Function GetStringArg(Arg, Def) As String Dim ans As String If IsNull(Arg) Then 'no value desired; return empty string ans = "" ElseIf Arg = "" Then 'argument value not given; use default value ans = Def Else 'use supplied argument value ans = Arg End If GetStringArg = ans End Function Sub HandleError(ReportToUser As Boolean, Module As String, SubName As String, ErrNum As Long, ErrDesc As String, Optional line = 0) Dim s As String Err.Clear s = Module + "." + SubName If line <> 0 Then s = s + " line" + str(line) + ": Error" + str(ErrNum) s = s + vbCrLf + ErrDesc If ReportToUser Then 'show to the user now MsgBox s Else 'pass error up the chain Err.Raise ErrNum, "", s End If End Sub Function IdleTimeExpired() As Boolean IdleCount = IdleCount + 1 If IdleCount >= IdleLimit Then IdleTimeExpired = True Else IdleTimeExpired = False End Function Sub Inc(A, B) 'Increment A by B A = A + B End Sub Function InsertString(S1 As String, S2 As String, l As Long) 'Insert S2 into S1 after character L InsertString = Left$(S1, l) + S2 + Right$(S1, Len(S1) - l) End Function Sub LogResourceStatus(s As String) 'Log system resouces Dim nl As String * 2 Dim shi As SYSHEAPINFO Dim Memory As Long Dim msg As String 'If Dbg = 0 Then Exit Sub 'nl = Chr(13) + Chr(10) 'Memory = GetFreeSpace(0) 'Msg = "Free Memory=" + Format$(Memory \ 1024, "###,###,###") + "K=" + Format$(Memory, "###,###,###,###") + nl 'shi.dwSize = Len(shi) 'If SystemHeapInfo(shi) Then ' Msg = Msg + " User Free=" + Format$(shi.wUserFreePercent) + "%" + nl ' Msg = Msg + " GDI Free=" + Format$(shi.wGDIFreePercent) + "%" + nl 'End If End Sub Function LongFileName(ShortFileName) As String LongFileName = Dir(ShortFileName, vbNormal + vbHidden + vbSystem + vbDirectory) End Function Function LPad(s As String, l As Long) 'prefix string with blanks to desired length Attribute LPad.VB_Description = "prefix string with blanks to desired length" LPad = LPadChar(s, l, " ") End Function Function LPadChar(s As String, l As Long, c As String) 'prefix string with c to desired length Attribute LPadChar.VB_Description = "prefix string with c to desired length" Dim ans As String ans = s While Len(ans) < l ans = c & ans Wend LPadChar = ans End Function Function Max(A, B) If A > B Then Max = A Else Max = B End Function Function Min(A, B) If A < B Then Min = A Else Min = B End Function Function NTProove(pwrd As String) As String Dim stab(1 To 15) As Integer Dim xcnt As Integer Dim rnum As Integer Dim hold As String Dim ctab As String Dim dtab As String Dim nent As Integer Dim ipos As Integer Dim swp As Integer If Trim(pwrd) = "" Then NTProove = "" Exit Function End If xcnt = 1 ' (Initialize Password Swap Table) For xcnt = 1 To 15 stab(xcnt) = xcnt Next xcnt xcnt = 1 ' (Generate The Swap Table) rnum = 111 While xcnt <= 15 rnum = ((rnum * xcnt) + 17&) Mod 16& If rnum >= 1 And rnum <= 15 Then If rnum <> xcnt Then swp = stab(rnum) stab(rnum) = stab(xcnt) stab(xcnt) = swp xcnt = xcnt + 1 End If End If Wend xcnt = 15 ' (Reverse Shuffle) While xcnt >= 1 hold = Mid$(pwrd, xcnt, 1) Mid$(pwrd, xcnt, 1) = Mid$(pwrd, stab(xcnt), 1) Mid$(pwrd, stab(xcnt), 1) = hold xcnt = xcnt - 1 Wend ctab = " [.<(+]&!$*);^-/|,%_>?`:#@'=" + Chr$(34) ' (Define Character Table) ctab = ctab + "abcdefghijklmnopqr~stuvwxyzABCDEFGHI}JKLMNOPQR\STUVWXYZ0123456789" dtab = ctab xcnt = 1 ' (Randomize Character Table) rnum = 1713 nent = Len(ctab) While xcnt <= nent rnum = ((rnum * xcnt) + nent + 1) Mod nent + 1 If rnum >= 1 And rnum <= nent Then If rnum <> xcnt Then hold = Mid$(dtab, rnum, 1) Mid$(dtab, rnum, 1) = Mid$(dtab, xcnt, 1) Mid$(dtab, xcnt, 1) = hold xcnt = xcnt + 1 End If End If Wend For xcnt = 1 To 15 ' (Reverse Character Substitutions) ipos = InStr(dtab, Mid$(pwrd, xcnt, 1)) If ipos >= 1 And ipos <= Len(dtab) Then Mid$(pwrd, xcnt, 1) = Mid$(ctab, ipos, 1) End If Next xcnt NTProove = pwrd ' (Return Original Password) End Function Function OrdinalOfNum(Num) As String 'Returns Ordinal string from integer Num Dim T As String 'text equivalent of Num Dim suf As String 'Ordinal suffix T = CStr(Num) 'Num assumed to be positive Select Case Right$(T, 2) Case "11", "12", "13" suf = "th" Case Else Select Case Right$(T, 1) Case "0", "4" To "9" suf = "th" Case "1" suf = "st" Case "2" suf = "nd" Case "3" suf = "rd" End Select End Select OrdinalOfNum = T + suf End Function Function Pad(s As String, l As Long) 'postfix string with blanks to desired length Dim ans As String If Len(s) > l Then Pad = Left$(s, l) Exit Function End If ans = s While Len(ans) < l ans = ans & " " Wend Pad = ans End Function Function Padch(s As String, l As Long, c As String) 'postfix string with desired string to desired length Dim ans As String If Len(s) > l Then Padch = Left$(s, l) Exit Function End If ans = s While Len(ans) < l ans = ans & c Wend Padch = ans End Function Sub ParsePath(T As String, p As String, F As String) 'Pick path and filename from a string Dim s As String 'local copy of T Dim I As Integer 'index into string Dim E As String 'file extent s = T If s <> "" Then 'is there work to do I = InStr(s, ".") 'look for extent indicator If I <> 0 Then 'extent exists E = Right$(s, Len(s) - I + 1) 'set extent s = Left$(s, I - 1) 'remove extent from string Else E = "" 'set no extent End If F = "" 'assume no file name For I = Len(s) To 1 Step -1 'loop backwards through string If Mid$(s, I, 1) = "\" Then F = Right$(s, Len(s) - I) 'set file name p = Left$(s, I) 'remove file name from string I = 1 'force loop end End If Next F = F + E 'reconstruct file name End If End Sub Sub ProcessParm(l As String, Match As String, Result As String) Dim Posn As Integer Posn = InStr(l, Match) 'look for Match in Line If Posn <> 0 Then 'if found Result = Trim(Right$(l, Len(l) - (Posn - 1 + Len(Match)))) 'return what's after Match End If End Sub Sub PutLocalProfileText(SectionName As String, ItemName As String, txt As String) 'Write string 'Txt' to Win.ini in section 'SectionName' with the name 'ItemName' Dim Result As Integer Dim s As String Dim IniSave As String IniSave = IniFileName IniFileName = "Win.ini" Result = WritePrivateProfileString(ByVal SectionName, ByVal ItemName, ByVal txt, IniFileName) IniFileName = IniSave End Sub Sub PutProfileText(Sect As String, Item As String, V As String) 'Write string 'V' to the .ini file in section 'Sect' with the name 'Item' Dim Result As Integer If Sect = "" Then Result = WritePrivateProfileString(ByVal ProgramName, ByVal Item, ByVal V, IniFileName) Else Result = WritePrivateProfileString(ByVal Sect, ByVal Item, ByVal V, IniFileName) End If End Sub Function RandomName() As String 'Create random 8 character name Dim s As String s = Trim(str(Int(Rnd * 1000000#))) RandomName = "$" + s + "$" End Function Function RemoveThePath(s As String) As String 'If S begins with ThePath, return S with ThePath removed. 'Using this with .ini files, allows them to be moved to new 'directories without change as long as the associated data files are in 'the same directory as the program. If InStr(UCase$(s), UCase$(ThePath)) = 1 Then RemoveThePath = Right$(s, Len(s) - Len(ThePath)) Else RemoveThePath = s End If End Function Sub RenameFile(OldName As String, NewName As String) 'rename file; delete new file first in case of collision If OldName = NewName Then Exit Sub If Not Exists(OldName) Then MsgBox "Cannot rename " + OldName + " to " + NewName + ". It does not exist", vbExclamation, "Something's no quite right!" Exit Sub End If On Error GoTo BadKill If Exists(NewName) Then Kill NewName 'delete file to prevent rename collision GoTo GoodKill BadKill: MsgBox "Unable to delete " + NewName + ". please do so manually and rename " + NewName + " as " + OldName, vbCritical, "Oops!" Call ExitProcess(0) GoodKill: End If If Not Exists(NewName) Then Name OldName As NewName 'perform the requested rename Else MsgBox "Unable to rename " + OldName + " to " + NewName + ". please do so manually", vbCritical, "Oops!" Call ExitProcess(0) End If End Sub Function ReverseString(s As String) As String 'Reproduce string S in reverse order Dim ans As String Dim I As Integer ans = "" For I = Len(s) To 1 Step -1 ans = ans + Mid$(s, I, 1) Next 'I ReverseString = ans End Function Function Round(N As Variant, DecPlaces%) As Variant 'Round N to decplaces; if decplaces=0, an integer results Dim tmp As Double, DecShift As Long tmp = CDbl(N) DecShift = 10 ^ DecPlaces% Round = (Fix((tmp + 0.5 / DecShift) * DecShift)) / DecShift End Function Function Rplc(s As String, p As String) As String 'Replace the first occurrance of ! in S with P Dim ans As String Dim I As Long ans = s I = InStr(s, "!") If I <> 0 Then ans = Left$(s, I - 1) + p + Right$(s, Len(s) - I) End If Rplc = ans End Function Sub SelectTextBox(txt As TextBox) 'select contents of the textbox txt txt.SelStart = 0 txt.SelLength = Len(txt) End Sub Sub SetAppPath(ProgName As String, IniName As String) 'Set ProgramName & path to app, help, ini files ProgramName = ProgName ThePath = ConditionPath(CStr(App.Path)) If IniName = "" Then IniFileName = AddPath(GetCommand(1, ProgramName + ".INI")) App.HelpFile = ThePath + ProgramName + ".HLP" Else IniFileName = AddPath(GetCommand(1, IniName + ".INI")) App.HelpFile = ThePath + IniName + ".HLP" End If End Sub Function Shell32Bit(ByVal JobToDo As String, wMode As Integer) As Long 'Shell to program and wait for completion Dim hProcess As Long Dim RetVal As Long On Error GoTo Shell32BitError 'Launch JobToDo as icon and capture process ID in hProcess hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, Shell(JobToDo, wMode)) Do GetExitCodeProcess hProcess, RetVal 'Get the status of the process DoEvents: Sleep 100 'Sleep command recommended as well as DoEvents Loop While RetVal = STILL_ACTIVE 'Loop while the process is active Shell32Bit = RetVal 'send exit code back to caller Exit Function Shell32BitError: Err.Raise Err.Number, "", "Globals.Shell32Bit Error: " + Err.Description Shell32Bit = Err.Number End Function Sub ShellDoc(strFile As String) 'opens strFile using its associated program Dim lngRet As Long Dim strDir As String 'try executing normally in case an association exists lngRet = ShellExecute(GetDesktopWindow, "open", strFile, vbNullString, vbNullString, vbNormalFocus) If lngRet = SE_ERR_NOASSOC Then 'no association; let user pick one strDir = Space(260) lngRet = GetSystemDirectory(strDir, Len(strDir)) Call ShellExecute(GetDesktopWindow, vbNullString, "RUNDLL32.EXE", "shell32.dll,OpenAs_RunDll " + strFile, strDir, vbNormalFocus) End If End Sub Sub TagAddParm(Text As String, Parm As String, value As String) 'Add a parameter and value pair to Text. Text is normally supplied as the Tag 'property of a control. Dim Text1 As String If Not IsNull(TagGetParm(Text, Parm)) Then Text1 = TagDelParm(Text, Parm) Else Text1 = Text End If If Text1 <> "" Then Text1 = Text1 + ";" Text = Text1 + Parm + "=" + value End Sub Function TagDelParm(Text As String, Parm As String) As String Dim I As Integer Dim J As Integer Dim S1 As String Dim S2 As String Dim Text1 As String Text1 = Text I = InStr(UCase$(Text), UCase$(Parm) + "=") If I > 0 Then If I = 1 Then S1 = "" Else S1 = Left$(Text, I - 2) End If J = InStr(I, Text, ";") If J > 0 Then S2 = Mid$(Text, J + 1) Else S2 = "" End If If S1 = "" Or S2 = "" Then Text1 = S1 + S2 Else Text1 = S1 + ";" + S2 End If End If TagDelParm = Text1 End Function Function TagGetParm(Text As String, Parm As String) Dim I As Integer Dim J As Integer Dim Text1 As String If Len(Text) Then If Left$(Text, 1) <> "'" Then Text1 = ";" + Text + ";" I = InStr(LCase$(Text1), ";" + LCase(Parm) + "=") + 1 If I > 1 Then J = InStr(I + Len(Parm), Text1, ";") TagGetParm = Mid$(Text1, I - Len(Parm) + 1, J - I - Len(Parm) - 1) Else TagGetParm = Null End If Else TagGetParm = Null End If Else TagGetParm = Null End If End Function Sub UsePrevInstance() 'Show window and set focus to previous instance of current application, if running. Dim hWnd As Integer Dim iResult As Integer Dim Ttl As String If App.PrevInstance Then 'application already running 'Thunderform is the class name for VB forms Ttl = App.Title hWnd = FindWindow("ThunderForm", Ttl) 'Find the existing instance If hWnd <> 0 Then 'matching window found iResult = ShowWindow(hWnd, SW_RESTORE) 'restore window if minimized iResult = SetFocusAPI(hWnd) 'set focus to specified window Call ExitProcess(0) 'terminate this instance End If End If End Sub Function WindowsProgram(s As String) As Integer '=True if the program is a Windows program Dim FileNum As Integer Dim FileString As String * 1000 Dim FP As String Dim FN As String Dim Ext As String Call FSplit(s, FP, FN, Ext) If Ext = ".BAT" Or Ext = ".COM" Then WindowsProgram = False Exit Function ElseIf Ext = ".PIF" Then WindowsProgram = True Exit Function End If FileNum = FreeFile 'get an available file number On Error Resume Next 'in case program is too small to read Open s For Binary As #FileNum Len = 1000 'open the program executable for input Get #FileNum, , FileString 'read enough to get "Windows required" message Close #FileNum 'don't forget to close! WindowsProgram = InStr(UCase$(FileString), UCase$("This program cannot be run in DOS mode.")) <> 0 On Error GoTo 0 'reset the error trapping End Function Function WrapText(txt, Optional LineLength = 80, Optional LineSeparator = vbCrLf, Optional Leader = "", Optional Delimeters = " ") As String 'Performs wrapping on Txt with output lines set at LineLength and separated by LineSeparator. Leader provides a prefix for the first line and Delimeters indicates the possible line breaking characters. Dim LL As Integer 'line length Dim LS As String 'line separator Dim Ldr As String 'line leader Dim Del As String 'line delimeters Dim st As String 'output string Dim ss As String 'substring Dim T As String 'local copy of input string Dim pos As Long 'delimeter location LL = LineLength 'pick up input values LS = LineSeparator Ldr = Leader Del = Delimeters T = Trim(txt) + " " 'make local copy of string st = "" 'initialize output string While T > " " 'loop until we're done pos = Min(Len(T), LL) 'move to end of display line While pos > 0 And InStr(Del, Mid$(T, pos, 1)) = 0 'look backward for a delimeter pos = pos - 1 Wend ss = Ldr + Left$(T, pos) 'construct current line If st = "" Then st = ss 'start output string Else st = st + LS + ss 'add to output string End If If Ldr <> "" Then Ldr = Pad("", Len(Ldr)) 'replace leader with blanks for clearer multi-line output T = Trim(Right$(T, Len(T) - pos)) + " " 'remove used part from source text Wend 'end of loop until we're done WrapText = st 'send result back to caller End Function Function UnWrapText(txt, Optional LineSeparator = vbCrLf) As String Dim s As String s = DeleteChar(CStr(txt), CStr(LineSeparator)) End Function Function ValidChars(ValidLetters As String, TestString As String) As Boolean 'Returns TRUE if all chars in TestString are found in ValidLetters Dim I As Byte ValidChars = True If TestString = "" Then Exit Function For I = 1 To Len(TestString) If InStr(UCase$(ValidLetters), UCase$(Mid$(TestString, I, 1))) = 0 Then ValidChars = False Exit Function End If Next 'i End Function Function ZeroLeftField(fld, FldLen) As String 'Left pad Fld with zeros as needed to achieve a lenth of FldLen Dim ans As String ans = Trim("" & fld) If Len(Trim(ans)) > 0 Then 'If field contains info While Len(Trim(ans)) < FldLen 'Supply leading zeroes as needed ans = "0" & ans Wend End If ans = Trim(Pad(ans, CLng(FldLen))) 'protect against overly long input field ZeroLeftField = ans End Function Sub Close_Globals() 'Close debug if open; optionally print debug file End Sub Sub GetProfile_Globals() 'Load private .INI file info 1 Dim I As Integer 2 Const GName = "Globals" 3 Dim Name As String * 50 4 Const namelen As Long = 50 5 On Error GoTo HandleTheError 6 Call GetUserName(Name, namelen) 'get name of logged on user 7 I = InStr(Name, Chr$(0)) 'find end of name string 8 If I > 0 Then UserName = Left$(Name, I - 1) Else UserName = "" 'extract user name 9 Editor = GetProfileText(GName, "Editor", "NotePad.exe") 10 Call PutProfile_Globals 11 SystemVersionInfo.dwOSVersionInfoSize = 148 12 Call GetVersionEx(SystemVersionInfo) 'get operating system information 13 Exit Sub HandleTheError: 14 MsgBox "GLOBALS.GetProfile_Globals " + Error$ + " line" + str(Erl) + " error=" + str(Err), vbOKOnly, "Write This Down!" End Sub Private Sub PutProfile_Globals() ' Save private .INI file info Call PutProfileText("Globals", "Editor", Editor) End Sub