Category : BASIC Source Code
Archive   : VINST8.ZIP
Filename : SETUP1.BAS

DefInt A-Z

Option Explicit

Function AskAboutCancel% ()
Dim Msg$
Dim MBFlags%, Res%

Msg$ = "You have not completeted installing the program. "
Msg$ = Msg$ & "Are you sure you want to abort?"
MBFlags% = MB_YESNO + MB_ICONQUESTION + MB_DEFBUTTON2
Res% = MsgBox(Msg$, MBFlags%, "SETUP")
If Res% = IDYES Then
AskAboutCancel% = True
gCancelCommand% = True
ElseIf Res% = IDNO Then
AskAboutCancel% = False
gCancelCommand% = False
End If
End Function

Function AskAboutForce% (Msg$)
Dim MBFlags%, Res%

Msg$ = Msg$ & gCrLf$ & "Do you want to "
Msg$ = Msg$ & "replace this file?"
MBFlags% = MB_YESNO & MB_DEFBUTTON2 & MB_ICONQUESTION
Res% = MsgBox(Msg$, 0, "SETUP")

If Res% = IDYES Then
AskAboutForce% = True
Else
AskAboutForce% = False
End If
End Function

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

' --------------------------------------------------------
' This file handles the errors that may result from
' calling VerInstallFile&
' If CopyFile% is TRUE and ForceInstall% is TRUE, then
' force the installation of the file.
' --------------------------------------------------------
Sub CheckTheError (result&, S$, D$, CopyFile2%, ForceInstall%)

