FreeInstall/Uninstaller/Mfrm.frm
VERSION 5.00
Begin VB.Form Mfrm
BorderStyle = 1 'Fest Einfach
Caption = "Uninstall"
ClientHeight = 1170
ClientLeft = 45
ClientTop = 330
ClientWidth = 5190
Icon = "Mfrm.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 1170
ScaleWidth = 5190
StartUpPosition = 3 'Windows‑Standard
Begin VB.FileListBox File1
Enabled = 0 'False
Height = 285
Hidden = ‑1 'True
Left = 0
System = ‑1 'True
TabIndex = 1
Top = 0
Visible = 0 'False
Width = 195
End
Begin VB.Label Label1
Caption = "Please wait, uninstalling..."
Height = 195
Left = 960
TabIndex = 0
Top = 420
Width = 4095
End
Begin VB.Image Image1
Height = 480
Left = 240
Picture = "Mfrm.frx":08CA
Top = 300
Width = 480
End
End
Attribute VB_Name = "Mfrm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'(c)2001, 2008 by Louis. Part of the Installer project.
'
'This code was downloaded from www.louis‑coder.com
'This code's original copyright (c)2001‑2008 by Louis Coder.
'
'Terms of use: you may spread this code in any way you want, as
'long as you retain the original copyright.
'You may add your own copyright, but please leave a reference
'in the code to www.louis‑coder.com.
'This is the condition for you to use this software.
'Thank you!
'
'If you have questions or suggestions, mail louis@louis‑coder.com.
'
'Uninstall
Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
'GetLongString
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
'
'NOTE: the following four structures will contain data that is to be written into the InstallFile.
'
'InfoStruct ‑ information about product to install
Private Type InfoStruct
ClientFile As String
ProductName As String
LaunchName As String 'program file to run (if any)
StartMenuFolder As String 'nothing ("") for no folder to create
End Type
Dim InfoStructVar As InfoStruct
'FilesStruct ‑ saves information about files that will be packet into the Installer Client
Private Type FilesStruct
SourceName As String
TargetName As String
NoUninstallFlag As Boolean
End Type
Dim FilesStructNumber As Integer
Dim FilesStructArray() As FilesStruct
'RegKeyStruct ‑ saves information about reg keys and values to create
Private Type RegKeyStruct
RegMainKey As Long
RegSubKey As String
RegValueName As String
RegValueValue As String
End Type
Dim RegKeyStructNumber As Integer
Dim RegKeyStructArray() As RegKeyStruct
'ShellLinkStruct ‑ saves information about shell links that are to be create
Private Type ShellLinkStruct
LinkFolder As String
LinkName As String
LinkApplication As String
End Type
Dim ShellLinkStructNumber As Integer
Dim ShellLinkStructArray() As ShellLinkStruct
'
'end of data that will be written into the InstallFile
'
Private Type ProgramFilesStruct
WinDir As String
WinSysDir As String
ProgramPath As String
ProgramFile As String
UninstallFile As String
End Type
Dim ProgramFilesStructVar As ProgramFilesStruct
Private Sub Form_Load()
'on error resume next
Call DefineProgramFilesStructVar
Call Uninstall
End
End Sub
Private Sub DefineProgramFilesStructVar()
'on error resume next
'
'NOTE: the Uninstaller needs 'Uninstall.dat' to be located in the
'program directory.
'
ProgramFilesStructVar.WinDir = GFShellRegistration_GetWinDir
ProgramFilesStructVar.WinSysDir = GFShellRegistration_GetWinSysDir
ProgramFilesStructVar.ProgramPath = App.Path
If Not (Right$(ProgramFilesStructVar.ProgramPath, 1) = "\") Then ProgramFilesStructVar.ProgramPath = ProgramFilesStructVar.ProgramPath + "\" 'verify
ProgramFilesStructVar.ProgramFile = ProgramFilesStructVar.ProgramPath + App.EXEName
If Not (UCase$(Right$(ProgramFilesStructVar.ProgramFile, 4)) = ".EXE") Then ProgramFilesStructVar.ProgramFile = ProgramFilesStructVar.ProgramFile + ".EXE" 'verify
ProgramFilesStructVar.UninstallFile = ProgramFilesStructVar.ProgramPath + "Uninstall.dat"
End Sub
Private Sub Uninstall()
'on error resume next
Dim UninstallErrorFlag As Boolean
If Not ((Dir(ProgramFilesStructVar.UninstallFile) = "") Or (Right$(ProgramFilesStructVar.UninstallFile, 1) = "\") Or (ProgramFilesStructVar.UninstallFile = "")) Then 'verify
Mfrm.Enabled = True
Mfrm.Visible = True
Mfrm.Refresh
Call InstallFile_Read(ProgramFilesStructVar.UninstallFile)
If MsgBox("Do you really want to remove '" + InfoStructVar.ProductName + "' from this computer ?", vbYesNo + vbQuestion) = vbYes Then
Call Uninstall_RemoveFileSystemVars(FilesStructNumber, FilesStructArray(), ShellLinkStructNumber, ShellLinkStructArray(), InfoStructVar)
'
'NOTE: all data for installing is now stored in the 'four structures'
'(see top of this form). This data is now used for deleting files, registry entries
'and short cuts.
'
'If any item cannot be removed the program will NOT create an error message,
'except if a file cannot be deleted (user may be able to close a running application).
'
Call Uninstall_Registry(RegKeyStructNumber, RegKeyStructArray())
If Uninstall_Files(FilesStructNumber, FilesStructArray()) = False Then UninstallErrorFlag = True
Call Uninstall_Directories(FilesStructNumber, FilesStructArray())
Call Uninstall_ShellLink(ShellLinkStructNumber, ShellLinkStructArray(), InfoStructVar)
Call Sleep(2000) 'looks more professional...
Mfrm.Visible = False
Mfrm.Enabled = False
Mfrm.Refresh
If UninstallErrorFlag = False Then
MsgBox "Application has been removed successfully.", vbOKOnly + vbInformation, "Uninstall"
Else
MsgBox "Uninstalling finished, not all files have been removed.", vbOKOnly + vbInformation, "Uninstall"
End If
Else
'do nothing (user canceled uninstalling)
End If
Else
MsgBox "Sorry, uninstalling is not possible as 'Uninstall.dat' was not found in the current directory. Try to reinstall the target application and then start uninstall again.", vbOKOnly + vbExclamation, "Uninstall"
End If
End Sub
Private Sub Uninstall_RemoveFileSystemVars(ByVal FilesStructNumber As Integer, ByRef FilesStructArray() As FilesStruct, ByVal ShellLinkStructNumber As Integer, ByRef ShellLinkStructArray() As ShellLinkStruct, ByRef InfoStructVar As InfoStruct)
'on error resume next
Dim StructLoop As Integer
'
'NOTE: besides the 'normal' file system vars (%windir%, %winsysdir%) this sub
'can also replace %userdir%, which is ProgramFilesStructVar.ProgramPath,
'and %userfolder%, which was read out of the UninstallFile.
'
For StructLoop = 1 To FilesStructNumber
'NOTE: not all values that are converted will be used by the Uninstaller.
Call Uninstall_RemoveFileSystemVarsSub(FilesStructArray(StructLoop).SourceName)
Call Uninstall_RemoveFileSystemVarsSub(FilesStructArray(StructLoop).TargetName)
Next StructLoop
For StructLoop = 1 To ShellLinkStructNumber
Call Uninstall_RemoveFileSystemVarsSub(ShellLinkStructArray(StructLoop).LinkFolder)
Call Uninstall_RemoveFileSystemVarsSub(ShellLinkStructArray(StructLoop).LinkApplication)
Next StructLoop
Call Uninstall_RemoveFileSystemVarsSub(InfoStructVar.ClientFile)
Call Uninstall_RemoveFileSystemVarsSub(InfoStructVar.LaunchName)
End Sub
Private Sub Uninstall_RemoveFileSystemVarsSub(ByRef Line As String)
'on error resume next
'
'NOTE: the %userfolder% value can be set by the user when installing the target application.
'The Installer Client wrote the start menu folder selected by the user into the UninstallFile.
'
If LCase$(Left$(Line, 9)) = "%windir%\" Then Line = ProgramFilesStructVar.WinDir + Right$(Line, Len(Line) ‑ 9)
If LCase$(Left$(Line, 12)) = "%winsysdir%\" Then Line = ProgramFilesStructVar.WinSysDir + Right$(Line, Len(Line) ‑ 12)
If LCase$(Left$(Line, 13)) = "%currentdir%\" Then Line = ProgramFilesStructVar.ProgramPath + Right$(Line, Len(Line) ‑ 13)
If LCase$(Left$(Line, 10)) = "%rootdir%\" Then Line = GetRootDir(ProgramFilesStructVar.ProgramPath) + Right$(Line, Len(Line) ‑ 10)
If LCase$(Left$(Line, 10)) = "%userdir%\" Then Line = GetDirectoryName(ProgramFilesStructVar.UninstallFile) + Right$(Line, Len(Line) ‑ 10) 'UninstallFile is always located in the directory the user installed the target application to
'If LCase$(Left$(Line, 13)) = "%userfolder%\" Then Line = InfoStructVar.StartMenuFolder + Right$(Line, Len(Line) ‑ 13) 'start menu folder name has no terminating backslash
If LCase$(Left$(Line, 8)) = "%windir%" Then Line = ProgramFilesStructVar.WinDir + Right$(Line, Len(Line) ‑ 8)
If LCase$(Left$(Line, 11)) = "%winsysdir%" Then Line = ProgramFilesStructVar.WinSysDir + Right$(Line, Len(Line) ‑ 11)
If LCase$(Left$(Line, 12)) = "%currentdir%" Then Line = ProgramFilesStructVar.ProgramPath + Right$(Line, Len(Line) ‑ 12)
If LCase$(Left$(Line, 9)) = "%rootdir%" Then Line = GetRootDir(ProgramFilesStructVar.ProgramPath) + Right$(Line, Len(Line) ‑ 9)
If LCase$(Left$(Line, 9)) = "%userdir%" Then Line = GetDirectoryName(ProgramFilesStructVar.UninstallFile) + Right$(Line, Len(Line) ‑ 9) 'UninstallFile is always located in the directory the user installed the target application to
If LCase$(Left$(Line, 12)) = "%userfolder%" Then Line = InfoStructVar.StartMenuFolder + Right$(Line, Len(Line) ‑ 12)
End Sub
Private Sub Uninstall_Directories(ByVal FilesStructNumber As Integer, ByRef FilesStructArray() As FilesStruct)
On Error Resume Next 'important (if removing a directory failed)
Dim SubDirNumber As Integer 'may be larger than FilesStructNumber
Dim SubDirArray() As String
Dim SubDirLengthArray() As Long
Dim SubDirLengthMax As Long
Dim CheckFlag As Boolean
Dim StructLoop As Integer
Dim WriteLoop As Integer
Dim TestLoop As Integer
Dim DeleteLoop As Integer
Dim Temp As Long
Dim Tempstr$
'
'NOTE: all directories that appear in the target names of FilesStructArray()
'will only be deleted if they aren't empty.
'if a directory that appears in FilesStructArray() is either
'GetDirectoryName(InfoStructVar.LaunchName) or one of its sub directories then
'all files within those dirs are deleted to verify it can be removed.
'
'verify
If FilesStructNumber < 1 Then Exit Sub
'begin
SubDirNumber = FilesStructNumber
ReDim SubDirArray(1 To SubDirNumber) As String
ReDim SubDirLengthArray(1 To SubDirNumber) As Long
For StructLoop = 1 To SubDirNumber
WriteLoop = WriteLoop + 1
If Not ( _
(Left$(FilesStructArray(StructLoop).TargetName, 1) = "%") Or _
(FilesStructArray(StructLoop).NoUninstallFlag = True)) Then 'verify (see annotation below)
SubDirArray(WriteLoop) = GetDirectoryName(FilesStructArray(StructLoop).TargetName)
SubDirLengthArray(WriteLoop) = Len(SubDirArray(WriteLoop))
Else
'drop current directory
SubDirNumber = SubDirNumber ‑ 1
WriteLoop = WriteLoop ‑ 1
If Not (SubDirNumber = 0) Then 'verify
ReDim Preserve SubDirArray(1 To SubDirNumber) As String
ReDim Preserve SubDirLengthArray(1 To SubDirNumber) As Long
End If
End If
Next StructLoop
'NOTE: FilesStruct[Number/Array()] will from now on not be accessed anymore.
'
'NOTE: the code below will fill 'directory gaps'.
'The sub directory names are gained from the name of the install files.
'It may happen that e.g. one group of files is installed in 'C:\App\',
'the second group in 'C:\App\Data\Save\'.
'This sub would not delete 'C:\App\Data\', and thus 'C:\App\' could not be
'deleted, too. When installing GFCreateDirectory() fills the directory gaps,
'when uninstalling the code below must do.
'Note that any file system vars (beginning with '%') must have been removed,
'or this sub will start trying to delete every directory down to the root directory
'(found out in tests).
'Note that every directory is tried to be delete where at least one
'non‑'no uninstall' file is installed (could also be %winsysdir%).
'The algorithm was tested successfully.
'
ReDo2:
For TestLoop = 1 To SubDirNumber
CheckFlag = False 'reset
For StructLoop = 1 To SubDirNumber
If Not (TestLoop = StructLoop) Then
If Len(SubDirArray(TestLoop)) > Len(SubDirArray(StructLoop)) Then
If Left$(SubDirArray(TestLoop), Len(SubDirArray(StructLoop))) = SubDirArray(StructLoop) Then
CheckFlag = True
If GetDirectoryName(Left$(SubDirArray(TestLoop), Len(SubDirArray(TestLoop)) ‑ 1)) = SubDirArray(StructLoop) Then
GoTo Jump:
End If
End If
End If
End If
Next StructLoop
If CheckFlag = False Then GoTo Jump:
If Not (SubDirNumber = 32767) Then 'verify
SubDirNumber = SubDirNumber + 1
Else
Exit For 'some directories may not be deleted
End If
ReDim Preserve SubDirArray(1 To SubDirNumber) As String
ReDim Preserve SubDirLengthArray(1 To SubDirNumber) As Long
SubDirArray(SubDirNumber) = GetDirectoryName(Left$(SubDirArray(TestLoop), Len(SubDirArray(TestLoop)) ‑ 1))
SubDirLengthArray(SubDirNumber) = Len(SubDirArray(SubDirNumber))
GoTo ReDo2:
Jump:
Next TestLoop
'
'NOTE: the code below sorts all sub directories by their length
'(the longest one comes first). The algorithm has been tested successfully.
'
DeleteLoop = 1 'preset
Do
SubDirLengthMax = 0 'reset
For StructLoop = 1 To SubDirNumber
If SubDirLengthArray(StructLoop) > SubDirLengthMax Then
SubDirLengthMax = SubDirLengthArray(StructLoop)
End If
Next StructLoop
If SubDirLengthMax = 0 Then Exit Do
ReDo:
For StructLoop = DeleteLoop To SubDirNumber
If Len(SubDirArray(StructLoop)) = SubDirLengthMax Then '***TEMP***: shouldn't we use SubDirLengthArray() (check when next time revising this code)
If Not (StructLoop = DeleteLoop) Then
Tempstr$ = SubDirArray(DeleteLoop)
SubDirArray(DeleteLoop) = SubDirArray(StructLoop)
SubDirArray(StructLoop) = Tempstr$
Temp = SubDirLengthArray(DeleteLoop)
SubDirLengthArray(DeleteLoop) = SubDirLengthArray(StructLoop)
SubDirLengthArray(StructLoop) = Temp
End If
SubDirLengthArray(DeleteLoop) = 0 'do not use anymore
DeleteLoop = DeleteLoop + 1
GoTo ReDo:
End If
Next StructLoop
Loop Until (DeleteLoop = 32767) 'avoid endless loop
'delete sub keys
For StructLoop = 1 To SubDirNumber
If Not (Dir(SubDirArray(StructLoop), vbDirectory) = "") Then 'verify
If Not (Right(SubDirArray(StructLoop), 1) = "\") Then SubDirArray(StructLoop) = SubDirArray(StructLoop) + "\" 'verify
File1.Path = SubDirArray(StructLoop)
File1.Refresh
If UCase$(SubDirArray(StructLoop)) = UCase$(GetDirectoryName(InfoStructVar.LaunchName)) Then
Select Case UCase$(SubDirArray(StructLoop))
Case ProgramFilesStructVar.WinDir 'don't do this
Case ProgramFilesStructVar.WinSysDir 'I know what I'm talking about
Case Else
For Temp = 1 To File1.ListCount
Kill SubDirArray(StructLoop) + File1.List(Temp ‑ 1)
Next Temp
End Select
End If
If (File1.ListCount = 0) Then 'verify directory is empty (although RmDir of VB v5.0 would fail anyway)
RmDir SubDirArray(StructLoop)
End If
End If
Next StructLoop
End Sub
Private Sub Uninstall_Registry(ByVal RegKeyStructNumber As Integer, ByRef RegKeyStructArray() As RegKeyStruct)
'on error resume next 'removes all registry entries
Dim SubKeyNumber As Integer
Dim SubKeyStructArray() As RegKeyStruct
Dim SubKeyLengthArray() As Long
Dim SubKeyLengthMax As Long
Dim CheckFlag As Boolean
Dim StructLoop As Integer
Dim TestLoop As Integer
Dim DeleteLoop As Integer
Dim TempRegKeyStruct As RegKeyStruct
Dim Temp As Long
'
'NOTE: RegDeleteKey() removes all key values of the key to delete,
'but under WinNT it does not remove sub keys. Thus all registry keys
'that are to be uninstalled are sorted by length to verify the last sub key
'is deleted first.
'
'verify
If RegKeyStructNumber < 1 Then Exit Sub
'begin
SubKeyNumber = RegKeyStructNumber
ReDim SubKeyStructArray(1 To SubKeyNumber) As RegKeyStruct
ReDim SubKeyLengthArray(1 To SubKeyNumber) As Long
For StructLoop = 1 To SubKeyNumber
SubKeyStructArray(StructLoop) = RegKeyStructArray(StructLoop)
SubKeyLengthArray(StructLoop) = Len(SubKeyStructArray(StructLoop).RegSubKey)
Next StructLoop
'
'NOTE: the code below will fill 'registry key gaps'.
'See Uninstall_Directories() for further information.
'Note that under WinNT a registry key cannot be deleted if it has sub keys.
'The algorithm has been tested, this should work!
'
ReDo2:
For TestLoop = 1 To SubKeyNumber
CheckFlag = False 'reset
For StructLoop = 1 To SubKeyNumber
If Not ( _
(TestLoop = StructLoop) Or _
(SubKeyStructArray(TestLoop).RegMainKey <> SubKeyStructArray(StructLoop).RegMainKey)) Then
If Len(SubKeyStructArray(TestLoop).RegSubKey) > Len(SubKeyStructArray(StructLoop).RegSubKey) Then
If Left$(SubKeyStructArray(TestLoop).RegSubKey, Len(SubKeyStructArray(StructLoop).RegSubKey)) = SubKeyStructArray(StructLoop).RegSubKey Then
CheckFlag = True
If GetDirectoryName(Left$(SubKeyStructArray(TestLoop).RegSubKey, Len(SubKeyStructArray(TestLoop).RegSubKey) ‑ 1)) = SubKeyStructArray(StructLoop).RegSubKey Then
GoTo Jump:
End If
End If
End If
End If
Next StructLoop
If CheckFlag = False Then GoTo Jump:
If Not (SubKeyNumber = 32767) Then 'verify
SubKeyNumber = SubKeyNumber + 1
Else
Exit For 'some directories may not be deleted
End If
ReDim Preserve SubKeyStructArray(1 To SubKeyNumber) As RegKeyStruct
ReDim Preserve SubKeyLengthArray(1 To SubKeyNumber) As Long
SubKeyStructArray(SubKeyNumber).RegMainKey = SubKeyStructArray(TestLoop).RegMainKey
SubKeyStructArray(SubKeyNumber).RegSubKey = GetDirectoryName(Left$(SubKeyStructArray(TestLoop).RegSubKey, Len(SubKeyStructArray(TestLoop).RegSubKey) ‑ 1))
SubKeyLengthArray(SubKeyNumber) = Len(SubKeyStructArray(SubKeyNumber).RegSubKey)
GoTo ReDo2:
Jump:
Next TestLoop
'
'NOTE: the code below sorts all sub keys by their length
'(the longest one comes first). The algorithm has been tested successfully.
'
DeleteLoop = 1 'preset
Do
SubKeyLengthMax = 0 'reset
For StructLoop = 1 To SubKeyNumber
If SubKeyLengthArray(StructLoop) > SubKeyLengthMax Then
SubKeyLengthMax = SubKeyLengthArray(StructLoop)
End If
Next StructLoop
If SubKeyLengthMax = 0 Then Exit Do
ReDo:
For StructLoop = DeleteLoop To SubKeyNumber
If Len(SubKeyStructArray(StructLoop).RegSubKey) = SubKeyLengthMax Then
If Not (StructLoop = DeleteLoop) Then
TempRegKeyStruct = SubKeyStructArray(DeleteLoop)
SubKeyStructArray(DeleteLoop) = SubKeyStructArray(StructLoop)
SubKeyStructArray(StructLoop) = TempRegKeyStruct
Temp = SubKeyLengthArray(DeleteLoop)
SubKeyLengthArray(DeleteLoop) = SubKeyLengthArray(StructLoop)
SubKeyLengthArray(StructLoop) = Temp
End If
SubKeyLengthArray(DeleteLoop) = 0 'do not use anymore
DeleteLoop = DeleteLoop + 1
GoTo ReDo:
End If
Next StructLoop
Loop Until (DeleteLoop = 32767) 'avoid endless loop
'delete sub keys
For StructLoop = 1 To SubKeyNumber
If Not (Right$(SubKeyStructArray(StructLoop).RegSubKey, 1) = "\") Then SubKeyStructArray(StructLoop).RegSubKey = SubKeyStructArray(StructLoop).RegSubKey + "\"
Call Rmod.RegDeleteSubKey(SubKeyStructArray(StructLoop).RegMainKey, SubKeyStructArray(StructLoop).RegSubKey)
Next StructLoop
End Sub
Private Function Uninstall_Files(ByVal FilesStructNumber As Integer, ByRef FilesStructArray() As FilesStruct) As Boolean
On Error Resume Next 'important; returns True if all files have been removed, False if not
Dim StructLoop As Integer
'
'NOTE: some files are not to be removed, e.g. ActiveX controls.
'The Uninstaller cannot be removed as an executable cannot delete itself.
'
'preset
Uninstall_Files = True
'begin
For StructLoop = 1 To FilesStructNumber
If FilesStructArray(StructLoop).NoUninstallFlag = False Then
If Not ((Dir(FilesStructArray(StructLoop).TargetName) = "") Or (Right$(FilesStructArray(StructLoop).TargetName, 1) = "\") Or (FilesStructArray(StructLoop).TargetName = "")) Then 'verify
ReDo:
Kill FilesStructArray(StructLoop).TargetName
If Not (Dir(FilesStructArray(StructLoop).TargetName) = "") Then
'NOTE: the file could not be deleted, e.g. as it is currently executed.
Select Case MsgBox("Error deleting file: " + FilesStructArray(StructLoop).TargetName + Chr$(10) + "Press 'Cancel' to skip this file.", vbRetryCancel + vbExclamation, "Uninstall")
Case vbRetry
GoTo ReDo:
Case vbCancel
Uninstall_Files = False 'at least one file has not been removed
End Select
End If
End If
End If
Next StructLoop
End Function
Private Sub Uninstall_ShellLink(ByVal ShellLinkStructNumber As Integer, ByRef ShellLinkStructArray() As ShellLinkStruct, ByRef InfoStructVar As InfoStruct)
On Error Resume Next 'important (if removing start menu folder fails)
Dim ProgramsFolderName As String
Dim LinkFolderName As String
Dim StructLoop As Integer
'delete desktop short cut
Call GFDeleteShellLink("..\..\Desktop", InfoStructVar.ProductName) 'desktop shell link is created by default
'delete start menu short cuts
For StructLoop = 1 To ShellLinkStructNumber
Call GFDeleteShellLink(ShellLinkStructArray(StructLoop).LinkFolder, ShellLinkStructArray(StructLoop).LinkName)
Next StructLoop
'delete start menu folder
If Not (InfoStructVar.StartMenuFolder = "") Then 'verify
ProgramsFolderName = GFGetSpecialFolderLocation(CSIDL_PROGRAMS)
If Not (ProgramsFolderName = "") Then 'verify
If Not (Right$(ProgramsFolderName, 1) = "\") Then ProgramsFolderName = ProgramsFolderName + "\" 'verify
LinkFolderName = ProgramsFolderName + InfoStructVar.StartMenuFolder
If Not (Dir(LinkFolderName, vbDirectory) = "") Then 'verify
RmDir LinkFolderName 'should be empty after removing shell links
End If
End If
End If
End Sub
Private Sub InstallFile_Write(ByVal InstallFile As String, ByRef InfoStructVar As InfoStruct, ByVal FilesStructNumber As Integer, ByRef FilesStructArray() As FilesStruct, ByVal RegKeyStructNumber As Integer, ByRef RegKeyStructArray() As RegKeyStruct)
'on error resume next
Dim Temp As Long
'
'NOTE: the InstallFile contains the data of the most important Install structures.
'The InstallFile has the following format:
'‑11 bytes: "InstallFile"
'‑1 byte: structure type ((1): InfoStruct, (2): FilesStruct, (3): RegKeyStruct)
'(1)
'‑4 bytes: length of client file
'‑client file
'‑4 bytes: length of product name
'‑product name
'‑4 bytes: length of launch name
'‑launch name
'‑4 bytes: length of start menu folder
'‑start menu folder
'(2)
'‑4 bytes: length of source name
'source name
'‑4 bytes: length of target name
'target name
'‑4 bytes: no uninstall flag
'(3)
'‑4 bytes: RegMainKey
'‑4 bytes: length of RegSubKey
'RegSubKey
'‑4 bytes: length of RegValueName
'RegValueName
'‑4 bytes: length of RegValueValue
'RegValueValue
'(4)
'‑4 bytes: length of ShellLinkFolder
'ShellLinkFolder
'‑4 bytes: length of ShellLinkName
'ShellLinkName
'‑4 bytes: length of ShellLinkApplication
'ShellLinkApplication
'
'NOTE: the InstallFile has the file number 1.
'
'preset
If InstallFile = "" Then
MsgBox "internal error in InstallFile_Write(): file '" + InstallFile + " not found !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
'begin
Open InstallFile For Output As #1
Print #1, "InstallFile"
Print #1, Chr$(1); 'InfoStruct
Print #1, GetLongString(Len(InfoStructVar.ClientFile));
Print #1, InfoStructVar.ClientFile;
Print #1, GetLongString(Len(InfoStructVar.ProductName));
Print #1, InfoStructVar.ProductName;
Print #1, GetLongString(Len(InfoStructVar.LaunchName));
Print #1, InfoStructVar.LaunchName;
Print #1, GetLongString(Len(InfoStructVar.StartMenuFolder));
Print #1, InfoStructVar.StartMenuFolder;
For Temp = 1 To FilesStructNumber
Print #1, Chr$(2); 'FilesStruct
Print #1, GetLongString(Len(FilesStructArray(Temp).SourceName));
Print #1, FilesStructArray(Temp).SourceName;
Print #1, GetLongString(Len(FilesStructArray(Temp).TargetName));
Print #1, FilesStructArray(Temp).TargetName;
Print #1, GetLongString(CLng(FilesStructArray(Temp).NoUninstallFlag));
Next Temp
For Temp = 1 To RegKeyStructNumber
Print #1, Chr$(3);
Print #1, GetLongString(RegKeyStructArray(Temp).RegMainKey);
Print #1, GetLongString(Len(RegKeyStructArray(Temp).RegSubKey));
Print #1, RegKeyStructArray(Temp).RegSubKey;
Print #1, GetLongString(Len(RegKeyStructArray(Temp).RegValueName));
Print #1, RegKeyStructArray(Temp).RegValueName;
Print #1, GetLongString(Len(RegKeyStructArray(Temp).RegValueValue));
Print #1, RegKeyStructArray(Temp).RegValueValue;
Next Temp
For Temp = 1 To ShellLinkStructNumber
Print #1, Chr$(4);
Print #1, GetLongString(Len(ShellLinkStructArray(Temp).LinkFolder));
Print #1, ShellLinkStructArray(Temp).LinkFolder;
Print #1, GetLongString(Len(ShellLinkStructArray(Temp).LinkName));
Print #1, ShellLinkStructArray(Temp).LinkName;
Print #1, GetLongString(Len(ShellLinkStructArray(Temp).LinkApplication));
Print #1, ShellLinkStructArray(Temp).LinkApplication;
Next Temp
Close #1
Exit Sub
End Sub
Private Sub InstallFile_Read(ByVal InstallFile As String)
'on error resume next
Dim InstallFileByte As Byte
Dim InstallFileString As String
Dim InstallFileStringLength As Long
'
'NOTE: search the Install Server for the InstallFile format.
'
'verify
If (Dir(InstallFile) = "") Or (Right$(InstallFile, 1) = "\") Or (InstallFile = "") Then 'verify
MsgBox "internal error in InstallFile_Read(): file '" + InstallFile + "' not found !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
'reset
FilesStructNumber = 0 'reset
ReDim FilesStructArray(1 To 1) As FilesStruct 'reset
RegKeyStructNumber = 0 'reset
ReDim RegKeyStructArray(1 To 1) As RegKeyStruct 'reset
ShellLinkStructNumber = 0 'reset
ReDim ShellLinkStructArray(1 To 1) As ShellLinkStruct 'reset
'begin
Open InstallFile For Binary As #1
InstallFileString = String$(11, Chr$(0))
Get #1, 1, InstallFileString
If Not (InstallFileString = "InstallFile") Then
MsgBox "Error: the file '" + InstallFile + "' is no valid InstallFile !", vbOKOnly + vbExclamation
Close #1 'important (make sure file is closed)
Exit Sub 'error
End If
Do While Not (EOF(1))
Get #1, , InstallFileByte
Select Case InstallFileByte
Case 1
GoSub ReadString:
InfoStructVar.ClientFile = InstallFileString
GoSub ReadString:
InfoStructVar.ProductName = InstallFileString
GoSub ReadString:
InfoStructVar.LaunchName = InstallFileString
GoSub ReadString:
InfoStructVar.StartMenuFolder = InstallFileString
Case 2
GoSub ReadString:
FilesStructNumber = FilesStructNumber + 1 'do not verify (save)
ReDim Preserve FilesStructArray(1 To FilesStructNumber) As FilesStruct
FilesStructArray(FilesStructNumber).SourceName = InstallFileString
GoSub ReadString:
FilesStructArray(FilesStructNumber).TargetName = InstallFileString
InstallFileString = String$(4, Chr$(0))
Get #1, , InstallFileString
FilesStructArray(FilesStructNumber).NoUninstallFlag = CBool(GetStringLong(InstallFileString))
Case 3
RegKeyStructNumber = RegKeyStructNumber + 1
ReDim Preserve RegKeyStructArray(1 To RegKeyStructNumber) As RegKeyStruct
InstallFileString = String$(4, Chr$(0))
Get #1, , InstallFileString
RegKeyStructArray(RegKeyStructNumber).RegMainKey = GetStringLong(InstallFileString)
GoSub ReadString:
RegKeyStructArray(RegKeyStructNumber).RegSubKey = InstallFileString
GoSub ReadString:
RegKeyStructArray(RegKeyStructNumber).RegValueName = InstallFileString
GoSub ReadString:
RegKeyStructArray(RegKeyStructNumber).RegValueValue = InstallFileString
Case 4
ShellLinkStructNumber = ShellLinkStructNumber + 1
ReDim Preserve ShellLinkStructArray(1 To ShellLinkStructNumber) As ShellLinkStruct
GoSub ReadString:
ShellLinkStructArray(ShellLinkStructNumber).LinkFolder = InstallFileString
GoSub ReadString:
ShellLinkStructArray(ShellLinkStructNumber).LinkName = InstallFileString
GoSub ReadString:
ShellLinkStructArray(ShellLinkStructNumber).LinkApplication = InstallFileString
End Select
Loop
Close #1
Exit Sub
ReadString:
InstallFileString = String$(4, Chr$(0))
Get #1, , InstallFileString
InstallFileStringLength = GetStringLong(InstallFileString)
InstallFileString = String$(InstallFileStringLength, Chr$(0))
Get #1, , InstallFileString
Return
End Sub
Private Function GetLongString(ByVal LongValue As Long) As String
'on error resume next 'get the 4 bytes of a Long value
GetLongString = String$(4, Chr$(0))
Call CopyMemory(ByVal GetLongString, LongValue, 4)
End Function
Private Function GetStringLong(ByVal StringString As String) As Long
'on error resume next
Call CopyMemory(GetStringLong, ByVal StringString, 4)
End Function
'***********************************GENERAL FUNCTIONS***********************************
Private Function GetRootDir(ByVal GetRootDirPath As String) As String
On Error Resume Next 'returns root dir of passed path, even if located on a network machine
Dim GetRootDirLoop As Integer
'verify
GetRootDirPath = Left$(GetRootDirPath, 32767)
'begin
If Not (Left$(GetRootDirPath, 2) = "\\") Then
GetRootDir = Left$(GetRootDirPath, 3) 'e.g. c:\
Else
GetRootDir = Chr$(0) 'preset (error)
GetRootDirPath = GetRootDirPath + "\" 'add end sign (testing is not required, increase speed)
For GetRootDirLoop = 3 To Len(GetRootDirPath)
If Mid$(GetRootDirPath, GetRootDirLoop, 1) = "\" Then
Select Case GetRootDir
Case Chr$(0)
GetRootDir = ""
Case ""
GetRootDir = Left$(GetRootDirPath, GetRootDirLoop) 'e.g. \\SERVER\C\
Exit For
End Select
End If
Next GetRootDirLoop
If GetRootDir = Chr$(0) Then GetRootDir = "" 'reset (error)
End If
End Function
Private Function GetFileName(ByVal GetFileNameName As String) As String
On Error Resume Next 'returns chars after last backslash or nothing
Dim GetFileNameLoop As Integer
GetFileName = "" 'reset
For GetFileNameLoop = Len(GetFileNameName) To 1 Step (‑1)
If Mid$(GetFileNameName, GetFileNameLoop, 1) = "\" Then
GetFileName = Right$(GetFileNameName, Len(GetFileNameName) ‑ GetFileNameLoop)
Exit For
End If
Next GetFileNameLoop
End Function
Private Function GetDirectoryName(ByVal GetDirectoryNameName As String) As String
On Error Resume Next 'returns chars from string beginning to (including) last backslash or nothing
Dim GetDirectoryNameLoop As Integer
GetDirectoryName = "" 'reset
For GetDirectoryNameLoop = Len(GetDirectoryNameName) To 1 Step (‑1)
If Mid$(GetDirectoryNameName, GetDirectoryNameLoop, 1) = "\" Then
GetDirectoryName = Left$(GetDirectoryNameName, GetDirectoryNameLoop)
Exit For
End If
Next GetDirectoryNameLoop
End Function
Private Sub Form_Unload(Cancel As Integer)
'on error resume next
Cancel = True 'user cannot abort
End Sub
'***END OF MFRM CODE***
[END OF FILE]