Zodiac Super OZ/MEDIADEPOT.ISO/FILES/13/VOL15N11.ZIP/TBWIZ.ZIP/LIBRARY.BAS

BASIC Source File | 1996-02-21 | 13KB | 422 lines

Attribute VB_Name = "LIBRARY"
'___general purpose library routines

Option Explicit
Option Compare Text
DefInt A-Z
Global DownY%
Global MyFile$
Global CommentChanged%
Global CurrentItem$
Global MyCRLF$
#If Win32 = 0 Then
    Declare Function WritePrivateProfileString% Lib "Kernel" (ByVal lpApplicationName$, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lplFileName$)
    Declare Function WriteProfileString% Lib "Kernel" (ByVal lpApplicationName$, ByVal lpKeyName As Any, ByVal lpString$)
    Declare Function GetProfileInt% Lib "Kernel" (ByVal lpAppName$, ByVal lpKeyName$, ByVal nDefault%)
    Declare Function GetPrivateProfileInt% Lib "Kernel" (ByVal lpApplicationName$, ByVal lpKeyName$, ByVal nDefault%, ByVal lpFileName$)
    Declare Function GetPrivateProfileString% Lib "Kernel" (ByVal lpApplicationName As Any, ByVal lpKeyName As Any, ByVal lpDefault$, ByVal lpReturnedString$, ByVal nSize%, ByVal lpFileName$)
    Declare Function GetProfileString% Lib "Kernel" (ByVal lpAppName$, ByVal lpKeyName As Any, ByVal lpDefault$, ByVal lpReturnedString$, ByVal nSize%)
    Declare Function GetVersion Lib "Kernel" () As Integer
    Declare Sub GetClientRect Lib "User" (ByVal hwnd As Integer, lpRect As Rect)
    Declare Function GetFocus Lib "User" () As Integer
    Declare Sub BringWindowToTop Lib "User" (ByVal hwnd As Integer)
    Declare Function SetFocusAPI Lib "User" Alias "SetFocus" (ByVal hwnd As Integer) As Integer
#Else
    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 Function WriteProfileString Lib "kernel32" Alias "WriteProfileStringA" (ByVal lpszSection As String, ByVal lpszKeyName As String, ByVal lpszString As String) As Long
    Declare Function GetProfileInt Lib "kernel32" Alias "GetProfileIntA" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal nDefault As Long) As Long
    Declare Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" (ByVal lpAppName As String, ByVal lpKeyName As Any, ByVal lpDefault As Any, ByVal lpReturnedString As String, ByVal nSize As Long) 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 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 GetVersion Lib "kernel32" () As Long
'    Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As Rect) As Long
    Declare Function GetFocus Lib "user32" () As Long
    Declare Function BringWindowToTop Lib "user32" (ByVal hwnd As Long) As Long
    Declare Function SetFocusAPI Lib "user32" Alias "SetFocus" (ByVal hwnd As Long) As Long
#End If
Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As Any, ByVal lpWindowName As String) As Long
Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Const vbd$ = " - Microsoft Visual Basic (design)"


Sub SetParentByCaption(Cap$, NewChild&)
'set parent window
Dim i&
Cap$ = Cap$ & vbd$
i& = FindWindow(0&, Cap$)
If IsWindow(i&) <> 0 Then i& = SetParent(NewChild&, i&)
End Sub

