Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/vbmdixpl/utils.bas

BASIC Source File | 1995-05-09 | 10.7 KB | 351 lines

Declare Function WriteProfileString Lib "Kernel" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpString As String) As Integer
Declare Function GetProfileString Lib "Kernel" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Integer) As Integer
Declare Function GetPrivateProfileString Lib "Kernel" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Integer, ByVal lpFileName As String) As Integer
Declare Function WritePrivateProfileString Lib "Kernel" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpString As String, ByVal lplFileName As String) As Integer
Declare Sub WinHelp Lib "USER" (ByVal hWnd As Integer, ByVal HlpFile As String, ByVal Cmd As Integer, ByVal dwData As Any)
Declare Function GetAllTags Lib "Kernel" Alias "GetPrivateProfileString" (ByVal lpApplicationName As String, ByVal lpKeyName As Long, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize%, ByVal lpFileName$) As Integer
Declare Function GetWindowsDirectory Lib "Kernel" (ByVal lpBuffer As String, ByVal nSize As Integer) As Integer


Declare Function TrackPopupMenu% Lib "user" (ByVal hMenu%, ByVal wFlags%, ByVal X%, ByVal Y%, ByVal r2%, ByVal hWnd%, ByVal r1&)
Declare Function GetMenu% Lib "user" (ByVal hWnd%)
Declare Function GetSubMenu% Lib "user" (ByVal hMenu%, ByVal nPos%)


Sub Action (Message$)
' writes a text in the statusline
  MDIForm1.StatusLine.Caption = Message
End Sub



'   ======================================================
'   Centers the passed form just above center on the screen
'   ======================================================
Sub CenterForm (X As Form)
 '   Screen.MousePointer = 11
    X.Top = (Screen.Height * .85) / 2 - X.Height / 2
    X.Left = Screen.Width / 2 - X.Width / 2
 '   Screen.MousePointer = 0
End Sub

Sub CopyFile (source$, Dest$)

Dim TheBuffer As String
Const BuffLen = 16384

    On Error GoTo errhandler


    Open source$ For Binary Access Read As #1
    Open Dest$ For Binary Access Write As #2


    If LOF(1) < BuffLen Then
       TheBuffer = Space$(LOF(1))
    Else
       TheBuffer = Space$(BuffLen)
    End If
    'MsgBox (Str$(Seek(1)) + " " + Str$(LOF(1)))

    Do While Seek(1) < LOF(1)

    'MsgBox (Str$(Seek(1)) + " " + Str$(LOF(1)))

    If LOF(1) - Seek(1) < BuffLen Then
       TheBuffer = Space$(LOF(1) - Seek(1) + 1)
       Get #1, , TheBuffer
       Put #2, , TheBuffer   ' Write to file.
       Exit Do
    Else
       Get #1, , TheBuffer
       Put #2, , TheBuffer   ' Write to file.
    End If

    'Call UpdateStatus(Len(TheBuffer), FALSE)

    i% = DoEvents()
    Loop

    Close #1
    Close #2
    Exit Sub
errhandler:
    warning ("problem with copying file" + source$)
    Close #1
    Close #2
    Exit Sub
End Sub

Sub critical (TheStr$)
i% = MsgBox(TheStr, 16 + 4096, app.Title)
End Sub

Function doit (TheStr$) As Integer
' default is YES
  i% = MsgBox(TheStr, 4 + 32, app.Title)
  If i% = 6 Then
    doit = True
  Else
    doit = False
  End If
End Function

'   ======================================================
'   Get the size of the file
'   ======================================================
Function GetFileSize& (source$, ExitProg%)
    ExitProg% = False
    On Error GoTo SizeError
    X% = FreeFile
    Open source$ For Binary Access Read As X%
    GetFileSize& = LOF(X%)
    Close X%

TheEnd:
    On Error GoTo 0
    Exit Function

'   ====================================================
SizeError:
    Msg$ = "Error getting the size of the file "
    Msg$ = Msg$ + UCase$(source$) + ".  Cannot "
    Msg$ = Msg$ + "continue the installation."
    MsgBox Msg$, 48, "INSTALLATION ERROR"
    ExitProg% = True
    Resume TheEnd

End Function

Sub Information (TheStr$)
 i% = MsgBox(TheStr, 64, app.Title)
End Sub

Function IsValidPath% (ByVal DestPath$, ByVal DefaultDrive$)


'   ======================================================
'   Remove left and right spaces
'   ======================================================
'    DestPath$ = AllTrim$(DestPath$)
'    DefaultDrive$ = AllTrim$(DefaultDrive$)

