Programmer 7500/MAX_PROGRAMMERS.iso/VISUAL_B/CODIGO_1/CUSGEN12/SETUP1.BAS

BASIC Source File | 1993-02-19 | 18.6 KB | 577 lines

'-------------------------------------------------------
'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

'---------------------------------------------------------------
'Copies file Filename from SourcePath to DestinationPath.
'If VerFlag is set to true (-1) then use version checking
'algorithm so older versions are not copied over newer versions
'
'Returns 0 if it could not find the file, or other runtime
'error occurs.  Otherwise, returns true.
'
'If the source file is older, and the older% parameter is
'true, the function returns success (-1) even though no
'file was copied, since no error occurred.
'---------------------------------------------------------------
Function CopyFile (ByVal SourcePath As String, ByVal DestinationPath As String, ByVal filename As String, VerFlag As Integer)
    Dim Index As Integer
    Dim FileLength As Long
    Dim LeftOver As Long
    Dim FileData As String

    Screen.MousePointer = 11

    '--------------------------------------
    'Add ending \ symbols to path variables
    '--------------------------------------
    If Right$(SourcePath$, 1) <> "\" Then
    SourcePath$ = SourcePath$ + "\"
    End If
    If Right$(DestinationPath$, 1) <> "\" Then
    DestinationPath$ = DestinationPath$ + "\"
    End If

    '----------------------------
    'Update status dialog info
    '----------------------------
    Statusdlg.Label1.Caption = "Source file: " + Chr$(10) + Chr$(13) + UCase$(SourcePath$ + filename$)
    Statusdlg.Label1.Refresh
    Statusdlg.Label2.Caption = "Destination file: " + Chr$(10) + Chr$(13) + UCase$(DestinationPath$ + filename$)
    Statusdlg.Label2.Refresh

    If Not FileExists(SourcePath$ + filename$) Then
    MsgBox "Error occurred while attempting to copy file.  Could not locate file: """ + SourcePath$ + filename$ + """", 64, "SETUP"
    GoTo ErrorCopy
    End If

    On Error GoTo ErrorCopy

    '-------------------------------------------------
    ' If version checking set to True, then get their
    ' version info, skip if older version
    '-------------------------------------------------
    If VerFlag Then
    szBufSrc$ = String$(255, 32)
    Call GetFileVersion(SourcePath$ + filename$, szBufSrc$, Len(szBufSrc$))

    szBufDest$ = String$(255, 32)
    Call GetFileVersion(DestinationPath$ + filename$, szBufDest$, Len(szBufDest$))

    If szBufSrc$ < szBufDest$ Then GoTo SkipCopy

    End If


    '-------------
    'Copy the file
    '-------------
    'Const BlockSize = 32768
     Const blocksize = 15322
    Open SourcePath$ + filename$ For Binary Access Read As #1

    Open DestinationPath$ + filename$ For Output As #2
    Close #2

    Open DestinationPath$ + filename$ For Binary As #2

    FileLength = LOF(1)
    UpdateStatus FileLength

    NumBlocks = FileLength \ blocksize
    LeftOver = FileLength Mod blocksize

    FileData = String$(LeftOver, 32)

    Get #1, , FileData
    Put #2, , FileData

    FileData = String$(blocksize, 32)

    For Index = 1 To NumBlocks
    Get #1, , FileData
    Put #2, , FileData
    Next Index

    Close #1, #2
    x = SetFileDateTime(SourcePath$ + filename$, DestinationPath$ + filename$)

SkipCopy:
    szBufSrc$ = ""
    szBufDest$ = ""
    Screen.MousePointer = 0
    CopyFile = True
    Exit Function


ErrorCopy:
    CopyFile = False
    Close
    Resume
End Function

'---------------------------------------------
'Create the path contained in DestPath$
'First char must be drive letter, followed by
'a ":\" followed by the path, if any.
'---------------------------------------------
Function CreatePath (ByVal destpath$) As Integer
    Screen.MousePointer = 11

    '---------------------------------------------
    'Add slash to end of path if not there already
    '---------------------------------------------
    If Right$(destpath$, 1) <> "\" Then
    destpath$ = destpath$ + "\"
    End If


    '-----------------------------------
    'Change to the root dir of the drive
    '-----------------------------------
    On Error Resume Next
    ChDrive destpath$
    If Err <> 0 Then GoTo errorOut
    ChDir "\"

    '-------------------------------------------------
    'Attempt to make each directory, then change to it
    '-------------------------------------------------
    BackPos = 3
    forePos = InStr(4, destpath$, "\")
    Do While forePos <> 0
    temp$ = Mid$(destpath$, BackPos + 1, forePos - BackPos - 1)

    Err = 0
    MkDir temp$
    If Err <> 0 And Err <> 75 Then GoTo errorOut

    Err = 0
    ChDir temp$
    If Err <> 0 Then GoTo errorOut

    BackPos = forePos
    forePos = InStr(BackPos + 1, destpath$, "\")
    Loop

    CreatePath = True
    Screen.MousePointer = 0
    Exit Function

errorOut:
    MsgBox "Error While Attempting to Create Directories on Destination Drive.", 48, "SETUP"
    CreatePath = False
    Screen.MousePointer = 0

End Function

'-------------------------------------------------------------
' Procedure: CreateProgManGroup
' Arguments: X           The Form where a Label1 exist
'            GroupName$  A string that contains the group name
'            GroupPath$  A string that contains the group file
'                        name  ie 'myapp.grp'
'-------------------------------------------------------------
Sub CreateProgManGroup (x As Form, GroupName$, GroupPath$)

    Screen.MousePointer = 11

    '----------------------------------------------------------------------
    'Windows requires DDE in order to create a program group and item.
    'Here, a Visual Basic label control is used to generate the DDE messages
    '----------------------------------------------------------------------
    On Error Resume Next


    '--------------------------------
    'Set LinkTopic to PROGRAM MANAGER
    '--------------------------------
    x.Label1.LinkTopic = "ProgMan|Progman"
    x.Label1.LinkMode = 2
    For i% = 1 To 10                                         ' Loop to ensure that there is enough time to
      z% = DoEvents()                                        ' process DDE Execute.  This is redundant but needed
    Next                                                     ' for debug windows.
    x.Label1.LinkTimeout = 100


    '---------------------
    ' Create program group
    '---------------------
    x.Label1.LinkExecute "[CreateGroup(" + GroupName$ + Chr$(44) + GroupPath$ + ")]"


    '-----------------
    'Reset properties
    '-----------------
    x.Label1.LinkTimeout = 50
    x.Label1.LinkMode = 0

    Screen.MousePointer = 0
End Sub

'----------------------------------------------------------
' Procedure: CreateProgManItem
'
' Arguments: X           The form where Label1 exists
'
'            CmdLine$    A string that contains the command
'                        line for the item/icon.
'                        ie 'c:\myapp\setup.exe'
'
'            IconTitle$  A string that contains the item's
'                        caption
'----------------------------------------------------------
Sub CreateProgManItem (x As Form, CmdLine$, IconTitle$)

    Screen.MousePointer = 11

    '----------------------------------------------------------------------
    'Windows requires DDE in order to create a program group and item.
    'Here, a Visual Basic label control is used to generate the DDE messages
    '----------------------------------------------------------------------
    On Error Resume Next


    '---------------------------------
    'Set LinkTopic to PROGRAM MANAGER
    '---------------------------------
    x.Label1.LinkTopic = "ProgMan|Progman"
    x.Label1.LinkMode = 2
    For i% = 1 To 10                                         ' Loop to ensure that there is enough time to
      z% = DoEvents()                                        ' process DDE Execute.  This is redundant but needed
    Next                                                     ' for debug windows.
    x.Label1.LinkTimeout = 100


    '------------------------------------------------
    'Create Program Item, one of the icons to launch
    'an application from Program Manager
    '------------------------------------------------
    x.Label1.LinkExecute "[AddItem(" + CmdLine$ + Chr$(44) + IconTitle$ + Chr$(44) + ",,)]"

    '-----------------
    ' Reset properties
    '-----------------
    x.Label1.LinkTimeout = 50
    x.Label1.LinkMode = 0

    Screen.MousePointer = 0
End Sub

'----------------------------------------------------------
' Check for the existence of a file by attempting an OPEN.
'----------------------------------------------------------
Function FileExists (path$) As Integer

    x = FreeFile

    On Error Resume Next
    Open path$ For Input As x
    If Err = 0 Then
    FileExists = True
    Else
    FileExists = False
    End If
    Close x

End Function

'------------------------------------------------
'Get the disk space free for the current drive
'------------------------------------------------
Function GetDiskSpaceFree (drive As String) As Long
    ChDrive drive
    GetDiskSpaceFree = DiskSpaceFree()
End Function

'----------------------------------------------------
'  Get the disk Allocation unit for the current drive
'----------------------------------------------------
Function GetDrivesAllocUnit (drive As String) As Long
    ChDrive drive
    GetDrivesAllocUnit = AllocUnit()
End Function

'------------------------
'Get the size of the file
'------------------------
Function GetFileSize (Source$) As Long
    x = FreeFile
    Open Source$ For Binary Access Read As x
    GetFileSize = LOF(x)
    Close x
End Function

'--------------------------------------------------
'Calls the windows API to get the windows directory
'--------------------------------------------------
Function GetWindowsDir () As String
    temp$ = String$(145, 0)              'Size Buffer
    x = GetWindowsDirectory(temp$, 145)  'Make API Call
    temp$ = Left$(temp$, x)              'Trim Buffer

    If Right$(temp$, 1) <> "\" Then      'Add \ if necessary
    GetWindowsDir$ = temp$ + "\"
    Else
    GetWindowsDir$ = temp$
    End If
End Function

'---------------------------------------------------------
'Calls the windows API to get the windows\SYSTEM directory
'---------------------------------------------------------
Function GetWindowsSysDir () As String
    temp$ = String$(145, 0)                 'Size Buffer
    x = GetSystemDirectory(temp$, 145)      'Make API Call
    temp$ = Left$(temp$, x)                 'Trim Buffer

    If Right$(temp$, 1) <> "\" Then         'Add \ if necessary
    GetWindowsSysDir$ = temp$ + "\"
    Else
    GetWindowsSysDir$ = temp$
    End If
End Function

'------------------------------------------------------
' Function:   IsValidPath as integer
' arguments:  DestPath$         a string that is a full path
'             DefaultDrive$     the default drive.  eg.  "C:"
'
'  If DestPath$ does not include a drive specification,
'  IsValidPath uses Default Drive
'
'  When IsValidPath is finished, DestPath$ is reformated
'  to the format "X:\dir\dir\dir\"
'
' Result:  True (-1) if path is valid.
'          False (0) if path is invalid
'-------------------------------------------------------
Function IsValidPath (destpath$, ByVal DefaultDrive$) As Integer

    '----------------------------
    'Remove left and right spaces
    '----------------------------
    destpath$ = RTrim$(LTrim$(destpath$))


    '-----------------------------
    'Check Default Drive Parameter
    '-----------------------------
    If Right$(DefaultDrive$, 1) <> ":" Or Len(DefaultDrive$) <> 2 Then
    MsgBox "Bad default drive parameter specified in IsValidPath Function.  You passed,  """ + DefaultDrive$ + """.  Must be one drive letter and "":"".  For example, ""C:"", ""D:""...", 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

'----------------------------------------------------
' Prompt for the next disk.  Use the FileToLookFor$
' argument to verify that the proper disk, disk number
' wDiskNum, was inserted.
'----------------------------------------------------
Function PromptForNextDisk (wDiskNum As Integer, FileToLookFor$) As Integer

    '-------------------------
    'Test for file
    '-------------------------
    Ready = False
    On Error Resume Next
    temp$ = Dir$(FileToLookFor$)

    '------------------------
    'If not found, start loop
    '------------------------
    If Err <> 0 Or Len(temp$) = 0 Then
    While Not Ready
        '----------------------------
        'Put up msg box
        '----------------------------
        Beep
        x = MsgBox("Please insert disk # " + Format$(wDiskNum%), 49, "SETUP")
        If x = 2 Then
        '-------------------------------
        'Use hit cancel, abort the copy
        '-------------------------------
        PromptForNextDisk = False
        GoTo ExitProc
        Else
        '----------------------------------------
        'User hits OK, try to find the file again
        '----------------------------------------
        temp$ = Dir$(FileToLookFor$)
        If Err = 0 And Len(temp$) <> 0 Then
            PromptForNextDisk = True
            Ready = True
        End If
        End If
    Wend
    Else
    PromptForNextDisk = True
    End If



ExitProc:

End Function

Sub RestoreProgMan ()
    AppActivate "Program Manager"   ' Activate Program Manager.
    SendKeys "%{ }{Enter}", True      ' Send Restore keystrokes.
End Sub

'-----------------------------------------------------------------------------
'Set the Destination File's date and time to the Source file's date and time
'-----------------------------------------------------------------------------
Function SetFileDateTime (SourceFile As String, DestinationFile As String) As Integer
    x = SetTime(SourceFile, DestinationFile)
    SetFileDateTime = -1
End Function

Sub UpdateStatus (FileLength As Long)
'-----------------------------------------------------------------------------
'Update the status bar using form.control Statusdlg.Picture2
'-----------------------------------------------------------------------------
    Static position
    Dim estTotal As Long

    estTotal = Val(Statusdlg.total.Tag)
    If estTotal = False Then
    estTotal = 10000000
    End If

    position = position + CSng((FileLength / estTotal) * 100)
    If position > 100 Then
    position = 100
    End If
    Statusdlg.Picture2.Cls
    Statusdlg.Picture2.Line (0, 0)-((position * (Statusdlg.Picture2.ScaleWidth / 100)), Statusdlg.Picture2.ScaleHeight), QBColor(4), BF

    Txt$ = Format$(CLng(position)) + "%"
    Statusdlg.Picture2.CurrentX = (Statusdlg.Picture2.ScaleWidth - Statusdlg.Picture2.TextWidth(Txt$)) \ 2
    Statusdlg.Picture2.CurrentY = (Statusdlg.Picture2.ScaleHeight - Statusdlg.Picture2.TextHeight(Txt$)) \ 2
    Statusdlg.Picture2.Print Txt$

    r = BitBlt(Statusdlg.Picture1.hDC, 0, 0, Statusdlg.Picture2.ScaleWidth, Statusdlg.Picture2.ScaleHeight, Statusdlg.Picture2.hDC, 0, 0, SRCCOPY)
End Sub