setup1.bas

Custom Visual Basic Packager and Installer for Visual Basic Developers. This is a group of standard

CheckDSAskSpace:
    '
    'if the user hasn't been prompted before in the event of not enough free space,
    'then display table of drive space and allow them to (basically) abort, retry,
    'or ignore.
    '
    If fDontAskOnSpaceErr = False Then
        If gfNoUserInput Then
            If gfSilent = True Then
                LogSilentMsg ResolveResString(resLBLNOSPACE)
            End If
            If gfSMS = True Then
                LogSMSMsg ResolveResString(resLBLNOSPACE)
            End If
            ExitSetup frmSetup1, gintRET_FATAL
        Else
            frmDskSpace.Show vbModal
        End If
        
        If gfRetVal <> gintRET_CONT Then
            CheckDiskSpace = False
            Exit Function
        Else
            fDontAskOnSpaceErr = True
        End If
    End If

    Return
End Function

'-----------------------------------------------------------
' FUNCTION: CheckDrive
'
' Check to see if the specified drive is ready to be read
' from.  In the case of a drive that holds removable media,
' this would mean that formatted media was in the drive and
' that the drive door was closed.
'
' IN: [strDrive] - drive to check
'     [strCaption] - caption if the drive isn't ready
'
' Returns: True if the drive is ready, False otherwise
'-----------------------------------------------------------
'
Function CheckDrive(ByVal strDrive As String, ByVal strCaption As String) As Integer
    Dim strDir As String
    Dim strMsg As String
    Dim fIsUNC As Boolean

    On Error Resume Next

    SetMousePtr vbHourglass

    Do
        Err = 0
        fIsUNC = False
        '
        'Attempt to read the current directory of the specified drive.  If
        'an error occurs, we assume that the drive is not ready
        '
        If IsUNCName(strDrive) Then
            fIsUNC = True
            strDir = Dir$(GetUNCShareName(strDrive))
        Else
            strDir = Dir$(Left$(strDrive, 2))
        End If

        If Err > 0 Then
            If fIsUNC Then
                strMsg = Error$ & vbLf & vbLf & ResolveResString(resCANTREADUNC, "|1", strDrive) & vbLf & vbLf & ResolveResString(resCHECKUNC)
            Else
                strMsg = Error$ & vbLf & vbLf & ResolveResString(resDRVREAD) & strDrive & vbLf & vbLf & ResolveResString(resDRVCHK)
            End If
            If MsgError(strMsg, vbExclamation Or vbRetryCancel, strCaption) = vbCancel Then
                CheckDrive = False
                Err = 0
            End If
        Else
            CheckDrive = True
        End If
        
        If Err And gfNoUserInput = True Then
            ExitSetup frmSetup1, gintRET_FATAL
        End If
    Loop While Err

    SetMousePtr gintMOUSE_DEFAULT
End Function

'-----------------------------------------------------------
' FUNCTION: CheckOverwritePrivateFile
'
' Checks if a private file that we are about to install
' already exists in the destination directory.  If it
' does, it asks if they want to overwrite the file
'
' IN: [strFN] - Full path of the private file that is
'               about to be installed.
'
'-----------------------------------------------------------
'
Public Function CheckOverwritePrivateFile(ByVal strFN As String) As Boolean
    Static fNoToAll As Boolean
    
    If fNoToAll Then 'They've already said no to all, don't ask again
        CheckOverwritePrivateFile = False
        Exit Function
    End If
    If FileExists(strFN) Then
        Do
            Select Case MsgFunc(ResolveResString(resOVERWRITEPRIVATE) & vbLf & vbLf & ResolveResString(resCANCELSETUP), vbYesNo Or vbDefaultButton1 Or vbExclamation, gstrTitle)
                Case vbYes
                    'The user chose to cancel.  (This is best.)
                    gfDontLogSMS = True  ' Don't log this message if SMS because we already logged the previous one and we can only use 255 characters.
                    MsgError ResolveResString(resCHOOSENEWDEST), vbOKOnly, gstrTitle
                    ExitSetup frmCopy, gintRET_FATAL
                Case Else
                    'One more level of warning to let them know that we highly
                    '  recommend cancelling setup at this point
                    Select Case MsgFunc(ResolveResString(resOVERWRITEPRIVATE2) & vbLf & vbLf & ResolveResString(resVERIFYCONTINUE), vbYesNo Or vbDefaultButton2 Or vbExclamation, gstrTitle)
                        Case vbNo
                            'User chose "no, don't continue"
                            'Repeat the first-level warning
                        Case Else
                            'They decided to continue anyway
                            Exit Do
                        'End Case
                    End Select
                'End Case
            End Select
        Loop
    Else
        CheckOverwritePrivateFile = True
    End If
End Function

