home *** CD-ROM | disk | FTP | other *** search
DefInt A-Z Declare Function ControlhWnd% Lib "CTLHWND.DLL" (Ctl As Control) 'API function used by SelectItem Declare Function SendMessage Lib "User" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, ByVal lParam As Any) As Long 'API function used by ClearList (requires different calling convention than Select Item) Declare Function SendMessage2 Lib "User" Alias "SendMessage" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As Long Function FileErrors (ErrVal As Integer) As Integer ' This function is a modification of one of the sample programs included ' in the Visual Basic Programmer's Guide. We do *not* assert copyright ' for this function. ' Return Value Meaning Return Value Meaning ' 0 Resume 2 Unrecoverable error ' 1 Resume Next 3 Unrecognized error MsgType% = 48 ' Exclamation point Select Case ErrVal Case ErrTYPEMISMATCH ' Error #13 Msg$ = "A data type mismatch occurred." Case ErrDEVICEUNAVAILABLE ' Error #68 Msg$ = "That device is unavailable." MsgType% = MsgType% + 4 ' Case ErrDISKNOTREADY ' Error #71 Msg$ = "Put a disk in the drive and close the door" Case ErrDEVICEIO ' Error # 57 Msg$ = "Ouch! Internal Disk Error" MsgType% = MsgType% + 4 Case ErrDISKFULL ' Error #61 Msg$ = "Umph! Disk full--Continue?" MsgType% = 35 Case ErrBADFILENAME, ErrBADFILENAMEORNUMBER ' Errors #64, #52 Msg$ = "Um, I can't find that file..." Case ErrPATHDOESNOTEXIST ' Error #76 Msg$ = "That directory path doesn't exist." Case ErrBADFILEMODE ' Error #54 Msg$ = "Can't open the file for that type of access." Case ErrFILEALREADYOPEN ' Error #55 Msg$ = "The file is already open." Case ErrPASTENDOFFILE ' Error #62 Msg$ = "This file has a nonstandard end-of-file" Msg$ = Msg$ + " marker, or an attempt was made to read" Msg$ = Msg$ + " beyond the end-of-file marker." Case Else FileErrors = 3 Msg$ = "Uh oh. Error #" + Str$(Err) + " was encountered." + Chr$(13) + Chr$(10) Msg$ = Msg$ + "System Message: " + Error$ MsgBox Msg$, 16, "Bad News" Stop Exit Function End Select Response% = MsgBox(Msg$, MsgType%, "Ouch! Disk Error") Select Case Response% Case 1, 4 ' OK, Retry buttons FileErrors = 0 Case 5 ' Ignore button FileErrors = 1 Case 2, 3 ' Cancel, Abort buttons FileErrors = 2 Case Else FileErrors = 3 End Select End Function Function FileOpener (NameToUse$, Mode%, RecordLength%) As Integer ' This function is one of the sample programs included in the Visual ' Basic Programmer's Guide (pp. 318-320). We do *not* assert copyright ' for this function. ' Opens a file in specified access mode. ' Arguments: NameToUse$ - String with a valid filename ' Mode% - Integer of file access mode ' RecordLength% - Length of one record ' Returns: Integer by which the file can be specified in the program. ' Returns 0 if file open fails. FileNum% = FreeFile 'Get the next free file number On Error GoTo OpenerError 'Error handler Select Case Mode 'Determine the mode we want Case REPLACEFILE Open NameToUse For Output As FileNum% Case READFILE Open NameToUse For Input As FileNum% Case ADDTOFILE Open NameToUse For Append As FileNum% Case RANDOMFILE Open NameToUse For Random As FileNum% Len = RecordLength% Case BINARYFILE Open NameToUse For Binary As FileNum% Case Else Exit Function End Select FileOpener = FileNum% 'Return the file number Exit Function OpenerError: Action% = FileErrors(Err) Select Case Action% Case 0 Resume Case Else FileOpener = 0 'Too bad.... Exit Function End Select End Function Function FioSlice (InString$, WordNum%, Delimeter$, StartPos%) As String ' FioSlice was outlined by Ed Girou. FioSlice parses strings into definable words ' that can be acted upon. Given that many CompuServe commands have a syntax like ' "DOW PROTO:B THISFILE THISNAME" it's handy to be able to just ask for the second ' word in the string. ' ================================================================================================ ' MAINTENANCE HISTORY: ' Version Date Coder Action ' 0.1 5/1/92 Murdoch Initial keyin ' 0.1a 5/3/92 Murdoch Slight amendment--fewer messages, more values returned. ' ' To do: ' ' ================================================================================================ If Len(InString$) = 0 Then FioSlice = GioDEFAULT ' GioDEFAULT is global for bad news Exit Function End If If Len(Delimeter$) = 0 Then ' We'll default to using a space Delimeter$ = " " End If If WordNum% = 0 Then ' We'll be thorough... WordNum% = 1 ' ...in our error testing End If If StartPos% = 0 Then StartPos% = 1 ElseIf StartPos% >= Len(InString$) Then FioSlice = GioDEFAULT Exit Function End If ' This loop starts by initializing DelimeterPos%. We count from 1 to WordNum%-- ' remember that For..Next loops are evaluated at the *end* of each iteration. If ' WordNum% equals 1 we'll just go through once. If WordNum% equals 5 we'll go through ' 5 times. (If WordNum% had equalled 0 we'd have reset it to 1 in the trap above.) ' We'll find the first instance of Delimeter$. If we have to count in several words, ' we'll assign the old DelimiterPos% to BeginPos%, and search again. Once we're done, ' we'll use Mid$ to extract just that portion we want. DelimeterPos% = StartPos% ' Initialize the value For Counter% = 1 To WordNum% ' Set up counter loop BeginPos% = DelimeterPos% ' This helps when searching for word 2 or 3 DelimeterPos% = InStr((BeginPos% + 1), InString$, Delimeter$) If DelimeterPos% = 0 Then If WordNum% - Counter% > 0 Then ' Oops! We can't find the word FioSlice = GioDEFAULT ' GioDEFAULT is our "bad news" global Exit Function Else ' We're looking for the last word DelimeterPos% = Len(InString$) + 1 ' We'll adjust DelimeterPos% to set up the Mid$ Exit For End If End If Next If BeginPos% > 1 Then BeginPos% = BeginPos% + 1 ' This cures a bug in the next line--we don't ' want the delimeter included in the string, ' but we *do* want the first letter of the first ' word in the string. Length% = DelimeterPos% - BeginPos% ' Length of word we want FioSlice = Mid$(InString$, BeginPos%, Length%) ' Extract the word we want, and quit. End Function Sub CenterForm (TheForm As Form) TheForm.WindowState = 0 TheForm.left = (Screen.Width - TheForm.Width) / 2 TheForm.top = (Screen.Height - TheForm.Height) / 2 End Sub Sub SioMsgBox (Msg$, MsgType%, Title$) ' Replacement for VB MsgBox command. Adds sound support. ' Same parameters and return values as VB command. ' Sound event is determined from MsgType% If MsgType% < 16 Then MsgSound% = 0 ElseIf MsgType% < 32 Then MsgSound% = MB_ICONHAND ElseIf MsgType% < 48 Then MsgSound% = MB_ICONQUESTION ElseIf MsgType% < 64 Then MsgSound% = MB_ICONEXCLAMATION ElseIf MsgType% < 80 Then MsgSound% = MB_ICONASTERISK Else MsgSound% = 0 End If MessageBeep MsgSound% MsgBox Msg$, MsgType%, Title$ End Sub Function FioMsgBox (Msg$, MsgType%, Title$) As Integer ' Replacement for VB MsgBox function. Adds sound support. ' Same parameters and return values as VB function. ' Sound event is determined from MsgType% If MsgType% < 16 Then MsgSound% = 0 ElseIf MsgType% < 32 Then MsgSound% = MB_ICONHAND ElseIf MsgType% < 48 Then MsgSound% = MB_ICONQUESTION ElseIf MsgType% < 64 Then MsgSound% = MB_ICONEXCLAMATION ElseIf MsgType% < 80 Then MsgSound% = MB_ICONASTERISK Else MsgSound% = 0 End If MessageBeep MsgSound% FioMsgBox = MsgBox(Msg$, MsgType%, Title$) End Function Function DirExists (TheDirectory As String) As Integer ' Returns True if Directory exists, False if it doesn't OldDir$ = CurDir$ On Error Resume Next ChDir TheDirectory If Err = 76 Then Err = 0 DirExists = FALSE Else DirExists = TRUE End If ChDir OldDir$ On Error GoTo 0 End Function Function SelectItem (Ctl As Control, SearchString As String) lbhWnd = ControlhWnd(Ctl) Index = SendMessage(lbhWnd, LB_SELECTSTRING, -1, SearchString) SelectItem = Index End Function Sub ClearList (LB As Control) If TypeOf LB Is ComboBox Then Msg% = CB_RESETCONTENT ElseIf TypeOf LB Is ListBox Then Msg% = LB_RESETCONTENT End If lbhWnd = ControlhWnd(LB) Index = SendMessage2(lbhWnd, Msg%, 0, 0) End Sub 