'   ======================================================
'   Check Default Drive Parameter
'   ======================================================
    If Right$(DefaultDrive$, 1) <> ":" Or Len(DefaultDrive$) <> 2 Then
    Msg$ = "Bad default drive parameter specified in IsValidPath "
    Msg$ = Msg$ + "Function.  You passed,  """ + DefaultDrive$ + """.  Must "
    Msg$ = Msg$ + "be one drive letter and "":"".  For "
    Msg$ = Msg$ + "example, ""C:"", ""D:""..."
    MsgBox Msg$, 64, "Setup Kit Error"
    GoTo parseErr
    End If


'   ======================================================
'   Insert default drive if path begins with root backslash
'   ======================================================
    If Left$(DestPath$, 1) = "\" Then
    DestPath$ = DefaultDrive + DestPath$
    End If


'   ======================================================
'   check for invalid characters
'   ======================================================
    On Error Resume Next
    tmp$ = Dir$(DestPath$)
    If Err <> 0 Then
    GoTo parseErr
    End If


'   ======================================================
'   Check for wildcard characters and spaces
'   ======================================================
    If (InStr(DestPath$, "*") <> 0) GoTo parseErr
    If (InStr(DestPath$, "?") <> 0) GoTo parseErr
    If (InStr(DestPath$, " ") <> 0) GoTo parseErr


'   ======================================================
'   Make Sure colon is in second char position
'   ======================================================
    If Mid$(DestPath$, 2, 1) <> Chr$(58) Then GoTo parseErr


'   ======================================================
'   Insert root backslash if needed
'   ======================================================
    If Len(DestPath$) > 2 Then
      If Right$(Left$(DestPath$, 3), 1) <> "\" Then
    DestPath$ = Left$(DestPath$, 2) + "\" + Right$(DestPath$, Len(DestPath$) - 2)
      End If
    End If


'   ======================================================
'   Check drive to install on
'   ======================================================
    Drive$ = Left$(DestPath$, 1)
    ChDrive (Drive$)                        ' Try to change to the dest drive
    If Err <> 0 Then GoTo parseErr

'   ======================================================
'   Add final \
'   ======================================================
    If Right$(DestPath$, 1) <> "\" Then
    DestPath$ = DestPath$ + "\"
    End If


'   ======================================================
'   Root dir is a valid dir
'   ======================================================
    If Len(DestPath$) = 3 Then
    If Right$(DestPath$, 2) = ":\" Then
        GoTo ParseOK
    End If
    End If


'   ======================================================
'   Check for repeated Slash
'   ======================================================
    If InStr(DestPath$, "\\") <> 0 Then GoTo parseErr


'   ======================================================
'   Check for illegal directory names
'   ======================================================
    legalChar$ = "!#$%&'()-0123456789@ABCDEFGHIJKLMNOPQRSTUVWXYZ^_`{}~."
    BackPos = 3
    forePos = InStr(4, DestPath$, "\")
    Do
    Temp$ = Mid$(DestPath$, 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 parseErr
    Next i

    '-------------------------------------------
    'Check combinations of periods and lengths
    '-------------------------------------------
    periodPos = InStr(Temp$, ".")
    length = Len(Temp$)
    If periodPos = 0 Then
        If length > 8 Then GoTo parseErr                         'Base too long
    Else
        If periodPos > 9 Then GoTo parseErr                      'Base too long
        If length > periodPos + 3 Then GoTo parseErr             'Extension too long
        If InStr(periodPos + 1, Temp$, ".") <> 0 Then GoTo parseErr'Two periods not allowed
    End If

    BackPos = forePos
    forePos = InStr(BackPos + 1, DestPath$, "\")
    Loop Until forePos = 0

ParseOK:
    IsValidPath% = True
    Exit Function

parseErr:
    IsValidPath% = False
End Function

Sub RemoveFile (Fname$)
If doit("Delete " + Fname) = True Then
   Kill (Fname)
End If
End Sub


Function retry (TheStr$) As Integer
  i% = MsgBox(TheStr, 5 + 32, app.Title)
  If i% = 4 Then
    retry = True
  Else
    retry = False
  End If

End Function

Sub ShowPopup (MyForm As Form, X As Single, Y As Single)
' shows a floating popup that is defined in the MDIform
' Change the invisible items to your needs
' First parameter is the form, on which the Popup is to be shown

Const PIXEL = 3
Const TWIP = 1
    MyForm.ScaleMode = PIXEL
    InPixels = MyForm.ScaleWidth
    MyForm.ScaleMode = TWIP
    IX = (X + MyForm.Left + MDIForm1.Left) \ (MyForm.ScaleWidth \ InPixels)
    IY = (Y + (MyForm.Top + MDIForm1.Top + (MyForm.Height - MyForm.ScaleHeight - (MyForm.Width - MyForm.ScaleWidth)))) \ (MyForm.ScaleWidth \ InPixels)


    hMenu% = GetMenu(MDIForm1.hWnd)
    If MDIForm1.ActiveForm.WindowState = 2 Then ' maximized. add 1 for MDI close box
       hSubMenu% = GetSubMenu(hMenu%, 2) 'use EDIT menu, change !!!
     Else
       hSubMenu% = GetSubMenu(hMenu%, 1) 'use EDIT menu, change !!!
    End If
    R = TrackPopupMenu(hSubMenu%, 0, IX, IY, 0, MDIForm1.hWnd, 0)

End Sub

Function VBstr (TheStr$) As String
' stripped einen Null terminerten String
' als VB string :
Dim TheTmp As String

     NullPos% = InStr(TheStr, Chr$(0))
     TheTmp = RTrim$(Left$(TheStr, NullPos% - 1))
     VBstr = TheTmp

End Function

Sub WaitOff ()
  Screen.MousePointer = 0
End Sub

Sub WaitOn ()
  Screen.MousePointer = 11
End Sub

Sub warning (TheStr$)
    MsgBox TheStr, 48, app.Title
End Sub

Function WinDir () As String
Dim TheStr As String * 256
     i% = GetWindowsDirectory(TheStr, 256)

     'MsgBox (":" + TheStr + ":")
     'MsgBox (Str$(Len(TheStr)))
     TheStr = LTrim$(TheStr)
     'MsgBox (":" + TheStr + ":")
     NullPos% = InStr(TheStr, Chr$(0))
     'MsgBox (Str$(NullPos%))

     TheTmp$ = RTrim$(Left$(TheStr, NullPos% - 1))
     'MsgBox (":" + TheTmp$ + ":")
     WinDir = TheTmp$
End Function

Function YouShure (TheStr$)
' default is NO
  i% = MsgBox(TheStr, 4 + 16 + 256, app.Title)
  If i% = 6 Then
    YouShure = True
  Else
    YouShure = False
  End If

End Function