Function GetListItem$(ByVal Source$, ByVal MyItem%, Sep$)
  If MyItem% > 0 Then MyItem% = MyItem% - 1
  Dim basepos%, thispos%, sepLen%, Cap$, nt%, res$, SourceLen%
  basepos% = 1
  thispos% = 0
  If Left$(Source$, 1) = Sep$ Then Source$ = Mid$(Source$, 2)
  SourceLen% = Len(Source$)
  sepLen% = Len(Sep$)
  If SourceLen% = 0 Then
    Cap$ = ""
  Else
    If Right$(Source$, sepLen%) <> Sep$ Then Source$ = Source$ + Sep$
    Do
      nt% = InStr(basepos% + 1, Source$, Sep$)
      If nt% = 0 Then nt% = SourceLen% + 1
      ' Now points to next tab or 1 past end of string
      If thispos% = MyItem% Then
        If nt% - (basepos% - 1) < 0 Then
          res$ = ""
        Else
          res$ = Mid$(Source$, basepos%, nt% - (basepos%))
        End If
        Exit Do
      End If
      basepos% = nt% + sepLen%
      If nt% <> 1 Then thispos% = thispos% + 1
    Loop While basepos% <= SourceLen%
    GetListItem$ = res$
  End If
End Function

Sub Alert(Mess$)
'  * creates an Alert box with an OK button
MsgBox Mess$, 48, App.Title
End Sub


