modVisualBasic -1118555947 310 100000918 310 100000721 220 209001836 183 209001724 183 209001639 209 200001836 181 0 modVisualBasic 536 0 vbCrLf As String vbCr As String vbLf As String vbFormFeed As String vbNewLine As String vbTab As String vbVerticalTab As String vbBack As String Null As Variant Nothing As Variant vbNullChar As String vbNullString As String vbBlack As Color vbWhite As Color vbGray As Color vbSilver As Color vbRed As Color vbYellow As Color vbGreen As Color vbCyan As Color vbBlue As Color vbMagenta As Color vbDarkRed As Color vbDarkYellow As Color vbDarkGreen As Color vbTeal As Color vbDarkBlue As Color vbPurple As Color vbKeyA As String vbKeyB As String vbKeyC As String vbKeyD As String vbKeyE As String vbKeyF As String vbKeyG As String vbKeyH As String vbKeyI As String vbKeyJ As String vbKeyK As String vbKeyL As String vbKeyM As String vbKeyN As String vbKeyO As String vbKeyP As String vbKeyQ As String vbKeyR As String vbKeyS As String vbKeyT As String vbKeyU As String vbKeyV As String vbKeyW As String vbKeyX As String vbKeyY As String vbKeyZ As String vbKey0 As String vbKey1 As String vbKey2 As String vbKey3 As String vbKey4 As String vbKey5 As String vbKey6 As String vbKey7 As String vbKey8 As String vbKey9 As String vbBinaryCompare As Integer vbTextCompare As Integer vbNull As Integer vbInteger As Integer vbDouble As Integer vbSingle As Integer vbDate As Integer vbString As Integer vbObject As Integer vbBoolean As Integer vbColor As Integer vbOKOnly As Integer vbOKCancel As Integer vbAbordRetryIgnore As Integer vbYesNoCancel As Integer vbYesNo As Integer vbRetryCancel As Integer vbNoIcon As Integer vbCritical As Integer vbQuestion As Integer vbExclamation As Integer vbInformation As Integer vbDefaultButton1 As Integer vbDefaultButton2 As Integer vbDefaultButton3 As Integer vbDefaultButtonNone As Integer vbOK As Integer vbCancel As Integer vbAbort As Integer vbRetry As Integer vbIgnore As Integer vbYes As Integer vbNo As Integer m_Initialized As Boolean vbButtonFace As Color vbButtonText As Color vb3DHighlight As Color vbButtonShadow As Color vbHighlight As Color vb3DFace As Color vb3DShadow As Color vb3DDKShadow As Color vb3DLight As Color vbActiveBorder As Color vbActiveTitleBar As Color vbActiveTitleBarText As Color vbApplicationWorkspace As Color vbDesktop As Color vbGrayText As Color vbHighlightText As Color vbInactiveBorder As Color vbInactiveCaptionText As Color vbInactiveTitleBar As Color vbInactiveTitleBarText As Color vbInfoBackground As Color vbInfoText As Color vbMenuBar As Color vbMenuText As Color vbScrollBars As Color vbTitleBarText As Color vbWindowBackground As Color vbWindowFrame As Color vbWindowText As Color g_TempWindow As Window 134217984 modVisualBasic_Description 1 14 22 14 22 134217984 modVisualBasic_Description '============================================================================================================= ' ' modVisualBasic Module ' --------------------- ' ' Created By : Kevin Wilson ' http://www.TheVBZone.com ( The VB Zone ) ' http://net.TheVBZone.com ( The VB Zone .NET ) ' http://rb.TheVBZone.com ( The VB Zone [RB] ) ' ' Created On : January 18, 2004 ' Last Update : Oct 06, 2004 ' ' RB Versions : 5.5 (or later) ' ' Requires : NOTHING ' ' Description : This module gives you access to some standard Visual Basic constants and functions that are ' native to Visual Basic 5.0, 6.0, and .NET. This allows programmers who are used to Visual ' Visual Basic make easier use of REALbasic. ' ' IMPORTANT : MAKE SURE TO CALL THE "InitializeVB" FUNCTION AT THE VERY BEGINNING OF YOUR APPLICATION ' '============================================================================================================= ' ' LEGAL: ' ' You are free to use this code as long as you keep the above heading information intact and unchanged. Credit ' given where credit is due. Also, it is not required, but it would be appreciated if you would mention ' somewhere in your compiled program that that your program makes use of code written and distributed by ' Kevin Wilson (www.TheVBZone.com). Feel free to link to this code via your web site or articles. ' ' You may NOT take this code and pass it off as your own. You may NOT distribute this code on your own server ' or web site. You may NOT take code created by Kevin Wilson (www.TheVBZone.com) and use it to create products, ' utilities, or applications that directly compete with products, utilities, and applications created by Kevin ' Wilson, TheVBZone.com, or Wilson Media. You may NOT take this code and sell it for profit without first ' obtaining the written consent of the author Kevin Wilson. ' ' These conditions are subject to change at the discretion of the owner Kevin Wilson at any time without 27207761726E696E67206F72206E6F746963652E2020436F70797269676874C2A9206279204B6576696E2057696C736F6E2E2020416C6C207269676874732072657365727665642E ' '============================================================================================================= 134217984 InitializeVB 0 104 10 104 14 134217984 Sub InitializeVB() ' NOTE: YOU MUST CALL THIS FUNCTION AT THE VERY BEGINNING OF YOUR APPLICATION SO THAT ' VALUES ARE SETUP PROPERLY FOR USE ' If this function has previously been called, don't go through it again If m_Initialized = True Then Return ' String Constants vbCrLf = Chr(13) + Chr(10) vbCr = Chr(13) vbLf = Chr(10) vbNewLine = Chr(13) + Chr(10) vbTab = Chr(9) vbBack = Chr(8) vbFormFeed = Chr(12) vbVerticalTab = Chr(11) vbNullChar = Chr(0) vbNullString = "" Null = Nil Nothing = Nil ' Color Constants vbBlack = RGB(0, 0, 0) vbBlue = RGB(0, 0, 255) vbCyan = RGB(0, 255, 255) vbGreen = RGB(0, 255, 0) vbMagenta = RGB(255, 0, 255) vbRed = RGB(255, 0, 0) vbWhite = RGB(255, 255, 255) vbYellow = RGB(255, 255, 0) vbDarkBlue = RGB(0, 0, 128) vbDarkGreen = RGB(0, 128, 0) vbDarkRed = RGB(128, 0, 0) vbDarkYellow = RGB(128, 128, 0) vbGray = RGB(128, 128, 128) vbSilver = RGB(192, 192, 192) vbPurple = RGB(128, 0, 128) vbTeal = RGB(0, 128, 128) ' System Color Constants vb3DFace = FillColor() vb3DHighlight = LightBevelColor() vb3DShadow = DarkBevelColor() vbButtonFace = FillColor() vbButtonShadow = DarkBevelColor() vbButtonText = TextColor() vbHighlight = HighlightColor() ' Windows only system color constants SetWinColors ' Compare Methods vbBinaryCompare = 0 vbTextCompare = 1 ' Key Code Constants vbKeyA = "A" vbKeyB = "B" vbKeyC = "C" vbKeyD = "D" vbKeyE = "E" vbKeyF = "F" vbKeyG = "G" vbKeyH = "H" vbKeyI = "I" vbKeyJ = "J" vbKeyK = "K" vbKeyL = "L" vbKeyM = "M" vbKeyN = "N" vbKeyO = "O" vbKeyP = "P" vbKeyQ = "Q" vbKeyR = "R" vbKeyS = "S" vbKeyT = "T" vbKeyU = "U" vbKeyV = "V" vbKeyW = "W" vbKeyX = "X" vbKeyY = "Y" vbKeyZ = "Z" vbKey0 = "0" vbKey1 = "1" vbKey2 = "2" vbKey3 = "3" vbKey4 = "4" vbKey5 = "5" vbKey6 = "6" vbKey7 = "7" vbKey8 = "8" vbKey9 = "9" ' Variable Type Constants (for use with the "VarType" function) vbNull = 0 'NOTE: A "Variant" data type will return vbNull until you assign a value to it. Then it will return the type that best represents the value it contains. vbInteger = 2 vbDouble = 5 vbSingle = 5 vbDate = 7 'NOTE: A "Date" object that has not yet been initialized will return 9 (vbObject) when VarType is called vbString = 8 vbObject = 9 vbBoolean = 11 vbColor = 16 ' MsgBox Button Constants vbOKOnly = 0 vbOKCancel = 1 vbAbordRetryIgnore = 2 vbYesNoCancel = 3 vbYesNo = 4 vbRetryCancel = 5 ' MsgBox Icon Constants vbNoIcon = 0 vbCritical = 16 vbQuestion = 32 vbExclamation = 48 vbInformation = 64 vbDefaultButton1 = 0 vbDefaultButton2 = 256 vbDefaultButton3 = 512 vbDefaultButtonNone = 768 ' MsgBox Result Constants vbOK = 1 vbCancel = 2 vbAbort = 3 vbRetry = 4 vbIgnore = 5 vbYes = 6 vbNo = 7 ' Finished m_Initialized = True End Sub 134217984 Now String 0 5 0 5 0 134217984 Function Now() As String Dim datDate As Date datDate = New Date Return CStr(datDate.Month) + "/" + CStr(datDate.Day) + "/" + CStr(datDate.Year) + " " + datDate.LongTime End Function 134217984 CInt Value As Variant Integer 0 3 0 3 0 134217984 Function CInt(Value As Variant) As Integer ' Returns an 4-byte (32-bit) number Dim objErr As RuntimeException If IsNumeric(Trim(Value.StringValue)) = False Then objErr = New RuntimeException objErr.ErrorNumber = 13 objErr.Message = "Type Mismatch" Raise objErr Else If Value.DoubleValue < -2147483648 Or Value.DoubleValue > 2147483647 Then objErr = New RuntimeException objErr.ErrorNumber = 6 objErr.Message = "Overflow" Raise objErr Else Return Value.IntegerValue End If End If End Function 134217984 CDate Value As Variant Date 0 15 66 15 66 134217984 Function CDate(Value As Variant) As Date ' NOTE: "Value.DaveValue" wasn't used because it returns funky date values for non-date values Dim datDate As Date Dim objErr As RuntimeException ' If the data type is DATE already, then return it immediately If VarType(Value) = vbDate Then Return Value.DateValue ' If ParseDate returns TRUE... it's a date ElseIf ParseDate(Value.StringValue, datDate) = True Then Return Value.DateValue ' Otherwise, it's not a date (or ParseDate was unable to parse it) Else objErr = New RuntimeException objErr.ErrorNumber = 13 objErr.Message = "Type Mismatch" Raise objErr End If End Function 134217984 CBool Value As Variant Boolean 0 17 0 17 0 134217984 Function CBool(Value As Variant) As Boolean ' NOTE: "Value.BooleanValue" was not used because the definition of "True" is any non-zero value. ' "Value.BooleanValue" returns FALSE for "-1" and "2"... both should be TRUE. Select Case Uppercase(Trim(Value.StringValue)) Case "FALSE", "0" Return False Case "TRUE", "1", "-1" Return True Else If IsNumeric(Value.StringValue) = True Then Return True Else Return False End If End Select End Function 134217984 CSng Value As Variant Single 0 1 0 1 0 134217984 Function CSng(Value As Variant) As Single Return Value.DoubleValue End Function 134217984 CColor Value As Variant Color 0 1 0 1 0 134217984 Function CColor(Value As Variant) As Color Return Value.ColorValue End Function 134217984 CObj Value As Variant Object 0 2 24 2 24 134217984 Function CObj(Value As Variant) As Object Return Value.ObjectValue End Function 134217984 Time String 0 5 0 5 0 134217984 Function Time() As String Dim datDate As Date datDate = New Date Return datDate.LongTime End Function 134217984 DateVB String 0 5 0 5 0 134217984 Function DateVB() As String Dim datDate As Date datDate = New Date Return CStr(datDate.Month) + "/" + CStr(datDate.Day) + "/" + CStr(datDate.Year) End Function 134217984 UCase Value As String String 0 2 13 2 13 134217984 Function UCase(Value As String) As String Return UpperCase(Value) End Function 134217984 LCase Value As String String 0 1 0 1 0 134217984 Function LCase(Value As String) As String Return Lowercase(Value) End Function 134217984 GetErrorInfo ByRef objErr As RunTimeException, ByRef Return_ErrNum As Integer, ByRef Return_ErrType As String, ByRef Return_ErrDesc As String 0 1 0 1 0 134217984 Sub GetErrorInfo(ByRef objErr As RunTimeException, ByRef Return_ErrNum As Integer, ByRef Return_ErrType As String, ByRef Return_ErrDesc As String) ' Set default values Return_ErrType = "Unknown" Return_ErrDesc = objErr.Message Return_ErrNum = objErr.ErrorNumber If Return_ErrNum = 0 Then Return_ErrNum = -1 ' Go through the different types of errors and check for a match If objErr IsA OLEException Then If Return_ErrDesc = "" Then Return_ErrDesc = "An error occured while interfacing with an OLE / ActiveX object." Return_ErrDesc = "[OLEException] " + Return_ErrDesc Return_ErrType = "OLEException" ElseIf objErr IsA EndException Then If Return_ErrDesc = "" Then Return_ErrDesc = "An exception of the type 'EndException' occured" Return_ErrDesc = "[EndException] " + Return_ErrDesc Return_ErrType = "EndException" ElseIf objErr IsA IllegalCastException Then If Return_ErrDesc = "" Then Return_ErrDesc = "An object was cast to a different class and a message was sent to its 'real' class that it can not accept" Return_ErrDesc = "[IllegalCastException] " + Return_ErrDesc Return_ErrType = "IllegalCastException" ElseIf objErr IsA InvalidParentException Then If Return_ErrDesc = "" Then Return_ErrDesc = "An exception of the type 'InvalidParentException' occured" Return_ErrDesc = "[InvalidParentException] " + Return_ErrDesc Return_ErrType = "InvalidParentException" ElseIf objErr IsA KeyChainException Then If Return_ErrDesc = "" Then Return_ErrDesc = "An exception of the type 'KeyChainException' occured" Return_ErrDesc = "[KeyChainException] " + Return_ErrDesc Return_ErrType = "KeyChainException" ElseIf objErr IsA KeyNotFoundException Then If Return_ErrDesc = "" Then Return_ErrDesc = "An attempt was made to access a Dictionary item with a key that the Dictionary object does not contain" Return_ErrDesc = "[KeyNotFoundException] " + Return_ErrDesc Return_ErrType = "KeyNotFoundException" ElseIf objErr IsA NilObjectException Then If Return_ErrDesc = "" Then Return_ErrDesc = "An exception of the type 'NilObjectException' occured" Return_ErrDesc = "[NilObjectException] " + Return_ErrDesc Return_ErrType = "NilObjectException" ElseIf objErr IsA NoOpenTransportException Then If Return_ErrDesc = "" Then Return_ErrDesc = "An exception of the type 'NoOpenTransportException' occured" Return_ErrDesc = "[NoOpenTransportException] " + Return_ErrDesc Return_ErrType = "NoOpenTransportException" ElseIf objErr IsA OutOfBoundsException Then If Return_ErrDesc = "" Then Return_ErrDesc = "An attempt was made to read from, or write to a value, character, or element outside the bounds of that object or data type." Return_ErrDesc = "[OutOfBoundsException] " + Return_ErrDesc Return_ErrType = "OutOfBoundsException" ElseIf objErr IsA OutOfMemoryException Then If Return_ErrDesc = "" Then Return_ErrDesc = "The requested operation could not be completed due to insufficient memory" Return_ErrDesc = "[OutOfMemoryException] " + Return_ErrDesc Return_ErrType = "OutOfMemoryException" ElseIf objErr IsA RbScriptAlreadyRunningException Then If Return_ErrDesc = "" Then Return_ErrDesc = "An attempt was made to alter an RbScript that is already executing" Return_ErrDesc = "[RbScriptAlreadyRunningException] " + Return_ErrDesc Return_ErrType = "RbScriptAlreadyRunningException" ElseIf objErr IsA RbScriptException Then If Return_ErrDesc = "" Then Return_ErrDesc = "An exception of the type 'RbScriptException' occured" Return_ErrDesc = "[RbScriptException] " + Return_ErrDesc Return_ErrType = "RbScriptException" ElseIf objErr IsA RegExException Then If Return_ErrDesc = "" Then Return_ErrDesc = "An exception was issued by the RegEx engine due to an invalid search pattern in a Regular Expression, or another regular expression problem" Return_ErrDesc = "[RegExException] " + Return_ErrDesc Return_ErrType = "RegExException" ElseIf objErr IsA RegExSearchPatternException Then If Return_ErrDesc = "" Then Return_ErrDesc = "An exception of the type 'RegExSearchPatternException' occured" Return_ErrDesc = "[RegExSearchPatternException] " + Return_ErrDesc Return_ErrType = "RegExSearchPatternException" ElseIf objErr IsA RegistryAccessErrorException Then If Return_ErrDesc = "" Then Return_ErrDesc = "An exception of the type 'RegistryAccessErrorException' occured" Return_ErrDesc = "[RegistryAccessErrorException] " + Return_ErrDesc Return_ErrType = "RegistryAccessErrorException" ElseIf objErr IsA ServiceNotAvailableException Then If Return_ErrDesc = "" Then Return_ErrDesc = "An exception of the type 'ServiceNotAvailableException' occured" Return_ErrDesc = "[ServiceNotAvailableException] " + Return_ErrDesc Return_ErrType = "ServiceNotAvailableException" ElseIf objErr IsA ShellNotAvailableException Then If Return_ErrDesc = "" Then Return_ErrDesc = "An exception of the type 'ShellNotAvailableException' occured" Return_ErrDesc = "[ShellNotAvailableException] " + Return_ErrDesc Return_ErrType = "ShellNotAvailableException" ElseIf objErr IsA ShellNotRunningException Then If Return_ErrDesc = "" Then Return_ErrDesc = "An attempt was made to access an asynchronous or interactive shell session, but the shell was no running" Return_ErrDesc = "[ShellNotRunningException] " + Return_ErrDesc Return_ErrType = "ShellNotRunningException" ElseIf objErr IsA StackOverflowException Then If Return_ErrDesc = "" Then Return_ErrDesc = "A stack / memory exception occured because the application ran out of stack space" Return_ErrDesc = "[StackOverflowException] " + Return_ErrDesc Return_ErrType = "StackOverflowException" ElseIf objErr IsA TypeMismatchException Then If Return_ErrDesc = "" Then Return_ErrDesc = "A value of the wrong data type was assigned to the variable or object" Return_ErrDesc = "[TypeMismatchException] " + Return_ErrDesc Return_ErrType = "TypeMismatchException" ElseIf objErr IsA UnsupportedFormatException Then If Return_ErrDesc = "" Then Return_ErrDesc = "A string expression was used that does not evaluate to a number, or an attempt was made to open or save an unsupported picture format" Return_ErrDesc = "[UnsupportedFormatException] " + Return_ErrDesc Return_ErrType = "UnsupportedFormatException" ElseIf objErr IsA RuntimeException Then If Return_ErrDesc = "" Then Return_ErrDesc = "A general or unknown run-time exception occured" Return_ErrDesc = "[RuntimeException] " + Return_ErrDesc Return_ErrType = "RuntimeException" ElseIf objErr IsA XmlException Then If Return_ErrDesc = "" Then Return_ErrDesc = "An XML error occured (this is most likely an XML parsing error due to mal-formed XML)" Return_ErrDesc = "[XmlException] " + Return_ErrDesc Return_ErrType = "XmlException" Else If Return_ErrDesc = "" Then Return_ErrDesc = "An unknown run-time exception occured" Return_ErrDesc = "[Unknown Exception Type] " + Return_ErrDesc Return_ErrType = "Unknown" End If End Sub 134217984 DoEvents 0 3 0 3 0 134217984 Sub DoEvents() App.DoEvents -1 End Sub 134217984 Sleep Milliseconds As Integer 0 1 7 1 7 134217984 Sub Sleep(Milliseconds As Integer) App.DoEvents Milliseconds End Sub 134217984 ReplaceVB strExpression As String, strFind As String, strReplace As String String 0 2 9 2 9 134217984 Function ReplaceVB(strExpression As String, strFind As String, strReplace As String) As String Return ReplaceVB(strExpression, strFind, strReplace, -1, vbBinaryCompare) End Function 134217984 MessageBox Prompt As String, Buttons As Integer = 0, Title As String = "" 0 1 0 1 0 134217984 Sub MessageBox(Prompt As String, Buttons As Integer = 0, Title As String = "") Dim intReturn As Integer intReturn = MessageBox(Prompt, Buttons, Title) End Sub 134217984 Kill FilePath As String 0 6 11 6 11 134217984 Sub Kill(FilePath As String) Dim oFile As FolderItem oFile = GetFolderItem(FilePath) If IsNull(oFile) = False Then oFile.Delete oFile = Nil End If End Sub 134217984 IIf Expression As Boolean, TruePart As Variant, FalsePart As Variant Variant 0 1 0 1 0 134217984 Function IIf(Expression As Boolean, TruePart As Variant, FalsePart As Variant) As Variant If Expression = True Then Return TruePart Else Return FalsePart End If End Function 134217984 IsDate Expression As Variant Boolean 0 1 0 1 0 134217984 Function IsDate(Expression As Variant) As Boolean Dim datDate As Date MsgBox Expression.StringValue If ParseDate(Expression.StringValue, datDate) = True Then Return True Else Return False End If End Function 6 134217984 IsObject Expression As Variant Boolean 0 7 0 7 0 134217984 Function IsObject(Expression As Variant) As Boolean If VarType(Expression) = vbObject Then Return True Else Return False End IF End Function 134217984 ReplaceVB strExpression As String, strFind As String, strReplace As String, intCount As Integer, intCompareMethod As Integer String 0 9 0 9 0 134217984 Function ReplaceVB(strExpression As String, strFind As String, strReplace As String, intCount As Integer, intCompareMethod As Integer) As String Dim intCounter As Integer Dim strTemp As String ' If the FIND and the REPLACE are the same, there's nothing to do... so exit If strFind = strReplace Then Return strExpression End If ' If the specified compare method is invalid, default it to BINARY If intCompareMethod <> vbBinaryCompare And intCompareMethod <> vbTextCompare Then intCompareMethod = vbBinaryCompare End If ' ** Replace ALL instances ** If intCount < 1 Then ' Binary replace (CaSe SeNsAtIvE) If intCompareMethod = vbBinaryCompare Then Return ReplaceAllB(strExpression, strFind, strReplace) ' Text replace (CASE INSENSATIVE) Else Return ReplaceAll(strExpression, strFind, strReplace) End If ' ** Replace only a certain number of instances ** Else strTemp = strExpression ' Binary replace (CaSe SeNsAtIvE) If intCompareMethod = vbBinaryCompare Then For intCounter = 1 To intCount strTemp = ReplaceB(strTemp, strFind, strReplace) Next ' Text replace (CASE INSENSATIVE) Else For intCounter = 1 To intCount strTemp = Replace(strTemp, strFind, strReplace) Next End IF End If End Function 134217984 Space intNumber As Integer String 0 2 7 2 7 134217984 Function Space(intNumber As Integer) As String Return StringVB(intNumber, " ") End Function 134217984 Space intNumber As Integer, strCharacter As String String 0 2 7 2 7 134217984 Function Space(intNumber As Integer, strCharacter As String) As String Return StringVB(intNumber, strCharacter) End Function 134217984 GetColorValue intRed As Integer, intGreen As Integer, intBlue As Integer Integer 0 13 0 13 0 134217984 Function GetColorValue(intRed As Integer, intGreen As Integer, intBlue As Integer) As Integer Dim strRED As String Dim strGRN As String Dim strBLU As String ' Validate the color values If intRed > 255 Then intRed = 255 If intGreen > 255 Then intGreen = 255 If intBlue > 255 Then intBlue = 255 If intRed < 0 Then intRed = 0 If intGreen < 0 Then intGreen = 0 If intBlue < 0 Then intBlue = 0 ' Get the HEX values of the R, G, B values strRED = Right("0" + HEX(intRed), 2) strGRN = Right("0" + HEX(intGreen), 2) strBLU = Right("0" + HEX(intBlue), 2) ' Get the color value for the 3 put together Return CDbl("&H" + strBLU + strGRN + strRED) End Function 134217984 GetColorValue objColor As Color Integer 0 2 65 2 65 134217984 Function GetColorValue(objColor As Color) As Integer Return GetColorValue(objColor.red, objColor.green, objColor.blue) End Function 134217984 Erase ByRef ArrayToErase() As Boolean 0 4 0 4 0 134217984 Sub Erase(ByRef ArrayToErase() As Boolean) ' Redimentioning an array to -1 erases it's contents ReDim ArrayToErase(-1) End Sub 134217984 Erase ByRef ArrayToErase() As Color 0 4 0 4 0 134217984 Sub Erase(ByRef ArrayToErase() As Color) ' Redimentioning an array to -1 erases it's contents ReDim ArrayToErase(-1) End Sub 134217984 Erase ByRef ArrayToErase() As Integer 0 4 0 4 0 134217984 Sub Erase(ByRef ArrayToErase() As Integer) ' Redimentioning an array to -1 erases it's contents ReDim ArrayToErase(-1) End Sub 134217984 Erase ByRef ArrayToErase() As Single 0 4 0 4 0 134217984 Sub Erase(ByRef ArrayToErase() As Single) ' Redimentioning an array to -1 erases it's contents ReDim ArrayToErase(-1) End Sub 134217984 Erase ByRef ArrayToErase() As Double 0 4 0 4 0 134217984 Sub Erase(ByRef ArrayToErase() As Double) ' Redimentioning an array to -1 erases it's contents ReDim ArrayToErase(-1) End Sub 134217984 Erase ByRef ArrayToErase() As String 0 4 0 4 0 134217984 Sub Erase(ByRef ArrayToErase() As String) ' Redimentioning an array to -1 erases it's contents ReDim ArrayToErase(-1) End Sub 134217984 Erase ByRef ArrayToErase() As Date 0 4 0 4 0 134217984 Sub Erase(ByRef ArrayToErase() As Date) ' Redimentioning an array to -1 erases it's contents ReDim ArrayToErase(-1) End Sub 134217984 Erase ByRef ArrayToErase() As Variant 0 4 0 4 0 134217984 Sub Erase(ByRef ArrayToErase() As Variant) ' Redimentioning an array to -1 erases it's contents ReDim ArrayToErase(-1) End Sub 134217984 SetWinColors 33 25 27 25 31 134217984 Sub SetWinColors() ' Windows only system color constants #If TargetWin32 Then ' Standard Win32 color values Const COLOR_3DDKSHADOW = 21 ' Dark shadow for three-dimensional display elements. 'Const COLOR_3DFACE = 15 ' (See COLOR_BTNFACE) 'Const COLOR_3DHIGHLIGHT = 20 ' (See COLOR_BTNHIGHLIGHT) 'Const COLOR_3DHILIGHT = 20 ' (See COLOR_BTNHIGHLIGHT) Const COLOR_3DLIGHT = 22 ' Light color for three-dimensional display elements (for edges facing the light source.) 'Const COLOR_3DSHADOW = 16 ' (See COLOR_BTNSHADOW) Const COLOR_ACTIVEBORDER = 10 ' Active window border. Const COLOR_APPWORKSPACE = 12 ' Background color of multiple document interface (MDI) applications. 'Const COLOR_BACKGROUND = 1 ' (See COLOR_DESKTOP) Const COLOR_BTNFACE = 15 ' Face color for three-dimensional display elements and for dialog box backgrounds. Const COLOR_BTNHIGHLIGHT = 20 ' Highlight color for three-dimensional display elements (for edges facing the light source.) 'Const COLOR_BTNHILIGHT = 20 ' (See COLOR_BTNHIGHLIGHT) Const COLOR_BTNSHADOW = 16 ' Shadow color for three-dimensional display elements (for edges facing away from the light source). Const COLOR_BTNTEXT = 18 ' Text on push buttons. Const COLOR_CAPTIONTEXT = 9 ' Text in caption, size box, and scroll bar arrow box. Const COLOR_DESKTOP = 1 ' Desktop. Const COLOR_GRAYTEXT = 17 ' Grayed (disabled) text. This color is set to 0 if the current display driver does not support a solid gray color. Const COLOR_HIGHLIGHT = 13 ' Item(s) selected in a control. Const COLOR_HIGHLIGHTTEXT = 14 ' Text of item(s) selected in a control. Const COLOR_INACTIVEBORDER = 11 ' Inactive window border. Const COLOR_INACTIVECAPTIONTEXT = 19 ' Color of text in an inactive caption. Const COLOR_INFOBK = 24 ' Background color for tooltip controls. Const COLOR_INFOTEXT = 23 ' Text color for tooltip controls. Const COLOR_MENU = 4 ' Menu background. Const COLOR_MENUTEXT = 7 ' Text in menus. Const COLOR_SCROLLBAR = 0 ' Scroll bar gray area. Const COLOR_WINDOW = 5 ' Window background. Const COLOR_WINDOWFRAME = 6 ' Window frame. Const COLOR_WINDOWTEXT = 8 ' Text in windows. ' The following are NOT supported under WinNT4/Win95: Const COLOR_ACTIVECAPTION = 2 ' Active window title bar. Specifies the left side color in the color gradient of an active window's title bar if the gradient effect is enabled. Const COLOR_GRADIENTINACTIVECAPTION = 28 ' Right side color in the color gradient of an inactive window's title bar. COLOR_INACTIVECAPTION specifies the left side color. Const COLOR_GRADIENTACTIVECAPTION = 27 ' Right side color in the color gradient of an active window's title bar. COLOR_ACTIVECAPTION specifies the left side color. Use SPI_GETGRADIENTCAPTIONS with the SystemParametersInfo function to determine whether the gradient effect is enabled. Const COLOR_HOTLIGHT = 26 ' Color for a hot-tracked item. Single clicking a hot-tracked item executes the item. Const COLOR_INACTIVECAPTION = 3 ' Inactive window caption. Specifies the left side color in the color gradient of an inactive window's title bar if the gradient effect is enabled. Declare Function GetSysColor Lib "USER32.DLL" (ByVal nIndex As Integer) As Integer vb3DDKShadow = GetColorValue(TranslateColor(GetSysColor(COLOR_3DDKSHADOW))) 'vb3DFace = FillColor() 'vb3DHighlight = LightBevelColor() vb3DLight = GetColorValue(TranslateColor(GetSysColor(COLOR_3DLIGHT))) 'vb3DShadow = DarkBevelColor() vbActiveBorder = GetColorValue(TranslateColor(GetSysColor(COLOR_ACTIVEBORDER))) vbActiveTitleBar = GetColorValue(TranslateColor(GetSysColor(COLOR_ACTIVECAPTION))) vbActiveTitleBarText = GetColorValue(TranslateColor(GetSysColor(COLOR_CAPTIONTEXT))) vbApplicationWorkspace = GetColorValue(TranslateColor(GetSysColor(COLOR_APPWORKSPACE))) 'vbButtonFace = FillColor() 'vbButtonShadow = DarkBevelColor() 'vbButtonText = TextColor() vbDesktop = GetColorValue(TranslateColor(GetSysColor(COLOR_DESKTOP))) vbGrayText = GetColorValue(TranslateColor(GetSysColor(COLOR_GRAYTEXT))) 'vbHighlight = HighlightColor() vbHighlightText = GetColorValue(TranslateColor(GetSysColor(COLOR_HIGHLIGHTTEXT))) vbInactiveBorder = GetColorValue(TranslateColor(GetSysColor(COLOR_INACTIVEBORDER))) vbInactiveCaptionText = GetColorValue(TranslateColor(GetSysColor(COLOR_INACTIVECAPTIONTEXT))) vbInactiveTitleBar = GetColorValue(TranslateColor(GetSysColor(COLOR_INACTIVECAPTION))) vbInactiveTitleBarText = GetColorValue(TranslateColor(GetSysColor(COLOR_INACTIVECAPTIONTEXT))) vbInfoBackground = GetColorValue(TranslateColor(GetSysColor(COLOR_INFOBK))) vbInfoText = GetColorValue(TranslateColor(GetSysColor(COLOR_INFOTEXT))) vbMenuBar = GetColorValue(TranslateColor(GetSysColor(COLOR_MENU))) vbMenuText = GetColorValue(TranslateColor(GetSysColor(COLOR_MENUTEXT))) vbScrollBars = GetColorValue(TranslateColor(GetSysColor(COLOR_SCROLLBAR))) vbTitleBarText = GetColorValue(TranslateColor(GetSysColor(COLOR_CAPTIONTEXT))) vbWindowBackground = GetColorValue(TranslateColor(GetSysColor(COLOR_WINDOW))) vbWindowFrame = GetColorValue(TranslateColor(GetSysColor(COLOR_WINDOWFRAME))) vbWindowText = GetColorValue(TranslateColor(GetSysColor(COLOR_WINDOWTEXT))) #EndIf End Sub 134217984 GetColorValue intColor As Integer Color 0 6 0 6 0 134217984 Function GetColorValue(intColor As Integer) As Color Dim intTemp As Integer Dim intRed As Integer Dim intGre As Integer Dim intBlu As Integer ' Validate the parameters Select Case intColor Case -1, 0 Return vbBlack End Select ' Break the color out into it's R, G, and B parts intRed = Bitwise.BitAnd(intColor, 255) intGre = Bitwise.BitAnd(intColor, 65280) \ 256 intBlu = Bitwise.BitAnd(intColor, 16711680) \ 65536 ' Function succeeded Return RGB(intRed, intGre, intBlu) End Function 134217984 TranslateColor ByVal ColorToConvert As Integer Integer 0 9 0 9 0 134217984 Function TranslateColor(ByVal ColorToConvert As Integer) As Integer ' This function takes the specified color and converts OLE colors (i.e. - "vbButtonFace") to standard color (i.e. - "12632256"). It is safest to pass all colors through this function to make sure that if a #If TargetWin32 Then Declare Function OleTranslateColor Lib "OLEPRO32.DLL" (ByVal OLE_COLOR As Integer, ByVal hPalette As Integer,ByRef pColorRef As Integer) As Integer Dim intReturn As Integer If OleTranslateColor(ColorToConvert, 0, intReturn) = 0 Then Return intReturn Else Return -1 End If #Else Return -1 #EndIf End Function 134217984 FontHeight strFontName As String, intFontSize As Integer Integer 0 31 0 31 13 134217984 Function FontHeight(strFontName As String, intFontSize As Integer) As Integer Dim intReturn As Integer ' Validate parameters If IsNull(g_TempWindow) = True Then MsgBox " * IMPORTANT:" + vbCrLf + vbCrLf + _ "You have not yet set the 'g_TempWindow' equal to a new Window object." + vbCrLf + _ "Put this lines in your project's 'App.Open' event:" + vbCrLf + _ vbCrLf + _ "g_TempWindow = New Window" + vbCrLf + _ "g_TempWindow.Visible = False" + vbCrLf + _ vbCrLf + _ "Put this line in your project's 'App.Close' event:" + vbCrLf + _ vbCrLf + _ "g_TempWindow = Nil" Return -1 ElseIf Trim(strFontName) = "" Or intFontSize < 1 Or intFontSize > 100 Then Return -1 End If ' Set the font information g_TempWindow.Graphics.TextFont = strFontName g_TempWindow.Graphics.TextSize = intFontSize ' Get the height of the font (in pixels) intReturn = g_TempWindow.Graphics.TextHeight ' Clean up Return intReturn Exception Err As RuntimeException Return -1 End Function 134217984 TextHeight strTextString As String, intWordWrapWidth As Integer, strFontName As String, intFontSize As Integer Integer 0 44 0 44 13 134217984 Function TextHeight(strTextString As String, intWordWrapWidth As Integer, strFontName As String, intFontSize As Integer) As Integer '=============================================================================================== ' PARAMETERS: ' ----------- ' strTextString = The text to get the height of ' intWordWrapWidth = The width (in pixels) that should be used to wrap the text ' strFontName = The name of the font to test the height with ' intFontSize = The font size of the font to test the height with ' '=============================================================================================== Dim intReturn As Integer ' Validate parameters If IsNull(g_TempWindow) = True Then MsgBox " * IMPORTANT:" + vbCrLf + vbCrLf + _ "You have not yet set the 'g_TempWindow' equal to a new Window object." + vbCrLf + _ "Put this lines in your project's 'App.Open' event:" + vbCrLf + _ vbCrLf + _ "g_TempWindow = New Window" + vbCrLf + _ "g_TempWindow.Visible = False" + vbCrLf + _ vbCrLf + _ "Put this line in your project's 'App.Close' event:" + vbCrLf + _ vbCrLf + _ "g_TempWindow = Nil" Return -1 ElseIf Trim(strTextString) = "" Then Return 0 ElseIf Trim(strFontName) = "" Or intFontSize < 1 Or intFontSize > 100 Then Return -1 End If ' Set the font information g_TempWindow.Graphics.TextFont = strFontName g_TempWindow.Graphics.TextSize = intFontSize ' Get the height of the specified text (in pixels) intReturn = g_TempWindow.Graphics.StringHeight(strTextString, intWordWrapWidth) ' Clean up Return intReturn Exception Err As RuntimeException Return -1 End Function 134217984 DoesFontExist strFontName As String Boolean 0 12 0 12 0 134217984 Function DoesFontExist(strFontName As String) As Boolean Dim intCounter As Integer If Trim(strFontName) = "" Then Return False For intCounter = 0 To FontCount - 1 If StrComp(strFontName, Font(intCounter), vbTextCompare) = 0 Then Return True End If Next Return False End Function 1536 TextWidth strTextString As String, strFontName As String, intFontSize As Integer Integer 0 43 0 43 13 134217984 Function TextWidth(strTextString As String, strFontName As String, intFontSize As Integer) As Integer '=============================================================================================== ' PARAMETERS: ' ----------- ' strTextString = The text to get the width of ' strFontName = The name of the font to test the width with ' intFontSize = The font size of the font to test the width with ' '=============================================================================================== Dim intReturn As Integer ' Validate parameters If IsNull(g_TempWindow) = True Then MsgBox " * IMPORTANT:" + vbCrLf + vbCrLf + _ "You have not yet set the 'g_TempWindow' equal to a new Window object." + vbCrLf + _ "Put this lines in your project's 'App.Open' event:" + vbCrLf + _ vbCrLf + _ "g_TempWindow = New Window" + vbCrLf + _ "g_TempWindow.Visible = False" + vbCrLf + _ vbCrLf + _ "Put this line in your project's 'App.Close' event:" + vbCrLf + _ vbCrLf + _ "g_TempWindow = Nil" Return -1 ElseIf Trim(strTextString) = "" Then Return 0 ElseIf Trim(strFontName) = "" Or intFontSize < 1 Or intFontSize > 100 Then Return -1 End If ' Set the font information g_TempWindow.Graphics.TextFont = strFontName g_TempWindow.Graphics.TextSize = intFontSize ' Get the height of the specified text (in pixels) intReturn = g_TempWindow.Graphics.StringWidth(strTextString) ' Clean up Return intReturn Exception Err As RuntimeException Return -1 End Function 134217984 MessageBox Prompt As String, Buttons As Integer = 0, Title As String = "" Integer 0 4 0 4 0 134217984 Function MessageBox(Prompt As String, Buttons As Integer = 0, Title As String = "") As Integer ' The "MsgBox" function does not beep unless you omit the BUTTONS and TITLE parameters. ' This function allows you to BEEP first, then prompt the user for action. Beep Return MsgBox(Prompt, Buttons, Title) End Function 134217984 Int Value As Variant Integer 0 14 0 14 0 134217984 Function Int(Value As Variant) As Integer ' Returns an 4-byte (32-bit) number Dim objErr As RuntimeException If IsNumeric(Trim(Value.StringValue)) = False Then objErr = New RuntimeException objErr.ErrorNumber = 13 objErr.Message = "Type Mismatch" Raise objErr Else Return (Value.DoubleValue \ 1) End If End Function 134217984 CByte Value As Variant MemoryBlock 0 4 0 23 6 134217984 Function CByte(Value As Variant) As MemoryBlock ' Returns an 1-byte (8-bit) number Dim objMem As MemoryBlock Dim objErr As RuntimeException If IsNumeric(Trim(Value.StringValue)) = False Then objErr = New RuntimeException objErr.ErrorNumber = 13 objErr.Message = "Type Mismatch" Raise objErr Else If Value.DoubleValue < 0 Or Value.DoubleValue > 255 Then objErr = New RuntimeException objErr.ErrorNumber = 6 objErr.Message = "Overflow" Raise objErr Else objMem = NewMemoryBlock(1) objMem.Byte(0) = (Value.DoubleValue \ 1) Return objMem End If End If End Function 134217984 CInt16 Value As Variant MemoryBlock 0 20 15 20 15 134217984 Function CInt16(Value As Variant) As MemoryBlock ' Returns an 2-byte (16-bit) number Dim objMem As MemoryBlock Dim objErr As RuntimeException If IsNumeric(Trim(Value.StringValue)) = False Then objErr = New RuntimeException objErr.ErrorNumber = 13 objErr.Message = "Type Mismatch" Raise objErr Else If Value.DoubleValue < -32768 Or Value.DoubleValue > 32767 Then objErr = New RuntimeException objErr.ErrorNumber = 6 objErr.Message = "Overflow" Raise objErr Else objMem = NewMemoryBlock(2) objMem.Short(0) = (Value.DoubleValue \ 1) Return objMem End If End If End Function 134217984 CInt32 Value As Variant MemoryBlock 0 20 14 20 14 134217984 Function CInt32(Value As Variant) As MemoryBlock ' Returns an 4-byte (32-bit) number Dim objMem As MemoryBlock Dim objErr As RuntimeException If IsNumeric(Trim(Value.StringValue)) = False Then objErr = New RuntimeException objErr.ErrorNumber = 13 objErr.Message = "Type Mismatch" Raise objErr Else If Value.DoubleValue < -2147483648 Or Value.DoubleValue > 2147483647 Then objErr = New RuntimeException objErr.ErrorNumber = 6 objErr.Message = "Overflow" Raise objErr Else objMem = NewMemoryBlock(4) objMem.Long(0) = (Value.DoubleValue \ 1) Return objMem End If End If End Function 134217984 CInt64 Value As Variant MemoryBlock 0 14 21 14 21 134217984 Function CInt64(Value As Variant) As MemoryBlock ' Returns an 8-byte (64-bit) number Dim objMem As MemoryBlock Dim objErr As RuntimeException If IsNumeric(Trim(Value.StringValue)) = False Then objErr = New RuntimeException objErr.ErrorNumber = 13 objErr.Message = "Type Mismatch" Raise objErr Else objMem = NewMemoryBlock(8) objMem.DoubleValue(0) = Value.DoubleValue Return objMem End If End Function 134217984 StringVB intNumber As Integer, strCharacter As String String 0 10 0 10 0 134217984 Function StringVB(intNumber As Integer, strCharacter As String) As String Dim intCounter As Integer Dim strTemp As String If intNumber < 1 Then Return "" ElseIf strCharacter = "" Then Return "" End If For intCounter = 1 To intNumber strTemp = strTemp + strCharacter Next Return strTemp End Function 134217984 CVar Value As Variant Variant 0 1 0 1 0 134217984 Function CVar(Value As Variant) As Variant Return Value End Function 134217984 Mid ByRef strString As String, ByVal intStart As Integer, Assigns strSubString As String 0 2 52 2 52 134217984 Sub Mid(ByRef strString As String, ByVal intStart As Integer, Assigns strSubString As String) strString = Mid(strString, intStart, Len(strString)) End Sub 134217984 Mid ByRef strString As String, ByVal intStart As Integer, ByVal intLength As Integer, Assigns strSubString As String 0 15 0 15 0 134217984 Sub Mid(ByRef strString As String, ByVal intStart As Integer, ByVal intLength As Integer, Assigns strSubString As String) Dim intStringLen As Integer Dim strTemp As String Dim intLen As Integer Dim intMaxLen As Integer ' Validate parameters If strString = "" Then Return intStringLen = Len(strString) If intStart < 1 Then Return If intStart > intStringLen Then Return If intLength < 1 Then Return intMaxLen = intStringLen - (intStart - 1) If intMaxLen < 1 Then Return ' If the length is greater than the remaining length of the string, set the length to the remaining length intLen = intLength If intLen > intMaxLen Then intLen = intMaxLen If intLen > Len(strSubString) Then intLen = Len(strSubString) ' Get the SubString to be inserted into the specified string strTemp = Left(strSubString, intLen) If (intStart + intLen) > intStringLen Then strString = Left(strString, intStart - 1) + strTemp Else strString = Left(strString, intStart - 1) + strTemp + Right(strString, (intStringLen - intStart) - (intLen - 1)) End If End Sub 134217984 IsBool Expression As Variant Boolean 0 2 31 2 31 134217984 Function IsBool(Expression As Variant) As Boolean Return IsBool(Expression, True) End Function 134217984 IsBool Expression As Variant, Explicit As Boolean Boolean 0 6 0 6 0 134217984 Function IsBool(Expression As Variant, Explicit As Boolean) As Boolean Select Case Uppercase(Expression.StringValue) Case "TRUE", "FALSE", "1", "0", "-1" Return True Else If Explicit = True Then Return False ElseIf IsNumeric(Expression.StringValue) = True Then Return True Else Return False End If End Select End Function