'-----------------------------------------------------------
' FUNCTION: CopyFile
'
' Uses the Windows VerInstallFile API to copy a file from
' the specified source location/name to the destination
' location/name.  Split files should be combined via the
' '...Concat...' file routines before calling this
' function.
' If the file is successfully updated and the file is a
' shared file (fShared = True), then the
' files reference count is updated (32-bits only)
'
' IN: [strSrcDir] - directory where source file is located
'     [strDestDir] - destination directory for file
'     [strSrcName] - name of source file
'     [strDestName] - name of destination file
'
' PRECONDITION: NewAction() must have already been called
'               for this file copy (of type either
'               gstrKEY_SHAREDFILE or gstrKEY_PRIVATE --
'               see CopySection for an example of how
'               this works).  See NewAction() and related
'               functions in LOGGING.BAS for comments on
'               using the logging function.
'               Either CommitAction() or AbortAction() will
'               allows be called by this procedure, and
'               should not be done by the caller.
'
' Returns: True if copy was successful, False otherwise
'
' POSTCONDITION: The current action will be either committed or
'                aborted.
'-----------------------------------------------------------
'
Function CopyFile(ByVal strSrcDir As String, ByVal strDestDir As String, ByVal strSrcName As String, ByVal strDestName As String, ByVal fShared As Boolean, ByVal fSystem As Boolean, Optional ByVal fOverWrite As Boolean = False) As Boolean
    Const intUNKNOWN% = 0
    Const intCOPIED% = 1
    Const intNOCOPY% = 2
    Const intFILEUPTODATE% = 3

    '
    'VerInstallFile() Flags
    '
    Const VIFF_FORCEINSTALL% = &H1
    Const VIF_TEMPFILE& = &H1
    Const VIF_SRCOLD& = &H4
    Const VIF_DIFFLANG& = &H8
    Const VIF_DIFFCODEPG& = &H10
    Const VIF_DIFFTYPE& = &H20
    Const VIF_WRITEPROT& = &H40
    Const VIF_FILEINUSE& = &H80
    Const VIF_OUTOFSPACE& = &H100
    Const VIF_ACCESSVIOLATION& = &H200
    Const VIF_SHARINGVIOLATION = &H400
    Const VIF_CANNOTCREATE = &H800
    Const VIF_CANNOTDELETE = &H1000
    Const VIF_CANNOTRENAME = &H2000
    Const VIF_OUTOFMEMORY = &H8000&
    Const VIF_CANNOTREADSRC = &H10000
    Const VIF_CANNOTREADDST = &H20000
    Const VIF_BUFFTOOSMALL = &H40000

    Static fIgnoreWarn As Integer             'user warned about ignoring error?

    Dim strMsg As String
    Dim lRC As Long
    Dim lpTmpNameLen As Long
    Dim intFlags As Integer
    Dim intRESULT As Integer
    Dim fFileAlreadyExisted

    On Error Resume Next

    CopyFile = False

    '
    'Ensure that the source file is available for copying
    '
    If DetectFile(strSrcDir & strSrcName) = vbIgnore Then
        AbortAction
        Exit Function
    End If
    
    '
    ' Make sure that the Destination path (including path, filename, commandline args, etc.
    ' is not longer than the max allowed.
    '
    If Not fCheckFNLength(strDestDir & strDestName) Then
        AbortAction
        strMsg = ResolveResString(resCANTCOPYPATHTOOLONG) & vbLf & vbLf & ResolveResString(resCHOOSENEWDEST) & vbLf & vbLf & strDestDir & strDestName
        Call MsgError(strMsg, vbOKOnly, gstrSETMSG)
        ExitSetup frmCopy, gintRET_FATAL
        Exit Function
    End If
    '
    'Make the destination directory, prompt the user to retry if there is an error
    '
    If Not MakePath(strDestDir) Then
        AbortAction ' Abort file copy
        Exit Function
    End If

    '
    'Make sure we have the LFN (long filename) of the destination directory
    '
    strDestDir = GetLongPathName(strDestDir)
    
    '
    'Setup for VerInstallFile call
    '
    lpTmpNameLen = gintMAX_SIZE
    mstrVerTmpName = String$(lpTmpNameLen, 0)
    intFlags = 0
    If fOverWrite Then intFlags = VIFF_FORCEINSTALL
    fFileAlreadyExisted = FileExists(strDestDir & strDestName)

    intRESULT = intUNKNOWN

    Do While intRESULT = intUNKNOWN
        'VerInstallFile under Windows 95 does not handle
        '  long filenames, so we must give it the short versions
        '  (32-bit only).
        Dim strShortSrcName As String
        Dim strShortDestName As String
        Dim strShortSrcDir As String
        Dim strShortDestDir As String
        
        strShortSrcName = strSrcName
        strShortSrcDir = strSrcDir
        strShortDestName = strDestName
        strShortDestDir = strDestDir
        If Not FileExists(strDestDir & strDestName) Then
            'If the destination file does not already
            '  exist, we create a dummy with the correct
            '  (long) filename so that we can get its
            '  short filename for VerInstallFile.
            Open strDestDir & strDestName For Output Access Write As #1
            Close #1
        End If
    
        On Error GoTo UnexpectedErr
        If Not IsWindowsNT() Then
            Dim strTemp As String
            'This conversion is not necessary under Windows NT
            strShortSrcDir = GetShortPathName(strSrcDir)
            If GetFileName(strSrcName) = strSrcName Then
                strShortSrcName = GetFileName(GetShortPathName(strSrcDir & strSrcName))
            Else
                strTemp = GetShortPathName(strSrcDir & strSrcName)
                strShortSrcName = Mid$(strTemp, Len(strShortSrcDir) + 1)
            End If
            strShortDestDir = GetShortPathName(strDestDir)
            strShortDestName = GetFileName(GetShortPathName(strDestDir & strDestName))
        End If
        On Error Resume Next
            
        lRC = VerInstallFile(intFlags, strShortSrcName, strShortDestName, strShortSrcDir, strShortDestDir, 0&, mstrVerTmpName, lpTmpNameLen)
        If Err <> 0 Then
            '
            'If the version or file expansion DLLs couldn't be found, then abort setup
            '
            ExitSetup frmCopy, gintRET_FATAL
        End If

        If lRC = 0 Then
            '
            'File was successfully installed, increment reference count if needed
            '