Function exGetName$(myF$)
Dim N%
  Do
    N% = InStr(myF$, "\")
    If N% > 0 Then myF$ = Right$(myF$, Len(myF$) - N%)
  Loop While N% > 0
exGetName$ = myF$
End Function

Function ExtractFileExt$(ByVal F$)
Dim i%
i% = InStr(F$, ".")
If i% > 0 And i% < Len(F$) Then
    ExtractFileExt$ = Mid$(F$, i% + 1)
  Else
    ExtractFileExt$ = ""
  End If

End Function

Function ExtractFileRoot$(ByVal F$)
  ' Return the basename portion of a full pathname
  Dim N%
  F$ = exGetName(F$)
  N% = InStr(F$, ".")
  If N% > 0 Then ExtractFileRoot$ = Left$(F$, N% - 1)
End Function

Function GetWinIniList$(pApp$)
Dim x%
Dim ret As String * 1024
Dim pDefault$
x% = GetPrivateProfileString(pApp$, "", pDefault$, ret, Len(ret), "WIN.INI")
If x% > 0 Then GetWinIniList$ = Left$(ret, x%)


End Function

Sub MsgExclaim(MyMsg$)
MsgBox MyMsg$, vbExclamation, App.Title
End Sub

Sub MsgInform(MyMsg$)
MsgBox MyMsg$, vbInformation, App.Title
End Sub







Sub WinCenter(F As Form)
F.Move (Screen.Width - F.Width) / 2, (Screen.Height - F.Height) / 2
End Sub

Function CheckForWin95%()
      Dim i%, lowbyte$, highbyte$
      i% = GetVersion()
      ' Lowbyte is derived by masking off high byte.
      lowbyte$ = Str$(i% And &HFF)
      ' Highbyte is derived by masking off low byte and shifting.
      highbyte$ = LTrim$(Str$((i% And &HFF00) / 256))
      ' Assign Windows version to text property.

      If Val(lowbyte$ + "." + highbyte$) > 3.8 Then
        CheckForWin95% = True
      Else
        CheckForWin95% = False
      End If

   End Function



Sub DelPrivIniItem(pApp$, pkey$, pFile$)
Dim x%
x% = WritePrivateProfileString(pApp$, pkey$, 0&, pFile$)
End Sub

Sub DelPrivIniSection(pApp$, pFile$)
Dim x%
x% = WritePrivateProfileString(pApp$, 0&, 0&, pFile$)
End Sub

Function ExtractFileName$(ByVal F$)
  ExtractFileName$ = exGetName(F$)

End Function

Function GetPrivINI$(pApp$, pkey$, pFile$)
Dim x%, pDefault$
Dim ret As String * 1024

x% = GetPrivateProfileString(pApp$, pkey$, pDefault$, ret, Len(ret), pFile$)
If x% > 0 Then GetPrivINI$ = Left$(ret, x%)
End Function

Function GetPrivIniInt%(pApp$, pkey$, pFile$)
Dim pDefault%
GetPrivIniInt% = GetPrivateProfileInt(pApp$, pkey$, pDefault%, pFile$)
End Function

Function CountListItems%(Source$, Sep$)
Dim counter%, i%, sepLen%, SourceLen%
Source$ = Trim$(Source$)
sepLen% = Len(Sep$)
If Right$(Source$, sepLen%) <> Sep$ Then Source$ = Source$ + Sep$
SourceLen% = Len(Source$)
If SourceLen% = sepLen% Then
    CountListItems% = 0
Else
    i% = InStr(Source$, Sep$)
    counter% = 0
    Do While i% > 0 And i% <= SourceLen%
      If Not (counter% = 0 And i% = 1) Then counter% = counter% + 1
      i% = InStr(i% + sepLen%, Source$, Sep$)
    Loop
    CountListItems% = counter%
  End If
End Function

Function ExtractFilePath$(ByVal F$)
Dim PathName$
PathName$ = F$
F$ = exGetName$(F$)
ExtractFilePath$ = Left$(PathName$, Len(PathName$) - Len(F$))
End Function

Function GetWinIni$(pApp$, key$)
Dim pDefault$
If key$ = "" Then

   GetWinIni$ = GetWinIniList$(pApp$)
Else
    Dim x%
    Dim ret As String * 1024
    x% = GetPrivateProfileString(pApp$, key$, pDefault$, ret, Len(ret), "WIN.INI")
    If x% > 0 Then GetWinIni$ = Left$(ret, x%)
End If

End Function


Function GetWinIniInt%(pApp$, pkey$)
Dim pDefault%
GetWinIniInt% = GetProfileInt(pApp$, pkey$, pDefault%)
End Function

Function ListPrivIniEntries$(pApp$, pFile$)
Dim x%, i%
Dim ret As String * 4096

Const MyBar = "|"
'a null for the item parameter returns a list of items
x% = GetPrivateProfileString(pApp$, 0&, "", ret, Len(ret), pFile$)
If x% > 0 Then
For i% = 1 To x% - 1
    If Mid$(ret$, i%, 1) = vbNullChar And Mid$(ret$, i% + 1, 1) <> vbNullChar Then
      Mid$(ret$, i%, 1) = MyBar
    End If
Next
ListPrivIniEntries$ = Left$(ret, x%)
End If
End Function

Function ListPrivIniSections$(pFile$)
Dim x%, tmp$, F%, accum$
'there's no api command for listing sections of an ini file
'so we do it the hard way, with vb's open command
F% = FreeFile
On Error Resume Next
Open pFile$ For Input As F
Do While Not EOF(F)
   Input #F, tmp$
   If Left$(tmp$, 1) = "[" Then accum$ = accum$ + MyCRLF$ + tmp$
Loop
Close F
ListPrivIniSections$ = Mid$(accum$, 3)
End Function

Sub PutPrivIni(pApp$, pkey$, ByVal pString$, pFile$)
Dim x%
x% = WritePrivateProfileString(pApp$, pkey, pString, pFile$)
End Sub

Function PutWinIniString%(pApp$, pkey$, pString$)

PutWinIniString% = WriteProfileString(pApp$, pkey$, pString$)
End Function

Function StripPath$(t$)
Dim x%, ct%
StripPath$ = t$
x% = InStr(t$, "\")
Do While x%
   ct% = x%
   x% = InStr(ct% + 1, t$, "\")
Loop
If ct% > 0 Then StripPath$ = Mid$(t$, ct% + 1)
End Function



Sub WinBringToTop(myHand%)
BringWindowToTop myHand%
End Sub

Function Exists%(F$)
On Error Resume Next
Exists% = Len(Dir$(F$)) > 0
End Function

Function FixAPIString$(ByVal test$)
If InStr(test$, Chr$(0)) > 1 Then
    FixAPIString$ = Trim(Left$(test$, InStr(test$, Chr$(0)) - 1))
ElseIf Left$(test$, 1) = Chr$(0) Then
    FixAPIString$ = ""
Else
    FixAPIString$ = Trim$(test$)
End If
End Function

Function FixPath1$(ByVal t$)
'sticks a backslash on the end of test$ if there's
'not one there already
'Dim t$
't$ = test$
If Right$(t$, 1) <> "\" Then t$ = t$ + "\"
FixPath1$ = t$
End Function


Function LBFindString%(lb As Control, Search$)
Dim i%, Y%, t%
t% = Len(Search$)
LBFindString% = -1
On Error Resume Next
i% = lb.ListCount
If i% = 0 Or t% = 0 Then Exit Function
For Y% = 0 To i% - 1
    If Left$(lb.List(Y%), t%) = Search$ Then LBFindString% = Y%: Exit For
Next
End Function

Sub SetTBReadOnly(Tb As TextBox, TF%)
'Dim x&, y%
'Const WM_USER = &H400
'Const EM_SETREADONLY = (WM_USER + 31)
'
'y% = WinSendMessage%(Tb.hWnd, EM_SETREADONLY, TF%, 0&)
End Sub

Function StripComma1(SC$) As Long
Dim S%
If InStr(SC$, ",") Then
    For S = 1 To Len(SC$)
        If Mid$(SC$, S, 1) = "," Then
            SC$ = Left$(SC$, S - 1) + Mid$(SC$, S + 1)
            S = S + 1
        End If
    Next
End If
StripComma1& = Val(SC$)
End Function

Function StripString$(S$)
'Strip embedded tabs from strings to make a nicer display
On Error Resume Next
S$ = Left$(S$, InStr(S$, Chr$(0)) - 1)
Dim i%
i% = InStr(S$, Chr$(9))
Do While i%
    Select Case i%
        Case Is = Len(S$)
            S$ = Left$(S$, i% - 1)
        Case Is > 1
            S$ = Left$(S$, i% - 1) + " " + Mid$(S$, i% + 1)
        Case Is = 1
            S$ = Mid$(S$, 2)
        Case Else
    End Select
    i% = InStr(S$, Chr$(9))
Loop
StripString$ = S$
End Function

Function Valid%(ByVal F$)
F$ = ExtractFileName$(F$)
If F$ = "" Then GoTo Fail
Valid% = True
Dim i%
F$ = Trim(F$)
If (InStr(F$, "*") <> 0) Then GoTo Fail
If (InStr(F$, "?") <> 0) Then GoTo Fail
If (InStr(F$, " ") <> 0) Then GoTo Fail
Dim LegalChar$, BackPos%, ForePos%, temp$
'--------------------------------------
LegalChar$ = "!#$%&'()-0123456789@ABCDEFGHIJKLMNOPQRSTUVWXYZ^_`{}~."
BackPos = 0
ForePos = Len(F$)   'InStr(F$, "\")
Do
   temp$ = Mid$(F$, BackPos + 1, ForePos - BackPos - 1)
'----------------------------
        ' Test for illegal characters
        '----------------------------
        For i = 1 To Len(temp$)
            If InStr(LegalChar$, UCase$(Mid$(temp$, i, 1))) = 0 Then GoTo Fail
        Next i

        '-------------------------------------------
        ' Check combinations of periods and lengths
        '-------------------------------------------
        Dim PeriodPos%, Length%
        PeriodPos = InStr(temp$, ".")
        Length = Len(temp$)
        If PeriodPos = 0 Then
            If Length > 8 Then GoTo Fail
        Else
            If PeriodPos > 9 Then GoTo Fail
            If Length > PeriodPos + 3 Then GoTo Fail
            If InStr(PeriodPos + 1, temp$, ".") <> 0 Then GoTo Fail
        End If
        BackPos = ForePos
        ForePos = InStr(BackPos + 1, F$, "\")
    Loop Until ForePos = 0
Exit Function
Fail:
Valid% = False: Exit Function
End Function