Dim x%, MBFlags% ''''
Dim Msg$

If result& = (result& And VIF_SRCOLD&) = VIF_SRCOLD& Then
CopyFile2% = True
Msg$ = "The file you are about to install is older than "
Msg$ = Msg$ & "the pre-existing file."
ForceInstall% = AskAboutForce%(Msg$)
ElseIf (result& And VIF_DIFFLANG&) = VIF_DIFFLANG& Then
CopyFile2% = True
Msg$ = "The file you are about to install has a different "
Msg$ = Msg$ & "language or code-page value than the "
Msg$ = Msg$ & "pre-existing file."
ForceInstall% = AskAboutForce%(Msg$)
ElseIf (result& And VIF_DIFFCODEPG&) = VIF_DIFFCODEPG& Then
CopyFile2% = True
Msg$ = "The file you are about to install requires "
Msg$ = Msg$ & "a code-page that cannot be displayed by "
Msg$ = Msg$ & "the currently running version of Windows."
ForceInstall% = AskAboutForce%(Msg$)
ElseIf (result& And VIF_DIFFTYPE&) = VIF_DIFFTYPE& Then
CopyFile2% = True
Msg$ = "The file you are about to install has a "
Msg$ = Msg$ & "different type, sub-type, or operating "
Msg$ = Msg$ & "system than the pre-existing file."
ForceInstall% = AskAboutForce%(Msg$)
ElseIf (result& And VIF_WRITEPROT&) = VIF_WRITEPROT& Then
CopyFile2% = False
ForceInstall% = False
Msg$ = "The file, " & UCase$(D$) & " is write-protected. "
Msg$ = Msg$ & "Please change the attributes of this file "
Msg$ = Msg$ & "and re-install the program."
MBFlags% = MB_OK & MB_ICONEXCLAMATION
MsgBox Msg$, MBFlags%, "SETUP"
ElseIf (result& And VIF_FILEINUSE&) = VIF_FILEINUSE& Then
CopyFile2% = False
ForceInstall% = False
Msg$ = "The file, " & UCase$(D$) & " is in use. Please "
Msg$ = Msg$ & "close all applications and re-attempt Setup."
MBFlags% = MB_OK & MB_ICONEXCLAMATION
MsgBox Msg$, MBFlags%, "SETUP"
ElseIf (result& And VIF_OUTOFSPACE&) = VIF_OUTOFSPACE& Then
CopyFile2% = False
ForceInstall% = False
Msg$ = "Cannot create a temporary file, " & UCase$(D$)
Msg$ = Msg$ & "on the " & UCase$(Mid$(D$, 1, 1)) & " drive."
MBFlags% = MB_OK & MB_ICONEXCLAMATION
MsgBox Msg$, MBFlags%, "SETUP"
ElseIf (result& And VIF_ACCESSVIOLATION&) = VIF_ACCESSVIOLATION& Then
CopyFile2% = False
ForceInstall% = False
Msg$ = "An access violation occured while creating, deleting, "
Msg$ = Msg$ & "or renaming the file " & UCase$(D$) & "."
MBFlags% = MB_OK & MB_ICONEXCLAMATION
MsgBox Msg$, MBFlags%, "SETUP"
ElseIf (result& And VIF_SHARINGVIOLATION&) = VIF_SHARINGVIOLATION& Then
CopyFile2% = False
ForceInstall% = False
Msg$ = "An sharing violation occured while creating, deleting, "
Msg$ = Msg$ & "or renaming the file " & UCase$(D$) & "."
MBFlags% = MB_OK & MB_ICONEXCLAMATION
MsgBox Msg$, MBFlags%, "SETUP"
ElseIf (result& And VIF_CANNOTDELETE&) = VIF_CANNOTDELETE& Then
CopyFile2% = False
ForceInstall% = False
If (result& And VIF_TEMPFILE&) = VIF_TEMPFILE& Then
Msg$ = "The destination file, " & UCase$(D$)
Msg$ = Msg$ & " cannot be deleted."
MBFlags% = MB_OK & MB_ICONEXCLAMATION
MsgBox Msg$, MBFlags%, "SETUP"
End If
ElseIf (result& And VIF_CANNOTRENAME&) = VIF_CANNOTRENAME& Then
CopyFile2% = False
ForceInstall% = False
Msg$ = "An access violation occured while creating, deleting, "
Msg$ = Msg$ & "or renaming the file " & UCase$(D$) & "."
MBFlags% = MB_OK & MB_ICONEXCLAMATION
MsgBox Msg$, MBFlags%, "SETUP"
ElseIf (result& And VIF_OUTOFMEMORY&) = VIF_OUTOFMEMORY& Then
CopyFile2% = False
ForceInstall% = False
Msg$ = "The installation utility ran out of memory while "
Msg$ = Msg$ & "trying to uncompress the file, " & UCase$(D$)
Msg$ = Msg$ & ". Please close some of your applications "
Msg$ = Msg$ & "and try again."
MBFlags% = MB_OK & MB_ICONEXCLAMATION
MsgBox Msg$, MBFlags%, "SETUP"
ElseIf (result& And VIF_CANNOTREADSRC&) = VIF_CANNOTREADSRC& Then
CopyFile2% = False
ForceInstall% = False
' --------------------------------------------------
' This error could also mean that the path was not
' specified correctly, or that the files does not
' exist, but we have already check for both of
' these items.
' --------------------------------------------------
Msg$ = "The compressed file, " & UCase$(S$) & " has been "
Msg$ = Msg$ & "corrupted and cannot be uncompressed."
MBFlags% = MB_OK & MB_ICONEXCLAMATION
MsgBox Msg$, MBFlags%, "SETUP"
ElseIf (result& And VIF_CANNOTREADDST&) = VIF_CANNOTREADDST& Then
CopyFile2% = False
ForceInstall% = False
Msg$ = "Cannot read the destination file, " & UCase$(D$) & "."
MBFlags% = MB_OK & MB_ICONEXCLAMATION
MsgBox Msg$, MBFlags%, "SETUP"
ElseIf (result& And VIF_BUFFTOOSMALL&) = VIF_BUFFTOOSMALL& Then
CopyFile2% = False
ForceInstall% = False
Msg$ = "Internal error, buffer too small for temporary source "
Msg$ = Msg$ & "file. This error should not happen!"
MBFlags% = MB_OK & MB_ICONEXCLAMATION
MsgBox Msg$, MBFlags%, "SETUP"
Else
CopyFile2% = False
ForceInstall% = False
Msg$ = "Unknow error while copying the file, " & UCase$(D$)
Msg$ = Msg$ & ". This error should not happen!"
MBFlags% = MB_OK & MB_ICONEXCLAMATION
MsgBox Msg$, MBFlags%, "SETUP"
End If

End Sub

' --------------------------------------------------------
' Copies file ScrFilename for SourcePath to DestinationPath
'
' Returns 0 if could not find the file, or if any other
' runtime error occurs
'
' If the source file is older, and the FUpdate% parameter
' is TRUE, then the function returns success (-1) even
' though no file was copied, since no error occurred.
' --------------------------------------------------------
Function CopyFile2% (ByVal SourcePath$, ByVal destinationpath$, ByVal SrcFileName$, ByVal destfilename$, FUpdate%, Last%, DestSize&)

Dim CurrDir$, TmpFile$, S$, D$
Dim Temp$, Msg$, DFileName$, szBufSrc$, szBufDest$
Dim sFileVer$, sProdVer$, dFileVer$, dProdVer$
Dim lpwTempFileLen%, CopyResult%, x%, ForceInstall%, r%
Dim DidUpdate%, Res%, MBFlags%, Success%, CopyFile%
Dim result&, FileLength&
Static filecount%
Dim TmpOFStruct As OFStruct

DidUpdate% = False
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


' -----------------------------------------------------
' Check for the cancel button
' -----------------------------------------------------
DoEvents: DoEvents
If gCancelCommand% = True Then
Res% = AskAboutCancel%()
If Res% = True Then
gCancelCommand% = 99
Exit Function
End If
End If


' -----------------------------------------------------
' Last check for existence of source file....
' -----------------------------------------------------
If Not FileExists%(SourcePath$ & SrcFileName$) Then
Msg$ = "Error occurred while attempting to copy file. "
Msg$ = Msg$ & "Could not locate file: """ & SourcePath$
Msg$ = Msg$ & SrcFileName$ & """"
MBFlags% = MB_OK & MB_ICONINFORMATION
MsgBox Msg$, MBFlags%, "SETUP"
CopyFile2% = False
GoTo SkipCopy
End If


' -----------------------------------------------------
' Catch any errors
' -----------------------------------------------------
On Error GoTo ErrorCopy


' -----------------------------------------------------
' If Update is set to true, then check to see if date,
' time, and size of the file are identical or later
' Goto end (SkipFile) if everything equal
' -----------------------------------------------------
If FUpdate% = True Then
' --------------------------------------------------
' Only check if destination exists
' --------------------------------------------------
Temp$ = destinationpath$ & destfilename$
If FileExists%(Temp$) Then
CheckForDateTime SourcePath$ & SrcFileName$, destinationpath$ & destfilename$, Res%, sFileVer$, sProdVer$, dFileVer$, dProdVer$
If Res% = False Then
Temp$ = "Update only, file exists:"
StatusDlg.Label1.Caption = Temp$
Temp$ = "Skipping file, " & gCrLf$
Temp$ = Temp$ & UCase$(destinationpath$ & destfilename$)
StatusDlg.Label2.Caption = Temp$
DoEvents
StatusDlg.Label1.Refresh
StatusDlg.Label2.Refresh
StatusDlg.Gauge.Refresh
DoEvents
CopyFile2% = True
GoTo SkipCopy
End If
End If
End If


DoExistAgain:

' -----------------------------------------------------
' Check to see if destination file exists, and give
' alternatives
' -----------------------------------------------------
Temp$ = destinationpath$ & destfilename$
If FileExists%(Temp$) Then

ReturnVerInfo destinationpath$ & destfilename$, dFileVer$, dProdVer$
ReturnVerInfo SourcePath$ & SrcFileName$, sFileVer$, sProdVer$

gRenPath$ = UCase$(destinationpath$)
gRenFile$ = UCase$(destfilename$)
gTmpSource$ = SourcePath$ & SrcFileName$
gTmpSize& = DestSize&
Load File_Exists

If sFileVer$ <> "0" And dFileVer$ <> "0" Then
File_Exists.LblSourceVer.Caption = "File Version: " & sFileVer$
File_Exists.LblDestVer.Caption = "File Version: " & dFileVer$
Else
File_Exists.LblSourceVer.Caption = "No File Version Information...."
File_Exists.LblDestVer.Caption = "No File Version Information...."
End If

File_Exists.LblSourceVer.Visible = True
File_Exists.LblDestVer.Visible = True
CenterForm File_Exists
File_Exists.Show MODAL

FadeForm Setup1


' -----------------------------------------------------
' Update status dialog info
' -----------------------------------------------------
Temp$ = "Source file: " & gCrLf$
Temp$ = Temp$ & UCase$(SourcePath$ & SrcFileName$)
StatusDlg.Label1.Caption = Temp$
Temp$ = "Destination file: " & gCrLf$
Temp$ = Temp$ & UCase$(destinationpath$ & destfilename$)
StatusDlg.Label2.Caption = Temp$
DoEvents
StatusDlg.Label1.Refresh
StatusDlg.Label2.Refresh
StatusDlg.Gauge.Refresh
DoEvents


' --------------------------------------------------
' User hit the Cancel button, abort the program
' --------------------------------------------------
If gCancelCommand% = True Then
gCancelCommand% = 99
Exit Function
End If


' --------------------------------------------------
' User wants to skip the file
' --------------------------------------------------
If gSkip% = True Then
CopyFile2% = True
GoTo SkipCopy
End If


' --------------------------------------------------
' User said to copy over the file if gTmpCopyOver%
' is TRUE
' --------------------------------------------------
If gtmpcopyover% = True Then
' User wants to copy over the current file --
' so ignore
Else
' --------------------------------------------------
' Otherwise, rename the file as requested
' --------------------------------------------------
If FileExists%(gRenPath$ & gRenFile$) Then
Msg$ = "The file name you gave for renaming the file, "
Msg$ = Msg$ & gRenFile$ & ", already exists on the "
Msg$ = Msg$ & gRenPath$ & " directory."
MBFlags% = MB_OK & MB_ICONINFORMATION
MsgBox Msg$, MBFlags%, "SETUP"
GoTo DoExistAgain
End If

DFileName$ = gRenFile$
RenameTheFile destfilename$, DFileName$, destinationpath$, Success%
FadeForm Setup1


' --------------------------------------------------
' Abort the program if the rename is not successful
' --------------------------------------------------
If Success% = False Then
Msg$ = "Could not rename the file, " & UCase$(Temp$) & ". "
Msg$ = Msg$ & "Aborting the installation...."
MBFlags% = MB_OK & MB_ICONSTOP
MsgBox Msg$, MBFlags%, "COULD NOT RENAME FILE"
gCancelCommand% = 99
Exit Function
End If
End If

' -----------------------------------------------------
' Destination file doesn't exist
' -----------------------------------------------------
Else

' -----------------------------------------------------
' Update status dialog info
' -----------------------------------------------------
Temp$ = "Source file: " & gCrLf$
Temp$ = Temp$ & UCase$(SourcePath$ & SrcFileName$)
StatusDlg.Label1.Caption = Temp$
Temp$ = "Destination file: " & gCrLf$
Temp$ = Temp$ & UCase$(destinationpath$ & destfilename$)
StatusDlg.Label2.Caption = Temp$
DoEvents
StatusDlg.Label1.Refresh
StatusDlg.Label2.Refresh
StatusDlg.Gauge.Refresh
DoEvents

End If


' -----------------------------------------------------
' VerInstallFile installs the file. We need to
' initialize some arguments for the temp file that is
' created by the call
' -----------------------------------------------------
CurrDir$ = String$(255, 0)
TmpFile$ = String$(255, 0)
lpwTempFileLen% = 255
DoEvents
StatusDlg.Label1.Refresh
StatusDlg.Label2.Refresh
StatusDlg.Gauge.Refresh
DoEvents
result& = VerInstallFile&(0, SrcFileName$, destfilename$, SourcePath$, destinationpath$, CurrDir$, TmpFile$, lpwTempFileLen%)
If DidUpdate% = False Then
FUpdateStatus DestSize&, Last%
DidUpdate% = True
End If


' -----------------------------------------------------
' Delete any temporary files that results from operation
' -----------------------------------------------------
If (result& And VIF_TEMPFILE&) = VIF_TEMPFILE& Then
CopyResult% = OpenFile(TmpFile$, TmpOFStruct, OF_DELETE%)
End If


' -----------------------------------------------------
' There are many return values that you can test for.
' The constants are listed above.
' The following lines of code return will set the Function to
' True if the VerInstallFile call was successful.
'
' If the call was unsuccessful due to a different language on the
' users machine, VerInstallFile is called again to force installation.
' You can change this to not install if you choose.
' Be careful about using FORCEINSTALL. Other flags could be
' set which indicate that this file should not be overridden.
'
' Under any other circumstance, the tempfile created by VerInstallFile
' is removed using OpenFile and the CopyFile2% function returns false.
' -----------------------------------------------------
S$ = SourcePath$ & SrcFileName$
D$ = destinationpath$ & destfilename$
If result& = 0 Then
CopyFile2% = True
x% = SetFileDateTime%(S$, D$)
ForceInstall% = False

' save the number of files copied
If gtmpcopyover% = False Then
' save full file name with path
' if it is the uninstall file, DON'T WRITE DATA!!!!!!!


If InStr(1, destfilename$, "uninstal.exe", 1) = 0 Then
filecount% = filecount% + 1
r% = writeprivateprofilestring%("FILES", "numfiles", Format$(filecount%), gunname$)
r% = writeprivateprofilestring%("FILES", "file" + Format$(filecount%), destinationpath$ + destfilename$, gunname$)
End If
End If
Else
' --------------------------------------------------
' If CopyFile% is TRUE and ForceInstall% is TRUE,
' then force the installation of the file.
' --------------------------------------------------
CheckTheError result&, S$, D$, CopyFile%, ForceInstall%
CopyFile2% = CopyFile%
End If

If result& <> 0 Then
If ForceInstall% = True And CopyFile% = True Then
result& = VerInstallFile&(VIFF_FORCEINSTALL%, SrcFileName$, destfilename$, SourcePath$, destinationpath$, CurrDir$, TmpFile$, lpwTempFileLen%)

' -----------------------------------------------------
' Delete any temporary files that results from operation
' -----------------------------------------------------
If (result& And VIF_TEMPFILE&) = VIF_TEMPFILE& Then
CopyResult% = OpenFile(TmpFile$, TmpOFStruct, OF_DELETE%)
End If

If CopyFile% = True And result& = 0 Then
x% = SetFileDateTime%(S$, D$)
End If
Else
CopyFile2% = False
GoTo SkipCopy
End If
End If

Screen.MousePointer = 0
On Error GoTo 0


' -----------------------------------------------------
' Check for the cancel button
' -----------------------------------------------------
DoEvents: DoEvents
If gCancelCommand% = True Then
Res% = AskAboutCancel%()
If Res% = True Then
gCancelCommand% = 99
Exit Function
End If
End If


' --------------------------------------------------------
SkipCopy:
If DidUpdate% = False Then
FUpdateStatus DestSize&, Last%
DidUpdate% = True
End If

szBufSrc$ = ""
szBufDest$ = ""
Screen.MousePointer = 0
On Error GoTo 0
Exit Function


' --------------------------------------------------------
ErrorCopy:
Msg$ = Error$(Err)
CopyFile2% = False
If DidUpdate% = False Then
FUpdateStatus DestSize&, Last%
DidUpdate% = True
End If
Msg$ = Msg$ & " : "
Msg$ = Msg$ & "Error copying file " & UCase$(SourcePath$ & SrcFileName$)
Msg$ = Msg$ & " to " & UCase$(destinationpath$ & destfilename$)
MBFlags% = MB_OK & MB_ICONINFORMATION
MsgBox Msg$, MBFlags%, "SETUP"
Resume SkipCopy


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$, MyForm As Form)

Dim BackPos%, ForePos%, MBFlags%, r%
Dim Msg$, Temp$
Static dircount%

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


' -----------------------------------------------------
' Check to see if directory already exists
' -----------------------------------------------------

Err = 0
If Right$(destpath$, 1) = "\" Then
Temp$ = Mid$(destpath$, 1, Len(destpath$) - 1)
Else
Temp$ = destpath$
End If
ChDir Temp$
If Err <> 0 Then GoTo NoDirectory


' -----------------------------------------------------
' Attempt to make each directory, then change to it
' -----------------------------------------------------
Cont9:
ChDir "\"
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:
Msg$ = "Error While Attempting to Create Directories "
Msg$ = Msg$ & "on Destination Drive."
MBFlags% = MB_OK & MB_ICONEXCLAMATION
MsgBox Msg$, MBFlags%, "SETUP"
CreatePath% = False
Screen.MousePointer = 0


' --------------------------------------------------------
NoDirectory:

If MyForm.Tag <> "This is the main form" Then
MyForm.Visible = False
End If

Load CreateDir
CenterForm CreateDir
Temp$ = "The directory, " & UCase$(AllTrim$(destpath$))
Temp$ = Temp$ & ", does not exist. Do you want to create it?"
CreateDir.Label1.Caption = Temp$
CreateDir.Show MODAL
MyForm.Visible = True
If gCancelCommand% = True Then
Exit Function
End If
'*************************************
' write new directory to uninstall ini file
'*************************************
dircount% = dircount% + 1
r% = writeprivateprofilestring%("DIRECTORIES", "Dirnum", Format$(dircount%), gunname$)
r% = writeprivateprofilestring%("DIRECTORIES", "Dir" + Format$(dircount%), Left$(destpath$, Len(destpath$) - 1), gunname$)


GoTo Cont9


End Function

' --------------------------------------------------------
' Procedure: CreateProgManGroup
' Arguments: X The Form where a Text1 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$)

Dim i%, r%


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.Text1.LinkTopic = "ProgMan|Progman"
x.Text1.LinkMode = 2
For i% = 1 To 10 ' Loop to ensure that there is enough time to
DoEvents ' process DDE Execute. This is redundant but needed
Next ' for debug windows.
x.Text1.LinkTimeout = 100


' -----------------------------------------------------
' Create program group
' -----------------------------------------------------
x.Text1.LinkExecute "[CreateGroup(" & GroupName$ & Chr$(44) & grouppath$ & ")]"

r% = writeprivateprofilestring("GROUP", "Path", grouppath$, gunname$)
' -----------------------------------------------------
' Reset properties
' -----------------------------------------------------
x.Text1.LinkTimeout = 50
x.Text1.LinkMode = 0

Screen.MousePointer = 0

End Sub

' --------------------------------------------------------
' Procedure: CreateProgManItem
'
' Arguments:
' X The form where Text1 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
'
' GroupName$ The name of the group to add the
' item to
' --------------------------------------------------------
Sub CreateProgManItem (x As Form, CmdLine$, IconTitle$, GroupName$)

Dim i%, Position%, Pos%, Pos2%, Continue%, FndDup%
Dim PrevPos%, Pos3%
Dim Temp$, Tmp$, Tmp2$, Tmp2a$, Tmp3$
Dim r%
Static iconcount%
Screen.MousePointer = 11


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


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


' -----------------------------------------------------
' Ask for the items in this group (returned in
' Text1.Text) - change to a group you actually have!
' Must use text box since label caption is limited to
' 1024 characters.
' -----------------------------------------------------
Setup1.Text1.LinkItem = GroupName$
Setup1.Text1.LinkRequest


' -----------------------------------------------------
' Reset properties
' -----------------------------------------------------
Setup1.Text1.LinkTimeout = 50
Setup1.Text1.LinkMode = 0


' -----------------------------------------------------
' Find if either the Icon Title or the Command line
' is the same as the one you are about to add.
' -----------------------------------------------------
i% = 1
Temp$ = Setup1.Text1.Text

Temp$ = Trim$(Temp$)
Position% = 1
PrevPos% = 1
Continue% = True

Do
' Get the to isolate the section
Pos% = InStr(PrevPos%, Temp$, Chr$(13))
Tmp$ = Mid$(Temp$, PrevPos%, Pos% - 1 - PrevPos%)
Pos% = Pos% + 1

If Pos% > 1 Then
If i% <> 1 Then
Pos2% = InStr(1, Tmp$, ",")
Tmp2a$ = Mid$(Tmp$, 2, Pos2% - 3)
Tmp2$ = UCase$(Tmp2a$)
Pos3% = InStr(Pos2% + 1, Tmp$, ",")
Tmp3$ = UCase$(Mid$(Tmp$, Pos2% + 2, Pos3% - 3 - Pos2%))

If UCase$(IconTitle$) = Tmp2$ Then
FndDup% = True
Exit Do
End If

If UCase$(CmdLine$) = Tmp3$ Then
FndDup% = True
Exit Do
End If

i% = i% + 1
Else
i% = i% + 1
End If
PrevPos% = Pos% + 1
Else
Continue% = False
End If
Loop While Continue% = True


' -----------------------------------------------------
' If found an identical icon title or command line,
' ask the user what he wants to do
' -----------------------------------------------------
If FndDup% = True Then
Load Duplicate_Icon
Tmp$ = "You are about to add an icon to the group "
Tmp$ = Tmp$ & UCase$(GroupName$) & ". A similar "
Tmp$ = Tmp$ & "already exists in this group. Do "
Tmp$ = Tmp$ & "you want to:"

Duplicate_Icon.LblForm.Caption = Tmp$
Duplicate_Icon.LblIconTitleCurrent.Caption = Tmp2$
Duplicate_Icon.LblIconCmdCurrent.Caption = Tmp3$
Duplicate_Icon.LblIconTitleNew.Caption = UCase$(IconTitle$)
Duplicate_Icon.LblIconCmdNew.Caption = UCase$(CmdLine$)
Screen.MousePointer = 0
CenterForm Duplicate_Icon
Duplicate_Icon.Show MODAL
FadeForm Setup1
Screen.MousePointer = 11

If gDupReturn% = 1 Then
' Continue as is
ElseIf gDupReturn% = 2 Then
' Replace the current icon
ElseIf gDupReturn% = 3 Then
' Abort and select new group
x.Text1.LinkMode = 0
Screen.MousePointer = 0
On Error GoTo 0
Exit Sub
End If
End If


' -----------------------------------------------------
' Set the focus to the selected group -- THIS IS
' CRITICAL!!
' 1 = Normal, with focus
' -----------------------------------------------------
x.Text1.LinkMode = 0
x.Text1.LinkTopic = "ProgMan|Progman"
x.Text1.LinkMode = 2
Setup1.Text1.LinkExecute "[ShowGroup(" & GroupName$ & ",1)]"
For i% = 1 To 5
DoEvents
Next i%


' -----------------------------------------------------
' Delete the item if that is what user selected
' -----------------------------------------------------
If FndDup% = True Then
If gDupReturn% = 2 Then
Setup1.Text1.LinkExecute "[DeleteItem(" & Tmp2a$ & ")]"
End If
For i% = 1 To 5
DoEvents
Next i%
End If


' -----------------------------------------------------
' Set LinkTopic to PROGRAM MANAGER
' -----------------------------------------------------
x.Text1.LinkMode = 0
x.Text1.LinkTopic = "ProgMan|Progman"
x.Text1.LinkMode = 2


' -----------------------------------------------------
' Loop to ensure that there is enough time to
' process DDE Execute. This is redundant but needed
' for debug windows.
' -----------------------------------------------------
For i% = 1 To 10
DoEvents
Next
x.Text1.LinkTimeout = 100


' -----------------------------------------------------
' Create Program Item, one of the icons to launch
' an application from Program Manager
' -----------------------------------------------------
Setup1.Text1.LinkExecute "[ShowGroup(" & GroupName$ & ",1)]"
For i% = 1 To 5
DoEvents
Next i%
x.Text1.LinkExecute "[AddItem(" & CmdLine$ & Chr$(44) & IconTitle$ & Chr$(44) & ",,)]"
iconcount% = iconcount% + 1
r% = writeprivateprofilestring("ICONS", "Iconnum", Format$(iconcount%), gunname$)
r% = writeprivateprofilestring("ICONS", "Num" + Format$(iconcount%), IconTitle$, gunname$)

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

Screen.MousePointer = 0
On Error GoTo 0


End Sub

' --------------------------------------------------------
' Check for the existence of a file by attempting an OPEN.
' --------------------------------------------------------
Function FileExists% (Path$)

Dim x%

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

' --------------------------------------------------------
' Update the status bar using form.control
' Statusdlg.Picture2
' --------------------------------------------------------
Sub FUpdateStatus (pFileLen&, Last%)

Static Position%
Const SRCCOPY = &HCC0020

Dim EstTotal&
Dim Percent$
Dim OldScaleMode%, r%


EstTotal& = Val(StatusDlg.total.Tag)
If EstTotal& = False Then
EstTotal& = 10000000
End If

Position% = Position% + CSng((pFileLen& / EstTotal&) * 100)
If Position% > 100 Then
Position% = 100
End If


' -----------------------------------------------------
' Make sure don't get to 100% before the end
' -----------------------------------------------------

If Last% = False Then
If Position% = 100 Then Position% = 99
End If


Percent$ = Format$(CLng(Position%)) & "%"
StatusDlg.Gauge.Cls
StatusDlg.InvisGauge.Cls
StatusDlg.Gauge.CurrentX = (StatusDlg.Gauge.Width - StatusDlg.Gauge.TextWidth(Percent$)) / 2
StatusDlg.InvisGauge.CurrentX = StatusDlg.Gauge.CurrentX 'Can do because same size
StatusDlg.Gauge.CurrentY = (StatusDlg.Gauge.Height - StatusDlg.Gauge.TextHeight(Percent$)) / 2
StatusDlg.InvisGauge.CurrentY = StatusDlg.Gauge.CurrentY
StatusDlg.Gauge.Print Percent$ 'Prints same string in both Picture
StatusDlg.InvisGauge.Print Percent$ 'Boxes in same relative location
OldScaleMode% = StatusDlg.Gauge.Parent.ScaleMode
StatusDlg.Gauge.Parent.ScaleMode = 3 'Pixels
r% = BitBlt(StatusDlg.Gauge.hDC, 0, 0, StatusDlg.InvisGauge.Width * Position% \ 100, StatusDlg.InvisGauge.Height, StatusDlg.InvisGauge.hDC, 0, 0, SRCCOPY)
StatusDlg.Gauge.Parent.ScaleMode = OldScaleMode% 'Resetting to previous value
StatusDlg.Gauge.Refresh

End Sub

' --------------------------------------------------------
' Get the disk space free for the current drive
' --------------------------------------------------------
Function GetDiskSpaceFree& (Drive$, HadError%)
HadError% = False

On Error GoTo DiskError
ChDrive Drive$
GetDiskSpaceFree& = DiskSpaceFree&()


ExitFree:
On Error GoTo 0
Exit Function

DiskError:
HadError% = True
Resume ExitFree

End Function

' --------------------------------------------------------
' Get the disk Allocation unit for the current drive
' --------------------------------------------------------
Function GetDrivesAllocUnit& (Drive$)
ChDrive Drive$
GetDrivesAllocUnit& = AllocUnit&()
End Function

' --------------------------------------------------------
' Get the size of the file
' --------------------------------------------------------
Function GetFileSize& (Source$, ExitProg%)

Dim x%, MBFlags%
Dim Msg$


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."
MBFlags% = MB_OK & MB_ICONEXCLAMATION
MsgBox Msg$, MBFlags%, "INSTALLATION ERROR"
ExitProg% = True
Resume TheEnd

End Function

' --------------------------------------------------------
' Calls the windows API to get the windows directory
' --------------------------------------------------------
Function GetWindowsDir$ ()

Dim Temp$
Dim x%


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$ ()

Dim Temp$
Dim x%


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$)

Dim Msg$, Tmp$, Temp$, Drive$, LegalChar$
Dim MBFlags%, BackPos%, ForePos%, i%, PeriodPos%
Dim Length%


' -----------------------------------------------------
' Remove left and right spaces

' -----------------------------------------------------
destpath$ = AllTrim$(destpath$)
DefaultDrive$ = AllTrim$(DefaultDrive$)
DefaultDrive$ = Mid$(DefaultDrive$, 1, 2)


' -----------------------------------------------------
' 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:""..."
MBFlags% = MB_OK & MB_ICONINFORMATION
MsgBox Msg$, MBFlags%, "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%, FileToLookFor$)

Dim Ready%, MBFlags%, x%
Dim Temp$, Msg$


' -----------------------------------------------------
' 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
Msg$ = "Please insert disk # " & Format$(wDiskNum%)
MBFlags% = MB_OKCANCEL & MB_ICONEXCLAMATION
x% = MsgBox(Msg$, MBFlags%, "SETUP")
If x% = IDCANCEL Then
' --------------------------------------------
' Use hit cancel, abort the copy
' --------------------------------------------
PromptForNextDisk% = False
GoTo ExitProc
ElseIf x% = IDOK Then
' --------------------------------------------
' 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 RenameTheFile (FileName$, NewFileName$, Path$, Success%)

Success% = True
On Error GoTo RenError

Name Path$ & FileName$ As Path$ & NewFileName$

Exit Sub

RenError:
On Error GoTo 0
Success% = False
Resume Next

End Sub

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

' --------------------------------------------------------
' Procedure: SelectProgManGroup
' Arguments: X The Form where a Text1 exist
' GroupName$ A string that contains the group name
' --------------------------------------------------------
Sub SelectProgManGroup (x As Form, grouppath$)

Dim i%


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 GoTo DError


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


' -----------------------------------------------------
' Set the focus to the selected group
' NOTE: 1 = Normal, with focus
' -----------------------------------------------------
x.Text1.LinkExecute "[ShowGroup(" & grouppath$ & Chr$(44) & "7)]"
x.Text1.LinkExecute "[ShowGroup(" & grouppath$ & Chr$(44) & "1)]"


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

Screen.MousePointer = 0
Exit Sub


' --------------------------------------------------------
DError:
Resume Next

End Sub

' --------------------------------------------------------
' Set the Destination File's date and time to the Source
' file's date and time
' --------------------------------------------------------
Function SetFileDateTime% (SourceFile$, DestinationFile$)

Dim x%

x% = SetTime%(SourceFile$, DestinationFile$)
SetFileDateTime% = -1
End Function