FreeInstall/Server/Mfrm.frm
VERSION 5.00
Begin VB.Form Mfrm
BorderStyle = 1 'Fest Einfach
Caption = "FreeInstall Server ‑ (c)2001‑2008 by Louis Coder."
ClientHeight = 6630
ClientLeft = 45
ClientTop = 330
ClientWidth = 10110
Icon = "Mfrm.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 6630
ScaleWidth = 10110
StartUpPosition = 3 'Windows‑Standard
Begin VB.CommandButton FilesReplaceSourceCommand
Caption = "Replace..."
Height = 315
Left = 1740
TabIndex = 9
Top = 3840
Width = 1575
End
Begin VB.Frame GUIFrame4
Caption = "Registry Keys"
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 2175
Left = 120
TabIndex = 28
ToolTipText = "Use the functions of this frame to transfer registry settings from the local machine to the user's machine"
Top = 4320
Width = 9855
Begin VB.CommandButton RegKeyRemoveCommand
Caption = "Remove"
Height = 315
Left = 3720
TabIndex = 15
ToolTipText = "remove selected registry key"
Top = 240
Width = 1935
End
Begin VB.ListBox RegKeyList
Height = 1425
ItemData = "Mfrm.frx":0442
Left = 120
List = "Mfrm.frx":0444
TabIndex = 16
Top = 600
Width = 9615
End
Begin VB.CheckBox RegKeyAddSubKeysCheck
Caption = "scan sub keys"
Height = 195
Left = 2100
TabIndex = 14
ToolTipText = "add all key names and values of a registry key and all its sub keys"
Top = 300
Value = 1 'Aktiviert
Width = 1575
End
Begin VB.CommandButton RegKeyAddCommand
Caption = "Add Reg Key(s)..."
Height = 315
Left = 120
TabIndex = 13
ToolTipText = "add all key names and settings of one registry key"
Top = 240
Width = 1935
End
End
Begin VB.Frame GUIFrame1
Caption = "Main"
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 675
Left = 120
TabIndex = 25
ToolTipText = "Main control"
Top = 60
Width = 9855
Begin VB.CommandButton CreateClientCommand
Caption = "Create Client"
Height = 315
Left = 8340
TabIndex = 24
ToolTipText = "Manipulate the Installer Client File (do not use before all settings are completed)"
Top = 240
Width = 1395
End
Begin VB.CommandButton InstallFileSaveCommand
Caption = "Save..."
Height = 315
Left = 7080
TabIndex = 3
ToolTipText = "Save current configuration to an InstallFile (save settings)"
Top = 240
Width = 1275
End
Begin VB.CommandButton InstallFileLoadCommand
Caption = "Load..."
Height = 315
Left = 5820
TabIndex = 2
ToolTipText = "Load any InstallFile (load settings)"
Top = 240
Width = 1275
End
Begin VB.TextBox InfoClientNameText
Height = 285
Left = 1860
TabIndex = 0
ToolTipText = "File that will contain the target application and that serves as Installer Client"
Top = 240
Width = 2715
End
Begin VB.CommandButton ClientNameBrowseCommand
Caption = "Browse..."
Height = 315
Left = 4680
TabIndex = 1
Top = 240
Width = 1155
End
Begin VB.Label ClientNameLabel
Caption = "Installer Client File:"
BeginProperty Font
Name = "Arial"
Size = 8.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 195
Left = 120
TabIndex = 29
Top = 300
Width = 1755
End
End
Begin VB.Frame GUIFrame3
Caption = "Shell Links"
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 3435
Left = 7320
TabIndex = 27
ToolTipText = "Use the settings of this frame to create short cuts to the installed application (desktop short cut is created by default)"
Top = 840
Width = 2655
Begin VB.CommandButton ShellLinkChangeCommand
Caption = "Change"
Height = 375
Left = 1740
TabIndex = 23
Top = 2040
Width = 795
End
Begin VB.CommandButton ShellLinkRemoveCommand
Caption = "Remove"
Height = 375
Left = 900
TabIndex = 22
Top = 2040
Width = 855
End
Begin VB.CommandButton ShellLinkNewCommand
Caption = "New"
Height = 375
Left = 120
TabIndex = 21
Top = 2040
Width = 795
End
Begin VB.TextBox InfoLaunchNameText
Height = 285
Left = 120
TabIndex = 18
ToolTipText = "executable the Installer Client File can launch automatically (recommended to be set, e.g. '%userdir%\Application.exe')"
Top = 1080
Width = 2415
End
Begin VB.TextBox InfoProductNameText
Height = 285
Left = 120
MaxLength = 35
TabIndex = 17
ToolTipText = "name of product to install (important)"
Top = 480
Width = 2415
End
Begin VB.TextBox InfoStartMenuFolderText
Height = 285
Left = 120
TabIndex = 19
ToolTipText = "start menu folder to create (can be changed by user, name must not include chars like e.g. / or "", example: 'MyApplication')"
Top = 1680
Width = 2415
End
Begin VB.ListBox ShellLinkList
Height = 840
Left = 120
TabIndex = 20
ToolTipText = "use %userfolder% to place the shell link into the folder selected by the user (if any)"
Top = 2400
Width = 2415
End
Begin VB.Label InfoLaunchNameLabel
Alignment = 2 'Zentriert
Caption = "ProgramFile to be run (if any):"
Height = 195
Left = 60
TabIndex = 32
Top = 840
Width = 2535
End
Begin VB.Label InfoProductNameLabel
Alignment = 2 'Zentriert
Caption = "ProductName (max. 35 chars):"
Height = 195
Left = 60
TabIndex = 31
Top = 240
Width = 2535
End
Begin VB.Label InfoStartMenuFolderLabel
Alignment = 2 'Zentriert
Caption = "Start Menu Folder to create (if any):"
Height = 195
Left = 60
TabIndex = 33
Top = 1440
Width = 2535
End
End
Begin VB.Frame GUIFrame2
Caption = "Files"
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 3435
Left = 120
TabIndex = 26
ToolTipText = "Set files that are to be installed"
Top = 840
Width = 7095
Begin VB.ListBox FilesNoUninstallList
Height = 2310
Left = 6360
Style = 1 'Kontrollkästchen
TabIndex = 12
Top = 600
Width = 615
End
Begin VB.CommandButton FilesChangeTargetDirCommand
Caption = "Change..."
Height = 315
Left = 5280
TabIndex = 8
ToolTipText = "change the target dir of a file"
Top = 240
Width = 1035
End
Begin VB.CommandButton FilesSetDefaultTargetDirCommand
Caption = "Default Target Dir..."
Height = 315
Left = 3720
TabIndex = 7
ToolTipText = "set the target dir all added files will be installed to by default"
Top = 240
Width = 1575
End
Begin VB.CommandButton FilesRemoveCommand
Caption = "Remove"
Height = 315
Left = 2700
TabIndex = 6
ToolTipText = "remove selected file"
Top = 240
Width = 1035
End
Begin VB.ListBox FilesSourceNameList
BeginProperty Font
Name = "Arial"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 2310
ItemData = "Mfrm.frx":0446
Left = 120
List = "Mfrm.frx":0448
TabIndex = 10
Top = 600
Width = 3075
End
Begin VB.ListBox FilesTargetDirList
BeginProperty Font
Name = "Arial"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 2310
ItemData = "Mfrm.frx":044A
Left = 3240
List = "Mfrm.frx":044C
TabIndex = 11
Top = 600
Width = 3075
End
Begin VB.CommandButton FilesAddDirCommand
Caption = "Add Directory..."
Height = 315
Left = 1140
TabIndex = 5
ToolTipText = "add all files in a specified directory"
Top = 240
Width = 1575
End
Begin VB.CommandButton FilesAddFileCommand
Caption = "Add File..."
Height = 315
Left = 120
TabIndex = 4
ToolTipText = "add one single file"
Top = 240
Width = 1035
End
Begin VB.Label FilesNoUninstallLabel
Caption = "no uninst."
Height = 435
Left = 6360
TabIndex = 30
ToolTipText = "avoid that e.g. an ActiveX control is uninstalled"
Top = 180
Width = 615
End
End
Begin VB.PictureBox GFListHScrollFontSizePicture
Enabled = 0 'False
Height = 315
Left = 9660
ScaleHeight = 17
ScaleMode = 3 'Pixel
ScaleWidth = 9
TabIndex = 34
Top = 6360
Visible = 0 'False
Width = 195
End
Begin VB.FileListBox AddDirFile
Enabled = 0 'False
Height = 285
Left = 9900
TabIndex = 35
Top = 6360
Visible = 0 'False
Width = 225
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. Use to configure an Installer Client File.
'
'NOTE: the Installer has the following functions:
'‑unpack files to special directories (SPack (originally NN99 packet system code) code used)
'‑create registry entries (new code)
'‑create Win95/98/NT start menu/desktop entries
'
'For every of these three functions the Installer Server has special var types
'(structures) that store the information to make the functions work.
'
'IMPORTANT: the Installer Server executable must be started in the Installer
'Server directory, or files necessary for the installation are not found!
'
'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.
'
'CreateClientCommand_Click
Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long
'GFCDGetFileName
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
'GFCDSetFileName
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
'GFSelectDirectory
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
'GFListHScroll
Private Declare Function SendMessageLong Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'GetLongString
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
'GFCDGetFileName
Const OFN_HIDEREADONLY = &H4
'Dim NULLARRAYSTRING(0 To 0) As String 'disable if already existing in target project
'GFSelectDirectory
Const MAX_PATH = 260
Const ERROR_SUCCESS As Long = 0
Const CSIDL_DESKTOP As Long = &H0
Const BIF_RETURNONLYFSDIRS As Long = &H1
Const BIF_STATUSTEXT As Long = &H4
Const BIF_RETURNFSANCESTORS As Long = &H8
'GFListHScroll
Const LB_SETHORIZONTALEXTENT = &H194
'SPACKTypeConstants
Const SPACK_TYPE_FILEPACK As Integer = 1
Const SPACK_TYPE_STARTINGPACK As Integer = 2
Const SPACK_TYPE_CLOSINGPACK As Integer = 3
Const SPACK_TYPE_ERASINGPACK As Integer = 4
Const SPACK_TYPE_PACKINTERRUPTION As Integer = 5
'GFCDGetFileName; GFCDSetFileName
Private Type OPENFILENAME
lStructSize As Long
hWndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
'GFSelectDirectory
Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
'Version
Const Version As String = "v1.0"
'
'NOTE: the following four structures will contain data that is to be written into the ProgramFilesStructVar.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 ProgramFilesStructVar.InstallFile
'
'HVARStruct ‑ contains data that must be available at Client start up
Private Type HVARStruct
ProductName As String
ProductFileSizeTotal As Long
ProductFileSizeUserDir As String 'not in use
ProductFileSizeWinDir As String 'not in use
ProductFileSizeOther As String 'not in use
End Type
Dim HVARStructVar As HVARStruct
'SystemStruct ‑ general information
Private Type SystemStruct
DefaultTargetDir As String
DefaultRegKey As String 'registry key last entered
End Type
Dim SystemStructVar As SystemStruct
'ProgramFilesStruct
Private Type ProgramFilesStruct
ProgramPath As String
ProgramFile As String
InstallFile As String
UninstallFile As String 'path to Uninstaller executable on local machine
VB5STKIT_DLL As String
CMPRZLIB_DLL As String
AddFileOld As String 'last file added by the user
End Type
Dim ProgramFilesStructVar As ProgramFilesStruct
'other
Dim NULLARRAYSTRING(0 To 0) As String
'***HVAR VARIABLES***
'[De/En]cryptWord
Dim EncryptionKeyWordNumber As Integer
Dim EncryptionKeyWord(1 To 8) As String
Dim EncryptionKeyWordPos(1 To 8) As Integer
'FormatRemoteMsgLine
Dim RemoteMsgLineProEncryptionExistingFlag As Boolean
Dim RemoteMsgNumber As Integer
Dim RemoteMsgDescription As String
Dim RemoteMsgwParam As String
Dim RemoteMsglParam As String
'HVAR_SetValue_GetHVARStringPos
Private Type ProgramTwoLongVar
LongVar1 As Long
LongVar2 As Long
End Type
'global temp vars (old styled)
Dim FormatLoop As Long 'see FormatRemoteMsgLine()
'***END OF HVAR VARIABLES***
Private Sub Form_Load()
'on error resume next
Call DefineCryptionSystem
Call DefineProgramFilesStructVar
Call DefineSystemStructVar
Call DefineSPackS
End Sub
Private Sub DefineCryptionSystem() 'for HVAR Server code
'on error resume next
EncryptionKeyWordNumber = 1 'NN99 LogFile encryption system (see DefineLogFileSystem)
'NN99 GENERATION 2 KEYWORDS
EncryptionKeyWord(1) = "5537D6560535E4D7032527B2B37786C454448395E3B676E2D6F2E34675567353747457641654A6456222277564021353322695A5C227E712D4D4E4E644476257874394E72412127507A2240734B626A732134645441776855396B783E45462D3056252359416F3856765E7A78285C403C695A3C4E742F284C4F67432B64554C7"
End Sub
Private Sub DefineProgramFilesStructVar()
'on error resume next
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.InstallFile = ProgramFilesStructVar.ProgramPath + "Install.dat"
ProgramFilesStructVar.UninstallFile = GetDirectoryName(Left$(ProgramFilesStructVar.ProgramPath, Len(ProgramFilesStructVar.ProgramPath) ‑ 1)) + "Uninstaller\" + "Uninstall.exe"
ProgramFilesStructVar.VB5STKIT_DLL = ProgramFilesStructVar.ProgramPath + "VB5STKIT.DLL"
ProgramFilesStructVar.CMPRZLIB_DLL = ProgramFilesStructVar.ProgramPath + "CMPRZLIB.DLL"
End Sub
Private Sub DefineSystemStructVar()
'on error resume next
SystemStructVar.DefaultTargetDir = "%userdir%" 'directory the user will choose in the Installer Client
End Sub
Private Sub DefineSPackS()
'on error resume next
Load SPACKSfrm 'important (defines encryption key words)
End Sub
'**************************************INSTALLFILE**************************************
'NOTE: the InstallFile saves the data of the most important structures and thus can
'serve to either transfer data from the Installer Server to the Client or to save
'Server settings for reloading.
Private Sub CreateClientCommand_Click()
'on error resume next
Dim ClientFileName As String
'preset
'
ClientFileName = InfoClientNameText.Text
If CreateClient_VerifyClientFile(ClientFileName) = False Then GoTo Error:
'
'begin
'
Mfrm.MousePointer = vbHourglass
Mfrm.Enabled = False
'
'update InfoStruct
'
Call InfoStruct_Update(InfoStructVar)
'
'create InstallFile
'
Call InstallFile_Write(ProgramFilesStructVar.InstallFile, InfoStructVar, FilesStructNumber, FilesStructArray(), RegKeyStructNumber, RegKeyStructArray())
If CreateClient_AddProgramFiles(ProgramFilesStructVar) = False Then GoTo Error:
'
'update HVAR Strings
'
'NOTE: change the HVAR strings before data is added to the client file, but after
'the additional system files (VB5STKIT.DLL and UninstallFile) have been added.
'
Call HVARStruct_Update(HVARStructVar)
If CreateClient_HVAR(ClientFileName, HVARStructVar) = False Then GoTo Error:
'
Call FilesStruct_Update(FilesStructNumber, FilesStructArray())
If CreateClient_PackFiles(ClientFileName, FilesStructNumber, FilesStructArray()) = False Then GoTo Error:
'
'finished, clean up
'
Mfrm.MousePointer = vbDefault
Mfrm.Enabled = True
MsgBox "The Installer Client File has been created successfully.", vbOKOnly + vbInformation
If Not ((Dir(ProgramFilesStructVar.InstallFile) = "") Or (Right$(ProgramFilesStructVar.InstallFile, 1) = "\") Or (ProgramFilesStructVar.InstallFile = "")) Then Kill ProgramFilesStructVar.InstallFile 'make sure file is deleted
If MsgBox("Do you want to test the Installer now (strongly recommended) ?", vbYesNo + vbQuestion) = vbYes Then
Mfrm.WindowState = vbMinimized
Mfrm.Refresh
Shell ClientFileName, vbNormalFocus
End If
Exit Sub
Error:
Mfrm.MousePointer = vbDefault
Mfrm.Enabled = True
MsgBox "Installer Client File creation aborted !", vbOKOnly + vbCritical
If Not ((Dir(ProgramFilesStructVar.InstallFile) = "") Or (Right$(ProgramFilesStructVar.InstallFile, 1) = "\") Or (ProgramFilesStructVar.InstallFile = "")) Then Kill ProgramFilesStructVar.InstallFile 'make sure file is deleted
Exit Sub
End Sub
Private Function CreateClient_VerifyClientFile(ByRef ClientFileName As String) As Boolean
'on error resume next 'returns True if ClientFileName is valid, False if not
If Not ((Dir(ClientFileName) = "") Or (Right$(ClientFileName, 1) = "\") Or (ClientFileName = "")) Then 'verify
CreateClient_VerifyClientFile = True 'ok
Exit Function
Else
MsgBox "Error: Installer Client File not found !", vbOKOnly + vbExclamation
CreateClient_VerifyClientFile = False 'error
Exit Function
End If
End Function
Private Function CreateClient_AddProgramFiles(ByRef ProgramFilesStructVar As ProgramFilesStruct) As Boolean
'on error resume next 'returns True for success or False for error
'
'NOTE: the program files are added AFTER the InstallFile was written,
'thus the client will not decompress them
'(only the files written to InstallFile will be decompressed).
'Thus the program files must not be compressed.
'
If Not ((Dir(ProgramFilesStructVar.InstallFile) = "") Or (Right(ProgramFilesStructVar.InstallFile, 1) = "\") Or (ProgramFilesStructVar.InstallFile = "")) Then 'verify
Call Files_AddFile(ProgramFilesStructVar.InstallFile, "%currentdir%", False)
Else
MsgBox "Error: the InstallFile '" + ProgramFilesStructVar.InstallFile + "' could not be created, check what's wrong !", vbOKOnly + vbExclamation
GoTo Error:
End If
If Not ((Dir(ProgramFilesStructVar.UninstallFile) = "") Or (Right$(ProgramFilesStructVar.UninstallFile, 1) = "\") Or (ProgramFilesStructVar.UninstallFile = "")) Then 'verify
Call Files_AddFile(ProgramFilesStructVar.UninstallFile, "%userdir%", True) 'no remove
Else
MsgBox "Error: file '" + ProgramFilesStructVar.UninstallFile + "' not found !", vbOKOnly + vbExclamation
GoTo Error:
End If
If Not ((Dir(ProgramFilesStructVar.VB5STKIT_DLL) = "") Or (Right$(ProgramFilesStructVar.VB5STKIT_DLL, 1) = "\") Or (ProgramFilesStructVar.VB5STKIT_DLL = "")) Then 'verify
Call Files_AddFile(ProgramFilesStructVar.VB5STKIT_DLL, "%winsysdir%", True) 'no remove
Else
MsgBox "Error: file '" + ProgramFilesStructVar.VB5STKIT_DLL + "' not found !", vbOKOnly + vbExclamation
GoTo Error:
End If
If Not ((Dir(ProgramFilesStructVar.CMPRZLIB_DLL) = "") Or (Right$(ProgramFilesStructVar.CMPRZLIB_DLL, 1) = "\") Or (ProgramFilesStructVar.CMPRZLIB_DLL = "")) Then 'verify
Call Files_AddFile(ProgramFilesStructVar.CMPRZLIB_DLL, "%winsysdir%", True) 'no remove
Else
MsgBox "Error: file '" + ProgramFilesStructVar.CMPRZLIB_DLL + "' not found !", vbOKOnly + vbExclamation
GoTo Error:
End If
CreateClient_AddProgramFiles = True 'ok
Exit Function
Error:
CreateClient_AddProgramFiles = False 'error
Exit Function
End Function
Private Function CreateClient_HVAR(ByVal ClientFileName As String, ByRef HVARStructVar As HVARStruct) As Boolean
'on error resume next 'returns True for success or False for error
Dim HVARErrorFlag As Boolean
'begin
If HVAR_SetValue(ClientFileName, "ProductName", HVARStructVar.ProductName, True) = False Then HVARErrorFlag = True
If HVAR_SetValue(ClientFileName, "ProductFileSizeTotal", LTrim$(Str$(HVARStructVar.ProductFileSizeTotal)), True) = False Then HVARErrorFlag = True
If HVARErrorFlag = True Then
MsgBox "Error manipulating HVAR String !", vbOKOnly + vbExclamation
CreateClient_HVAR = False 'error
Exit Function
Else
CreateClient_HVAR = True 'ok
Exit Function
End If
End Function
Private Function CreateClient_PackFiles(ByVal ClientFileName As String, ByVal FilesStructNumber As Integer, ByRef FilesStructArray() As FilesStruct) As Boolean
'on error resume next 'returns True if all 'normal' (non‑program‑) files were added to the ClientFile, False if not
Dim TempFile As String 'used to retain uncompressed file
Dim lParam As String 'passed to sPack code
Dim FileLoop As Integer
'preset
TempFile = GenerateTempFileName(ProgramFilesStructVar.ProgramPath)
'begin
For FileLoop = 1 To FilesStructNumber
If Not ((FilesStructArray(FileLoop).SourceName = "") Or (FilesStructArray(FileLoop).TargetName = "")) Then 'verify
'
'NOTE: although the output name is saved in form of a complete path
'the SPack Client code supports an output directory name only ( :‑( ).
'
If Not (CopyFile(FilesStructArray(FileLoop).SourceName, TempFile, False) = 0) Then 'verify
'
'NOTE: only the ZLib dll stays uncompressed.
'Note that the client will first unpack all files and then will begin
'decompressing (then the ZLib dll is already existing in %windir%).
'
Select Case UCase$(FilesStructArray(FileLoop).SourceName) 'use UCase$
Case _
UCase$(ProgramFilesStructVar.InstallFile), _
UCase$(ProgramFilesStructVar.UninstallFile), _
UCase$(ProgramFilesStructVar.VB5STKIT_DLL), _
UCase$(ProgramFilesStructVar.CMPRZLIB_DLL) 'use UCase$
'do not compress these files as necessary for decompression or not mentioned in InstallFile
lParam = FilesStructArray(FileLoop).SourceName + "/" + GetDirectoryName(FilesStructArray(FileLoop).TargetName) 'see NN99 System notes
Call SPACKSfrm.SPACKType_Apply(SPACK_TYPE_FILEPACK, ClientFileName, lParam)
Case Else
Call GFCompression_CompressFile(FilesStructArray(FileLoop).SourceName, "zlib", False, "")
'NOTE: lParam must include the original file name, thus the original source file must temporarily be compressed.
lParam = FilesStructArray(FileLoop).SourceName + "/" + GetDirectoryName(FilesStructArray(FileLoop).TargetName) 'see NN99 System notes
Call SPACKSfrm.SPACKType_Apply(SPACK_TYPE_FILEPACK, ClientFileName, lParam)
Call FileCopy(TempFile, FilesStructArray(FileLoop).SourceName)
Call GFCompression_DeleteTempFile(TempFile)
End Select
Else
MsgBox "Copying " + FilesStructArray(FileLoop).SourceName + " into " + TempFile + " failed !", vbOKOnly + vbCritical
GoTo Error:
End If
Else
MsgBox "Error adding file #" + LTrim$(Str$(FileLoop)) + " !", vbOKOnly + vbExclamation
GoTo Error:
End If
Next FileLoop
CreateClient_PackFiles = True 'ok
Exit Function
Error:
If Not ((Dir(TempFile) = "") Or (Right$(TempFile, 1) = "\") Or (TempFile = "")) Then Kill TempFile 'make sure file is deleted
CreateClient_PackFiles = False 'error
Exit Function
End Function
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 InstallFileNumber As Integer
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
InstallFileNumber = FreeFile(0)
Open InstallFile For Output As #InstallFileNumber
Print #InstallFileNumber, "InstallFile"
Print #InstallFileNumber, Chr$(1); 'InfoStruct
Print #InstallFileNumber, GetLongString(Len(InfoStructVar.ClientFile));
Print #InstallFileNumber, InfoStructVar.ClientFile;
Print #InstallFileNumber, GetLongString(Len(InfoStructVar.ProductName));
Print #InstallFileNumber, InfoStructVar.ProductName;
Print #InstallFileNumber, GetLongString(Len(InfoStructVar.LaunchName));
Print #InstallFileNumber, InfoStructVar.LaunchName;
Print #InstallFileNumber, GetLongString(Len(InfoStructVar.StartMenuFolder));
Print #InstallFileNumber, InfoStructVar.StartMenuFolder;
For Temp = 1 To FilesStructNumber
Print #InstallFileNumber, Chr$(2); 'FilesStruct
Print #InstallFileNumber, GetLongString(Len(FilesStructArray(Temp).SourceName));
Print #InstallFileNumber, FilesStructArray(Temp).SourceName;
Print #InstallFileNumber, GetLongString(Len(FilesStructArray(Temp).TargetName));
Print #InstallFileNumber, FilesStructArray(Temp).TargetName;
Print #InstallFileNumber, GetLongString(CLng(FilesStructArray(Temp).NoUninstallFlag));
Next Temp
For Temp = 1 To RegKeyStructNumber
Print #InstallFileNumber, Chr$(3);
Print #InstallFileNumber, GetLongString(RegKeyStructArray(Temp).RegMainKey);
Print #InstallFileNumber, GetLongString(Len(RegKeyStructArray(Temp).RegSubKey));
Print #InstallFileNumber, RegKeyStructArray(Temp).RegSubKey;
Print #InstallFileNumber, GetLongString(Len(RegKeyStructArray(Temp).RegValueName));
Print #InstallFileNumber, RegKeyStructArray(Temp).RegValueName;
Print #InstallFileNumber, GetLongString(Len(RegKeyStructArray(Temp).RegValueValue));
Print #InstallFileNumber, RegKeyStructArray(Temp).RegValueValue;
Next Temp
For Temp = 1 To ShellLinkStructNumber
Print #InstallFileNumber, Chr$(4);
Print #InstallFileNumber, GetLongString(Len(ShellLinkStructArray(Temp).LinkFolder));
Print #InstallFileNumber, ShellLinkStructArray(Temp).LinkFolder;
Print #InstallFileNumber, GetLongString(Len(ShellLinkStructArray(Temp).LinkName));
Print #InstallFileNumber, ShellLinkStructArray(Temp).LinkName;
Print #InstallFileNumber, GetLongString(Len(ShellLinkStructArray(Temp).LinkApplication));
Print #InstallFileNumber, ShellLinkStructArray(Temp).LinkApplication;
Next Temp
Close #InstallFileNumber
Exit Sub
End Sub
Private Sub InstallFile_Read(ByVal InstallFile As String)
'on error resume next
Dim InstallFileNumber As Integer
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
InstallFileNumber = FreeFile(0)
Open InstallFile For Binary As #InstallFileNumber
InstallFileString = String$(11, Chr$(0))
Get #InstallFileNumber, 1, InstallFileString
If Not (InstallFileString = "InstallFile") Then
MsgBox "Error: the file '" + InstallFile + "' is no valid InstallFile !", vbOKOnly + vbExclamation
Close #InstallFileNumber 'important (make sure file is closed)
Exit Sub 'error
End If
Do While Not (EOF(InstallFileNumber))
Get #InstallFileNumber, , 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 #InstallFileNumber, , 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 #InstallFileNumber, , 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 #InstallFileNumber
Exit Sub
ReadString:
InstallFileString = String$(4, Chr$(0))
Get #InstallFileNumber, , InstallFileString
InstallFileStringLength = GetStringLong(InstallFileString)
InstallFileString = String$(InstallFileStringLength, Chr$(0))
Get #InstallFileNumber, , 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
'**********************************END OF INSTALLFILE***********************************
'*****************************************MAIN******************************************
'NOTE: the following subs/functions are of general use.
Private Sub ClientNameBrowseCommand_Click()
'on error resume next 'make user select the Client File
Dim ProgramPath As String
Dim ClientName As String
'preset
ProgramPath = App.Path
If Not (Right$(ProgramPath, 1) = "\") Then ProgramPath = ProgramPath + "\"
'begin
ClientName = GFCDGetFileName("Select Installer Client File", 0, NULLARRAYSTRING(), NULLARRAYSTRING(), 0, ProgramPath)
If Not ((Dir(ClientName) = "") Or (Right$(ClientName, 1) = "\") Or (ClientName = "")) Then 'verify
InfoClientNameText.Text = ClientName
End If
End Sub
Private Sub InstallFileSaveCommand_Click()
'on error resume next 'saves current data to an ProgramFilesStructVar.InstallFile
Call InstallFileSaveSub
End Sub
Private Function InstallFileSaveSub() As Boolean
'on error resume next 'returns True if the user saved the current settings, False if not
Dim ProgramPath As String
Dim FilterDescriptionArray(1 To 1) As String
Dim FilterStringArray(1 To 1) As String
Dim InstallFile As String
'preset
FilterDescriptionArray(1) = "Install Files"
FilterStringArray(1) = "*.dat"
ProgramPath = App.Path
If Not (Right$(ProgramPath, 1) = "\") Then ProgramPath = ProgramPath + "\"
'begin
ReDo:
InstallFile = GFCDSetFileName("Save as...", 1, FilterDescriptionArray(), FilterStringArray(), 0, ProgramPath)
If Not ((InstallFile = "") Or (Right$(InstallFile, 1) = "\")) Then 'verify
If Not (Dir(InstallFile) = "") Then
If MsgBox("This file already exists. Overwrite ?", vbYesNo + vbQuestion) = vbNo Then
GoTo ReDo:
End If
End If
Call InfoStruct_Update(InfoStructVar)
Call InstallFile_Write(InstallFile, InfoStructVar, FilesStructNumber, FilesStructArray(), RegKeyStructNumber, RegKeyStructArray())
If Not ((Dir(InstallFile) = "") Or (Right$(InstallFile, 1) = "\") Or (InstallFile = "")) Then 'verify
MsgBox "Configuration has been saved successfully.", vbOKOnly + vbInformation
Else
MsgBox "Error saving configuration, check entered path !", vbOKOnly + vbExclamation
End If
InstallFileSaveSub = True
Else
InstallFileSaveSub = False
End If
End Function
Private Sub InstallFileLoadCommand_Click()
'on error resume next 'loads any InstallFile
Dim InstallFile As String
'begin
InstallFile = GFCDGetFileName("Load...", 0, NULLARRAYSTRING(), NULLARRAYSTRING(), 0, ProgramFilesStructVar.ProgramPath)
If Not (InstallFile = "") Then 'verify
If Not ((Dir(InstallFile) = "") Or (Right(InstallFile, 1) = "\")) Then 'verify
Call InstallFile_Read(InstallFile)
Call FilesList_Reload(FilesStructNumber, FilesStructArray())
Call RegKeyList_Reload(RegKeyStructNumber, RegKeyStructArray())
Call ShellLinkList_Reload(ShellLinkStructNumber, ShellLinkStructArray())
Call InfoText_Reload(InfoStructVar)
Else
MsgBox "Error: file '" + InstallFile + "' not found !", vbOKOnly + vbExclamation
End If
End If
End Sub
'**************************************END OF MAIN**************************************
'**************************************INFOSTRUCT***************************************
'NOTE: the InfoStructVar saves general information about the application to install.
Private Sub InfoText_Reload(ByRef InfoStructVar As InfoStruct)
'on error resume next
'
'NOTE: the InfoTexts display the data of the InfoStructVar.
'
InfoClientNameText.Text = InfoStructVar.ClientFile
InfoProductNameText.Text = InfoStructVar.ProductName
InfoLaunchNameText.Text = InfoStructVar.LaunchName
InfoStartMenuFolderText.Text = InfoStructVar.StartMenuFolder
End Sub
Private Sub InfoStruct_Update(ByRef InfoStructVar As InfoStruct)
'on error resume next
InfoStructVar.ClientFile = InfoClientNameText.Text
InfoStructVar.ProductName = InfoProductNameText.Text
InfoStructVar.LaunchName = InfoLaunchNameText.Text
InfoStructVar.StartMenuFolder = InfoStartMenuFolderText.Text
End Sub
'***********************************END OF INFOSTRUCT***********************************
'*****************************************FILES*****************************************
'NOTE: the source name and target dir name of the files to install is first saved
'in the FilesStructArray(). When the Installer Client is created the files are packet
'into the Installer Client File by the SPack Client code.
'Additionally the FilesStructArray() data is written to the created InstallFile,
'which is also packed and can furthermore be used to save the current Server
'configuration.
Private Sub FilesAddFileCommand_Click()
'on error resume next
Dim AddName As String 'file that is to be added
'begin
If ProgramFilesStructVar.AddFileOld = "" Then ProgramFilesStructVar.AddFileOld = ProgramFilesStructVar.ProgramFile
'NOTE: it is very annoying when we always have to change the directory, so retain it for the next file adding.
AddName = GFCDGetFileName("Select File to add...", 0, NULLARRAYSTRING(), NULLARRAYSTRING(), 0, ProgramFilesStructVar.AddFileOld)
If Not ((Dir(AddName) = "") Or (Right$(AddName, 1) = "\") Or (AddName = "")) Then 'verify
ProgramFilesStructVar.AddFileOld = AddName
Call Files_AddFile(AddName, SystemStructVar.DefaultTargetDir, False)
Call FilesList_Reload(FilesStructNumber, FilesStructArray())
End If
End Sub
Private Sub FilesAddDirCommand_Click()
'on error resume next
Dim AddDir As String
Dim AddName As String
Dim FileLoop As Integer
'begin
AddDir = GFSelectDirectory("", "Select directory that contains files to install")
If Not ((Dir(AddDir, vbDirectory) = "") Or (AddDir = "")) Then 'verify
If Not (Right(AddDir, 1) = "\") Then AddDir = AddDir + "\" 'verify
AddDirFile.Path = AddDir
AddDirFile.Refresh
For FileLoop = 1 To AddDirFile.ListCount
Call Files_AddFile(AddDir + AddDirFile.List(FileLoop ‑ 1), SystemStructVar.DefaultTargetDir, False)
Next FileLoop
Call FilesList_Reload(FilesStructNumber, FilesStructArray())
End If
End Sub
Private Sub FilesRemoveCommand_Click()
'on error resume next
Dim StructLoop As Integer
If Not (FilesSourceNameList.ListIndex = True) Then
For StructLoop = (FilesSourceNameList.ListIndex + 1) To FilesStructNumber
If Not (StructLoop = FilesStructNumber) Then
FilesStructArray(StructLoop) = FilesStructArray(StructLoop + 1)
Else
FilesStructNumber = FilesStructNumber ‑ 1
StructLoop = FilesStructNumber
If StructLoop < 1 Then StructLoop = 1 'verify
ReDim Preserve FilesStructArray(1 To StructLoop) As FilesStruct
Exit For
End If
Next StructLoop
Call FilesList_Reload(FilesStructNumber, FilesStructArray())
Else
MsgBox "Please select a source name to remove !", vbOKOnly + vbExclamation
End If
End Sub
Private Sub FilesSetDefaultTargetDirCommand_Click()
'on error resume next
SystemStructVar.DefaultTargetDir = InputBox("Please enter default target dir (where file(s) will be unpacked to, possible: [dir name], %userdir%, %windir%, %winsysdir%):", "Installer Server", SystemStructVar.DefaultTargetDir)
End Sub
Private Sub FilesChangeTargetDirCommand_Click()
'on error resume next
Dim TargetDirNew As String
If Not (FilesTargetDirList.ListIndex = True) Then 'verify
TargetDirNew = InputBox("Please enter new target dir (where file(s) will be unpacked to, possible: [dir name], %userdir%, %windir%, %winsysdir%):", "Installer Server", FilesTargetDirList.List(FilesTargetDirList.ListIndex))
If Not (TargetDirNew = "") Then 'verify
FilesStructArray(FilesTargetDirList.ListIndex + 1).TargetName = TargetDirNew
Call FilesList_Reload(FilesStructNumber, FilesStructArray()) 'display changes
End If
Else
MsgBox "Please select a target dir from list below !", vbOKOnly + vbExclamation
End If
End Sub
Private Sub FilesSourceNameList_Click()
'on error resume next 'transfer list indices
If Not (FilesTargetDirList.ListIndex = FilesSourceNameList.ListIndex) Then 'avoid endless loop
FilesTargetDirList.ListIndex = FilesSourceNameList.ListIndex
End If
If Not (FilesNoUninstallList.ListIndex = FilesSourceNameList.ListIndex) Then 'avoid endless loop
FilesNoUninstallList.ListIndex = FilesSourceNameList.ListIndex
End If
End Sub
Private Sub FilesTargetDirList_Click()
'on error resume next 'transfer list indices
If Not (FilesSourceNameList.ListIndex = FilesTargetDirList.ListIndex) Then 'avoid endless loop
FilesSourceNameList.ListIndex = FilesTargetDirList.ListIndex
End If
If Not (FilesNoUninstallList.ListIndex = FilesTargetDirList.ListIndex) Then 'avoid endless loop
FilesNoUninstallList.ListIndex = FilesTargetDirList.ListIndex
End If
End Sub
Private Sub FilesNoUninstallList_Click()
'on error resume next 'transfer list indices
If Not (FilesSourceNameList.ListIndex = FilesNoUninstallList.ListIndex) Then 'avoid endless loop
FilesSourceNameList.ListIndex = FilesNoUninstallList.ListIndex
End If
If Not (FilesTargetDirList.ListIndex = FilesNoUninstallList.ListIndex) Then 'avoid endless loop
FilesTargetDirList.ListIndex = FilesNoUninstallList.ListIndex
End If
End Sub
Private Sub FilesReplaceSourceCommand_Click()
'on error resume next
Dim StructLoop As Integer
Dim ReplaceSourceString As String
Dim ReplaceTargetString As String
Dim ReplacePos As Long
'preset
ReplaceSourceString = InputBox("Please enter replace source string:")
If ReplaceSourceString = "" Then Exit Sub
ReplaceTargetString = InputBox("Please enter replace target string:")
If ReplaceTargetString = "" Then Exit Sub
'begin
For StructLoop = 1 To FilesStructNumber
ReplacePos = InStr(1, FilesStructArray(StructLoop).SourceName, ReplaceSourceString, vbTextCompare)
If (ReplacePos) Then
FilesStructArray(StructLoop).SourceName = Left$(FilesStructArray(StructLoop).SourceName, ReplacePos ‑ 1) + _
ReplaceTargetString + Mid$(FilesStructArray(StructLoop).SourceName, ReplacePos + Len(ReplaceSourceString))
End If
Next StructLoop
Call FilesList_Reload(FilesStructNumber, FilesStructArray()) 'display changes
End Sub
Private Sub Files_AddFile(ByVal AddName As String, ByVal AddNameTargetDir As String, ByVal NoUninstallFlag As Boolean)
'on error resume next 'call to add a file to the Client File
Dim StructLoop As Integer
'verify
If (Dir(AddName) = "") Or (Right$(AddName, 1) = "\") Or (AddName = "") Then 'verify
MsgBox "internal error in Files_AddFile(): file '" + AddName + "' not found !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
If Not (Right$(AddNameTargetDir, 1) = "\") Then AddNameTargetDir = AddNameTargetDir + "\" 'verify (even if directory name is e.g. %windir%\)
'check if file has been already added
For StructLoop = 1 To FilesStructNumber
If (UCase$(FilesStructArray(StructLoop).SourceName) = UCase$(AddName)) And _
(UCase$(FilesStructArray(StructLoop).TargetName) = UCase$(AddNameTargetDir + GetFileName(AddName))) Then
Exit Sub 'file has already been added
End If
Next StructLoop
'begin
If Not (FilesStructNumber = 32767) Then
FilesStructNumber = FilesStructNumber + 1
Else
Exit Sub 'error
End If
ReDim Preserve FilesStructArray(1 To FilesStructNumber) As FilesStruct
FilesStructArray(FilesStructNumber).SourceName = AddName
FilesStructArray(FilesStructNumber).TargetName = AddNameTargetDir + GetFileName(AddName)
FilesStructArray(FilesStructNumber).NoUninstallFlag = NoUninstallFlag
Exit Sub
End Sub
Private Sub FilesStruct_Update(ByVal FilesStructNumber As Integer, ByRef FilesStructArray() As FilesStruct)
'on error resume next
Dim StructLoop As Integer
For StructLoop = 1 To FilesStructNumber
If Not (StructLoop > FilesNoUninstallList.ListCount) Then
If FilesNoUninstallList.Selected(StructLoop ‑ 1) = True Then
FilesStructArray(StructLoop).NoUninstallFlag = True
Else
FilesStructArray(StructLoop).NoUninstallFlag = False
End If
Else
'
'NOTE: files have been added by system (VB5STKIT.DLL and Uninstaller),
'do not change the NoUninstallFlag.
'
End If
Next StructLoop
End Sub
Private Sub FilesList_Reload(ByVal FilesStructNumber As Integer, ByRef FilesStructArray() As FilesStruct)
'on error resume next
Dim StructLoop As Integer
Dim ListIndexOld As Integer 'list index of FilesSourceNameList (list index will be transfered automatically)
'
'NOTE: FilesList is an expression for the FilesSourceNameList and the FilesTargetDirList
'
'preset
ListIndexOld = FilesSourceNameList.ListIndex
'reset
FilesSourceNameList.Clear 'reset
FilesTargetDirList.Clear 'reset
FilesNoUninstallList.Clear 'reset
'begin
For StructLoop = 1 To FilesStructNumber
FilesSourceNameList.AddItem FilesStructArray(StructLoop).SourceName
FilesTargetDirList.AddItem FilesStructArray(StructLoop).TargetName
FilesNoUninstallList.AddItem "‑"
If FilesStructArray(StructLoop).NoUninstallFlag = True Then
FilesNoUninstallList.Selected(StructLoop ‑ 1) = True
Else
FilesNoUninstallList.Selected(StructLoop ‑ 1) = False
End If
Next StructLoop
Call GFListHScroll_AddScrollBars(FilesSourceNameList)
Call GFListHScroll_AddScrollBars(FilesTargetDirList)
Call GFListHScroll_AddScrollBars(FilesNoUninstallList)
'restore list index
If Not ((ListIndexOld < True) Or (ListIndexOld > (FilesSourceNameList.ListCount ‑ 1))) Then 'verify
FilesSourceNameList.ListIndex = ListIndexOld
End If
End Sub
'*************************************END OF FILES**************************************
'**************************************SHELL LINK***************************************
'NOTE: the data of the shell links to create is saved in the InstallFile which will be
'packed together with the original files to install.
'Note that it is necessary to transfer VB5STKIT.DLL to the target machine as this dll
'is necessary to create a shell link.
Private Sub ShellLinkNewCommand_Click()
'on error resume next
Dim ShellLinkFolder As String
Dim ShellLinkName As String
Dim ShellLinkApplication As String
'preset
Call InfoStruct_Update(InfoStructVar) 'data will be used in this sub
'begin
ShellLinkFolder = InputBox("Enter link folder (use %userfolder% to create the link in the newly created folder, use %programsfolder% to create the link in the program folder, a desktop short cut is created by default):", "Installer_Server", "%userfolder%")
If ShellLinkFolder = "" Then Exit Sub
ShellLinkName = InputBox("Enter link name (description):", "Installer_Server", InfoStructVar.ProductName)
If ShellLinkName = "" Then Exit Sub
ShellLinkApplication = InputBox("Enter link application (e.g. '%userdir%\InstallApp.exe', '%windir%\Calc.exe', '%currentdir%\Cleaner.exe'):", "Installer_Server", InfoStructVar.LaunchName)
If ShellLinkApplication = "" Then Exit Sub
'create link struct element
If Not (ShellLinkStructNumber = 32767) Then 'verify
ShellLinkStructNumber = ShellLinkStructNumber + 1
Else
MsgBox "The number of shell links is limited to 32767 !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
ReDim Preserve ShellLinkStructArray(1 To ShellLinkStructNumber) As ShellLinkStruct
ShellLinkStructArray(ShellLinkStructNumber).LinkFolder = ShellLinkFolder
ShellLinkStructArray(ShellLinkStructNumber).LinkName = ShellLinkName
ShellLinkStructArray(ShellLinkStructNumber).LinkApplication = ShellLinkApplication
Call ShellLinkList_Reload(ShellLinkStructNumber, ShellLinkStructArray())
End Sub
Private Sub ShellLinkRemoveCommand_Click()
'on error resume next
Dim StructLoop As Integer
If Not (ShellLinkList.ListIndex = True) Then 'verify
For StructLoop = ShellLinkList.ListIndex + 1 To ShellLinkStructNumber
If Not (StructLoop = ShellLinkStructNumber) Then
ShellLinkStructArray(StructLoop) = ShellLinkStructArray(StructLoop + 1)
Else
ShellLinkStructNumber = ShellLinkStructNumber ‑ 1
StructLoop = ShellLinkStructNumber
If StructLoop < 1 Then StructLoop = 1
ReDim Preserve ShellLinkStructArray(1 To StructLoop) As ShellLinkStruct
Exit For
End If
Next StructLoop
Call ShellLinkList_Reload(ShellLinkStructNumber, ShellLinkStructArray())
Else
MsgBox "Please select the shell link to remove !", vbOKOnly + vbExclamation
End If
End Sub
Private Sub ShellLinkChangeCommand_Click()
'on error resume next
Dim ShellLinkFolder As String
Dim ShellLinkName As String
Dim ShellLinkApplication As String
'verify
If ShellLinkList.ListIndex = True Then
MsgBox "Please select the shell link to edit in the list below !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
'begin
ShellLinkFolder = InputBox("Enter link folder (e.g. '..\..\Desktop'):", "Installer_Server", ShellLinkStructArray(ShellLinkList.ListIndex + 1).LinkFolder)
If Not (ShellLinkFolder = "") Then ShellLinkStructArray(ShellLinkList.ListIndex + 1).LinkFolder = ShellLinkFolder
ShellLinkName = InputBox("Enter link name (description):", "Installer_Server", ShellLinkStructArray(ShellLinkList.ListIndex + 1).LinkName)
If Not (ShellLinkName = "") Then ShellLinkStructArray(ShellLinkList.ListIndex + 1).LinkName = ShellLinkName
ShellLinkApplication = InputBox("Enter link application (e.g. '%userdir%\InstallApp.exe'):", "Installer_Server", ShellLinkStructArray(ShellLinkList.ListIndex + 1).LinkApplication)
If Not (ShellLinkApplication = "") Then ShellLinkStructArray(ShellLinkList.ListIndex + 1).LinkApplication = ShellLinkApplication
Call ShellLinkList_Reload(ShellLinkStructNumber, ShellLinkStructArray())
End Sub
Private Sub ShellLinkList_Reload(ByVal ShellLinkStructNumber As Integer, ByRef ShellLinkStructArray() As ShellLinkStruct)
'on error resume next
Dim ListIndexOld As Integer
Dim StructLoop As Integer
'preset
ListIndexOld = ShellLinkList.ListIndex
'reset
ShellLinkList.Clear 'reset
'begin
For StructLoop = 1 To ShellLinkStructNumber
ShellLinkList.AddItem """" + ShellLinkStructArray(StructLoop).LinkFolder + """ """ + ShellLinkStructArray(StructLoop).LinkName + """ """ + ShellLinkStructArray(StructLoop).LinkApplication + """"
Next StructLoop
Call GFListHScroll_AddScrollBars(ShellLinkList)
'restore list index
If Not ((ListIndexOld < True) Or (ListIndexOld > (ShellLinkList.ListCount ‑ 1))) Then 'verify
ShellLinkList.ListIndex = ListIndexOld
End If
End Sub
'***********************************END OF SHELL LINK***********************************
'****************************************REG KEY****************************************
'NOTE: the data to create the registry keys is written into the InstallFile.
'The user's registry will look after the installation process like the registry on
'the local machine (selected sub keys only, of course).
Private Sub RegKeyAddCommand_Click()
'on error resume next
Dim RegKeyNew As String
Dim RegKeyCurrent As String 'when creating a sub key list
Dim RegKeyAddedNumber As Integer
Dim RegMainKey As Long
Dim RegSubKey As String
Dim RegValueName As String
Dim RegValueValue As String
Dim RegValueNumber As Integer
Dim RegValueNameArray() As String
Dim RegValueValueArray() As String
Dim RegSubKeyNumber As Integer
Dim RegSubKeyNameArray() As String
Dim AddLoop As Integer
Dim SubLoop As Integer
'begin
'
RegKeyNew = InputBox("Please enter registry key whose values will be imported:", "Install Server", SystemStructVar.DefaultRegKey)
SystemStructVar.DefaultRegKey = RegKeyNew
'
If Not (RegKeyNew = "") Then 'verify
If RegKeyAddSubKeysCheck.Value = 1 Then
'add values of all sub keys
Call RegGetSubKeyListEx(GetRegMainKey(RegKeyNew), GetRegSubKey(RegKeyNew), RegSubKeyNumber, RegSubKeyNameArray(), True)
'NOTE: RegSubKeyNumber will never be 0.
For SubLoop = 1 To RegSubKeyNumber
'
RegKeyCurrent = RegSubKeyNameArray(SubLoop)
If Not (Right$(RegKeyCurrent, 1) = "\") Then RegKeyCurrent = RegKeyCurrent + "\" 'verify
'
Call RegGetKeyValueList(GetRegMainKey(RegKeyNew), RegKeyCurrent, RegValueNumber, RegValueNameArray(), RegValueValueArray())
For AddLoop = 1 To RegValueNumber
RegKeyAddedNumber = RegKeyAddedNumber + 1
Call RegKey_AddKey(GetRegMainKey(RegKeyNew), RegKeyCurrent, RegValueNameArray(AddLoop), RegValueValueArray(AddLoop))
Next AddLoop
'
Next SubLoop
'
If Not (RegKeyAddedNumber = 0) Then
Call RegKeyList_Reload(RegKeyStructNumber, RegKeyStructArray()) 'display changes
Else
MsgBox "Sorry, no sub keys found. Verify the entered key is valid.", vbOKOnly + vbInformation 'means also not the entered key
End If
Else
'add values of one sub key
Call RegGetKeyValueList(GetRegMainKey(RegKeyNew), GetRegSubKey(RegKeyNew), RegValueNumber, RegValueNameArray(), RegValueValueArray())
'
For AddLoop = 1 To RegValueNumber
RegKeyAddedNumber = RegKeyAddedNumber + 1
Call RegKey_AddKey(GetRegMainKey(RegKeyNew), GetRegSubKey(RegKeyNew), RegValueNameArray(AddLoop), RegValueValueArray(AddLoop))
Next AddLoop
'
If Not (RegKeyAddedNumber = 0) Then
Call RegKeyList_Reload(RegKeyStructNumber, RegKeyStructArray()) 'display changes
Else
MsgBox "Sorry, no value found or the entered key is not existing. Verify entered data.", vbOKOnly + vbInformation
End If
End If
End If
End Sub
Private Sub RegKeyRemoveCommand_Click()
'on error resume next
Dim StructLoop As Integer
If Not (RegKeyList.ListIndex = True) Then 'verify
For StructLoop = (RegKeyList.ListIndex + 1) To RegKeyStructNumber
If Not (StructLoop = RegKeyStructNumber) Then
RegKeyStructArray(StructLoop) = RegKeyStructArray(StructLoop + 1)
Else
RegKeyStructNumber = RegKeyStructNumber ‑ 1
StructLoop = RegKeyStructNumber 'StructLoop not in use anymore
If StructLoop < 1 Then StructLoop = 1 'verify
ReDim Preserve RegKeyStructArray(1 To StructLoop) As RegKeyStruct
Exit For
End If
Next StructLoop
Call RegKeyList_Reload(RegKeyStructNumber, RegKeyStructArray()) 'display changes
Else
MsgBox "Please select the key to remove in the list below !", vbOKOnly + vbExclamation
End If
End Sub
Private Sub RegKey_AddKey(ByVal RegMainKey As Long, ByVal RegSubKey As String, ByVal RegValueName As String, ByVal RegValueValue As String)
'on error resume next
If Not (RegKeyStructNumber = 32767) Then 'verify
RegKeyStructNumber = RegKeyStructNumber + 1
Else
Exit Sub 'error
End If
ReDim Preserve RegKeyStructArray(1 To RegKeyStructNumber) As RegKeyStruct
RegKeyStructArray(RegKeyStructNumber).RegMainKey = RegMainKey
RegKeyStructArray(RegKeyStructNumber).RegSubKey = RegSubKey
RegKeyStructArray(RegKeyStructNumber).RegValueName = RegValueName
RegKeyStructArray(RegKeyStructNumber).RegValueValue = RegValueValue
End Sub
Private Sub RegKeyList_Reload(ByVal RegKeyStructNumber As Integer, ByRef RegKeyStructArray() As RegKeyStruct)
'on error resume next 'reloads the RegKeyNameList only
Dim ListIndexOld As Integer
Dim StructLoop As Integer
Dim Tempstr$
'preset
ListIndexOld = RegKeyList.ListIndex
'reset
RegKeyList.Clear 'reset
'begin
For StructLoop = 1 To RegKeyStructNumber
Tempstr$ = GetRegMainKeyName(RegKeyStructArray(StructLoop).RegMainKey)
If Not (Right$(Tempstr$, 1) = "\") Then Tempstr$ = Tempstr$ + "\"
Tempstr$ = Tempstr$ + RegKeyStructArray(StructLoop).RegSubKey
If Not (Right$(Tempstr$, 1) = "\") Then Tempstr$ = Tempstr$ + "\"
Tempstr$ = Tempstr$ + RegKeyStructArray(StructLoop).RegValueName + "‑>" + RegKeyStructArray(StructLoop).RegValueValue
RegKeyList.AddItem Tempstr$
Next StructLoop
Call GFListHScroll_AddScrollBars(RegKeyList)
'restore list index
If Not ((ListIndexOld < True) Or (ListIndexOld > (RegKeyList.ListCount ‑ 1))) Then 'verify
RegKeyList.ListIndex = ListIndexOld
End If
End Sub
'************************************END OF REG KEY*************************************
'*****************************************HVAR******************************************
'NOTE: the HVAR system allows to change a string value in a compiled executable.
'The Installer Server sets e.g. the total size of the files to install, as well as the
'product name. Both values are existing in the Installer Client File in the form
'of HVAR Strings, which will be searched and changed.
'The advantage of the HVAR system is that the set information is available instantly
'after the Client File start up.
'As the HVAR system was originally developed for 'hacking' purposes (like the SPack)
'it uses an encryption system that must be initialized (don't forget to do so).
Private Sub HVARStruct_Update(ByRef HVARStructVar As HVARStruct)
'on error resume next
Dim FileSizeTotal As Long
Dim FileLoop As Integer
'begin
HVARStructVar.ProductName = InfoProductNameText.Text
For FileLoop = 1 To FilesStructNumber
If Not ((Dir(FilesStructArray(FileLoop).SourceName) = "") Or (Right$(FilesStructArray(FileLoop).SourceName, 1) = "\") Or (Len(FilesStructArray(FileLoop).SourceName) = 0)) Then 'verify (important, tested)
FileSizeTotal = FileSizeTotal + FileLen(FilesStructArray(FileLoop).SourceName)
Else
MsgBox "internal error in HVARStruct_Update(): file '" + FilesStructArray(FileLoop).SourceName + "' not found !", vbOKOnly + vbExclamation
End If
Next FileLoop
HVARStructVar.ProductFileSizeTotal = FileSizeTotal
End Sub
'********************************HVAR: SERVER FUNCTIONS*********************************
'NOTE: the HVAR Server code below is Installer Server specific.
Private Function HVAR_Create(ByVal HVARName As String, ByVal HVARValue As String, ByVal UseEncryptionFlag As Boolean) As String
'on error resume next 'returns HVAR string; uses RemoteCreateMsgLine()
Const HVARNameLengthFixed As Integer = 35 'do not (!) change
Const HVARValueLengthFixed As Integer = 35 'do not (!) change
'verify
If Len(HVARName) > HVARNameLengthFixed Then HVARName = Left$(HVARName, HVARNameLengthFixed) 'verify
If Len(HVARValue) > HVARValueLengthFixed Then HVARValue = Left$(HVARValue, HVARValueLengthFixed) 'verify
'begin
Select Case UseEncryptionFlag
Case False
'create unencrypted remote msg line
HVAR_Create = "<" + "'" + "remote command" + "'" + "|" + "890" + "|" + "HVAR string" + "|" + HVARName + String$(HVARNameLengthFixed ‑ Len(HVARName), Chr$(191)) + "|" + HVARValue + String$(HVARValueLengthFixed ‑ Len(HVARValue), Chr$(191)) + ">"
Case True
'create encrypted remote msg line
HVAR_Create = RemoteCreateMsgLine(890, "HVAR string", HVARName + String$(HVARNameLengthFixed ‑ Len(HVARName), Chr$(191)), HVARValue + String$(HVARValueLengthFixed ‑ Len(HVARValue), Chr$(191)))
End Select
End Function
Private Function HVAR_GetName(ByVal HVARString As String) As String
'on error resume next 'returns HVAR name included in passed HVAR string or nothing for error
HVAR_GetName = HVAR_GetSub(HVARString, True)
End Function
Private Function HVAR_GetValue(ByVal HVARString As String) As String
'on error resume next 'returns HVAR value included in passed HVAR string or nothing for error
HVAR_GetValue = HVAR_GetSub(HVARString, False)
End Function
Private Function HVAR_GetSub(ByVal HVARString As String, ByVal NameOrValueFlag As Boolean) As String
'on error resume next
Dim RemoteMsgNumberUnchanged As Integer
Dim RemoteMsgDescriptionUnchanged As String
Dim RemoteMsgwParamUnchanged As String
Dim RemoteMsglParamUnchanged As String
Dim HVARStringNew As String
Dim HVARTemp As Long
'store FormatRemoteMsgLine()‑values
RemoteMsgNumberUnchanged = RemoteMsgNumber
RemoteMsgDescriptionUnchanged = RemoteMsgDescription
RemoteMsgwParamUnchanged = RemoteMsgwParam
RemoteMsglParamUnchanged = RemoteMsglParam
'create HVARStringNew
For HVARTemp = 1 To Len(HVARString)
Select Case Mid$(HVARString, HVARTemp, 1)
Case Chr$(0)
'do nothing
Case Else
HVARStringNew = HVARStringNew + Mid$(HVARString, HVARTemp, 1)
End Select
Next HVARTemp
'get HVAR value
Call FormatRemoteMsgLine(HVARStringNew) 'format string without null chars
If RemoteMsgNumber = 890 Then 'verify
Select Case NameOrValueFlag
Case True
'cut spacer chars (Chr$(191))
For HVARTemp = Len(RemoteMsgwParam) To 1 Step (‑1)
If Not (Mid$(RemoteMsgwParam, HVARTemp, 1) = Chr$(191)) Then
HVARTemp = HVARTemp
Exit For
End If
Next HVARTemp
If HVARTemp < 0 Then HVARTemp = 0 'verify
HVAR_GetSub = Left$(RemoteMsgwParam, HVARTemp)
Case False
'cut spacer chars (Chr$(191))
For HVARTemp = Len(RemoteMsglParam) To 1 Step (‑1)
If Not (Mid$(RemoteMsglParam, HVARTemp, 1) = Chr$(191)) Then
HVARTemp = HVARTemp
Exit For
End If
Next HVARTemp
If HVARTemp < 0 Then HVARTemp = 0 'verify
HVAR_GetSub = Left$(RemoteMsglParam, HVARTemp)
End Select
Else
HVAR_GetSub = "" 'reset (error)
End If
'restore FormatRemoteMsgLine()‑values
RemoteMsgNumber = RemoteMsgNumberUnchanged
RemoteMsgDescription = RemoteMsgDescriptionUnchanged
RemoteMsgwParam = RemoteMsgwParamUnchanged
RemoteMsglParam = RemoteMsglParamUnchanged
End Function
Private Function HVAR_SetValue(ByVal InputName As String, ByVal HVARName As String, ByVal HVARValueNew As String, ByVal UseEncryptionFlag As Boolean) As Boolean
'on error resume next 'returns True if HVAR value has been set, False if not
Dim RemoteMsg890Line As String 'created msg line
Dim RemoteMsg890LineNew As String 'created msg line including null chars
Dim ProgramTwoLongVarVar As ProgramTwoLongVar
Dim TempFile As String
Dim HVARTemp As Long
'begin
ProgramTwoLongVarVar = HVAR_SetValue_GetHVARStringPos(InputName, HVARName, False, Nothing)
If Not ((ProgramTwoLongVarVar.LongVar1 = 0) Or (ProgramTwoLongVarVar.LongVar2 = 0)) Then 'verify
RemoteMsg890Line = HVAR_Create(HVARName, HVARValueNew, UseEncryptionFlag)
'create RemoteMsg890LineNew
For HVARTemp = 1 To Len(RemoteMsg890Line)
RemoteMsg890LineNew = RemoteMsg890LineNew + _
Mid$(RemoteMsg890Line, HVARTemp, 1) + Chr$(0)
Next HVARTemp
'verify RemoteMsg890LineNew
If Not (Len(RemoteMsg890LineNew) = 0) Then 'verify
'
'NOTE: ProgramTwoLongVarVar.LongVar[1, 2] point to
'['<', '>'], so last null char must be cut off.
'
RemoteMsg890LineNew = Left$(RemoteMsg890LineNew, Len(RemoteMsg890LineNew) ‑ 1)
Else
GoTo Error:
End If
If Not (Len(RemoteMsg890LineNew) = ProgramTwoLongVarVar.LongVar2 ‑ ProgramTwoLongVarVar.LongVar1 + 1) Then
GoTo Error: 'verify
End If
'insert RemoteMsg890LineNew
TempFile = GenerateTempFileName(GetDirectoryName(InputName))
If ReplaceStringInFile(InputName, TempFile, RemoteMsg890LineNew, ProgramTwoLongVarVar.LongVar1, ProgramTwoLongVarVar.LongVar2) = True Then
FileCopy TempFile, InputName
Kill TempFile
HVAR_SetValue = True 'ok
Exit Function
Else
Kill TempFile
GoTo Error:
End If
Else
GoTo Error:
End If
Exit Function
Error:
HVAR_SetValue = False 'error
Exit Function
End Function
Private Function HVAR_SetValue_GetHVARStringPos(ByVal InputName As String, ByVal HVARName As String, ByVal ListOnlyFlag As Boolean, ByVal ListBoxName As ListBox) As ProgramTwoLongVar
'on error resume next
Dim InputNameFileNumber As Integer
Dim BlockString As String
Dim BlockStartPos As Long
Dim BlockLength As Long
Dim RemoteMsg890LineStartPos As Long
Dim RemoteMsg890LineEndPos As Long
Dim RemoteMsg890Line As String
'
'NOTE: this function returns start/end pos of HVAR string containing the passed
'HVAR Name (capitalization not ignored) or initializes passed list box with all
'HVAR Names included in InputName.
'
'preset
If (ListOnlyFlag = True) And (0 = 0) Then ListBoxName.Clear 'reset
HVAR_SetValue_GetHVARStringPos.LongVar1 = 0
HVAR_SetValue_GetHVARStringPos.LongVar2 = 0
'verify
If (Dir(InputName) = "") Or (Right$(InputName, 1) = "\") Or (InputName = "") Then GoTo Error:
If (ListOnlyFlag = False) And (HVARName = "") Then GoTo Error:
'begin
InputNameFileNumber = FreeFile(0)
If InputNameFileNumber = 0 Then GoTo Error:
BlockStartPos = 1 'preset
Open InputName For Binary As #InputNameFileNumber
Do
'
'NOTE: the following code was partially copied from NN99
'RemoteFileStringReplace() (12‑10‑2000).
'
If BlockStartPos > LOF(InputNameFileNumber) Then Exit Do 'error
BlockLength = 128000 'reset
If (BlockStartPos + BlockLength ‑ 1) > LOF(InputNameFileNumber) Then 'verify block can be read
BlockLength = LOF(InputNameFileNumber) ‑ BlockStartPos + 1
End If
BlockString = String$(BlockLength, Chr$(0))
Get #InputNameFileNumber, BlockStartPos, BlockString
'
RemoteMsg890LineEndPos = 1 'preset
ReDo:
RemoteMsg890LineStartPos = InStr(RemoteMsg890LineEndPos, BlockString, "<", vbBinaryCompare)
If Not (RemoteMsg890LineStartPos = 0) Then
RemoteMsg890LineEndPos = InStr(RemoteMsg890LineStartPos, BlockString, ">", vbBinaryCompare)
If Not (RemoteMsg890LineEndPos = 0) Then
RemoteMsg890Line = Mid$(BlockString, RemoteMsg890LineStartPos, RemoteMsg890LineEndPos ‑ RemoteMsg890LineStartPos + 1)
Select Case ListOnlyFlag
Case False
If HVAR_GetName(RemoteMsg890Line) = HVARName Then
HVAR_SetValue_GetHVARStringPos.LongVar1 = BlockStartPos + RemoteMsg890LineStartPos ‑ 1
HVAR_SetValue_GetHVARStringPos.LongVar2 = BlockStartPos + RemoteMsg890LineEndPos ‑ 1
Exit Do 'ok
Else
'find next remote msg line start sign ('<')
RemoteMsg890LineEndPos = (RemoteMsg890LineStartPos + 1) 'important
GoTo ReDo:
End If
Case True
HVARName = HVAR_GetName(RemoteMsg890Line)
If Not (HVARName = "") Then
ListBoxName.AddItem HVARName + "=" + HVAR_GetValue(RemoteMsg890Line)
'find next remote msg line start sign ('<')
RemoteMsg890LineEndPos = (RemoteMsg890LineStartPos + 1) 'important
GoTo ReDo:
Else
'find next remote msg line start sign ('<')
RemoteMsg890LineEndPos = (RemoteMsg890LineStartPos + 1) 'important
GoTo ReDo:
End If
End Select
Else
'find next remote msg line start sign ('<')
RemoteMsg890LineEndPos = (RemoteMsg890LineStartPos + 1) 'important
GoTo ReDo:
End If
Else
'read next block
End If
'
If Not (BlockLength = LOF(InputNameFileNumber) ‑ BlockStartPos + 1) Then 'check if last block was read
BlockStartPos = BlockStartPos + BlockLength ‑ 12400 'make next block overlapping over old one
Else
Exit Do
End If
Loop
Close #InputNameFileNumber
Exit Function
Error:
Close #InputNameFileNumber 'make sure file is closed
HVAR_SetValue_GetHVARStringPos.LongVar1 = 0 'reset (error)
HVAR_SetValue_GetHVARStringPos.LongVar2 = 0 'reset (error)
Exit Function
End Function
'*****************************END OF HVAR: SERVER FUNCTIONS*****************************
'**************************HVAR: GENERAL NN99 SYSTEM FUNCTIONS**************************
'NOTE: some of the following functions must additionally be copied to the target project if
'not existing yet (see list):
'HVAR Client
'‑FormatRemoteMsgLine (also Dim formatloop as Long)
'‑EncryptWordPro()
'‑DecryptWordPro()
'‑DefineCryptionSystem
'HVAR Server
'‑FormatRemoteMsgLine (also Dim formatloop as Long)
'‑EncryptWordPro()
'‑DecryptWordPro()
'‑DefineCryptionSystem
'‑GenerateTempFileName()
'‑ReplaceStringInFile()
Private Function RemoteCreateMsgLine(ByVal RemoteMsgNumber As Integer, RemoteMsgDescription As String, RemoteMsgwParam As String, RemoteMsglParam As String) As String
On Error Resume Next 'copied from NN99 (10‑12‑2000)
RemoteCreateMsgLine = "<" + "'" + EncryptWordPro(DecryptWordPro("7405E58503350255F585E545B205")) + "'" + "|" + EncryptWordPro(LTrim$(Str$(RemoteMsgNumber))) + "|" + EncryptWordPro(RemoteMsgDescription) + "|" + EncryptWordPro(RemoteMsgwParam) + "|" + EncryptWordPro(RemoteMsglParam) + ">" 'remote command
End Function
Private Sub FormatRemoteMsgLine(ByVal RemoteMsgLine As String)
On Error Resume Next 'copied from NN99 (10‑12‑2000)
If RemoteMsgLine = "" Then GoTo Error: 'verify
If Not (Left$(RemoteMsgLine, 1) = "<") Then
GoTo Error:
Else
RemoteMsgLine = Right(RemoteMsgLine, Len(RemoteMsgLine) ‑ 1)
For FormatLoop = 1 To Len(RemoteMsgLine)
If Mid$(RemoteMsgLine, FormatLoop, 1) = "|" Then 'check if RemoteMsgLine is a message line
Select Case Trim$(Left$(RemoteMsgLine, FormatLoop ‑ 1))
Case Is = "'" + DecryptWordPro("7405E58503350255F585E545B205") + "'" 'remote command
RemoteMsgLineProEncryptionExistingFlag = False 'message line is not pro encrypted
RemoteMsgLine = Right$(RemoteMsgLine, Len(RemoteMsgLine) ‑ FormatLoop)
Exit For 'important
Case Is = "'" + EncryptWordPro(DecryptWordPro("7405E58503350255F585E545B205")) + "'" 'remote command
RemoteMsgLineProEncryptionExistingFlag = True 'message line is pro encrypted
RemoteMsgLine = Right$(RemoteMsgLine, Len(RemoteMsgLine) ‑ FormatLoop)
Exit For
Case Else
GoTo Error:
Exit For
End Select
End If
If FormatLoop = Len(RemoteMsgLine) Then Exit Sub
Next FormatLoop
For FormatLoop = 1 To Len(RemoteMsgLine)
If Mid$(RemoteMsgLine, FormatLoop, 1) = "|" Then 'command number may not be 0
'decrypt if necessary
If RemoteMsgLineProEncryptionExistingFlag = False Then
RemoteMsgNumber = Val(Trim$(Left$(RemoteMsgLine, FormatLoop ‑ 1)))
Else
RemoteMsgNumber = Val(DecryptWordPro(Trim$(Left$(RemoteMsgLine, FormatLoop ‑ 1))))
End If
'verify value
If RemoteMsgNumber = 0 Then
GoTo Error:
Else
RemoteMsgLine = Right$(RemoteMsgLine, Len(RemoteMsgLine) ‑ FormatLoop)
Exit For
End If
End If
If FormatLoop = Len(RemoteMsgLine) Then Exit Sub
Next FormatLoop
For FormatLoop = 1 To Len(RemoteMsgLine)
If Mid$(RemoteMsgLine, FormatLoop, 1) = "|" Then 'description may be ""
If RemoteMsgLineProEncryptionExistingFlag = False Then
RemoteMsgDescription = Trim$(Left$(RemoteMsgLine, FormatLoop ‑ 1))
Else 'decrypt
RemoteMsgDescription = DecryptWordPro(Trim$(Left$(RemoteMsgLine, FormatLoop ‑ 1)))
End If
RemoteMsgLine = Right$(RemoteMsgLine, Len(RemoteMsgLine) ‑ FormatLoop)
Exit For
End If
If FormatLoop = Len(RemoteMsgLine) Then Exit Sub
Next FormatLoop
For FormatLoop = 1 To Len(RemoteMsgLine)
If Mid$(RemoteMsgLine, FormatLoop, 1) = "|" Then 'wParam may be ""
If RemoteMsgLineProEncryptionExistingFlag = False Then
RemoteMsgwParam = Trim$(Left$(RemoteMsgLine, FormatLoop ‑ 1))
Else 'decrypt
RemoteMsgwParam = DecryptWordPro(Trim$(Left$(RemoteMsgLine, FormatLoop ‑ 1)))
End If
RemoteMsgLine = Right$(RemoteMsgLine, Len(RemoteMsgLine) ‑ FormatLoop)
Exit For
End If
If FormatLoop = Len(RemoteMsgLine) Then Exit Sub
Next FormatLoop
For FormatLoop = Len(RemoteMsgLine) To 1 Step (‑1) 'seek in reverse direction to allow using long strings (for Remote File Upload) as lParam without decreasing speed or error due to > in lParam
If Mid$(RemoteMsgLine, FormatLoop, 1) = ">" Then 'lParam may be ""
If RemoteMsgLineProEncryptionExistingFlag = False Then
RemoteMsglParam = Trim$(Left$(RemoteMsgLine, FormatLoop ‑ 1))
Else 'decrypt
RemoteMsglParam = DecryptWordPro(Trim$(Left$(RemoteMsgLine, FormatLoop ‑ 1)))
End If
RemoteMsgLine = Right$(RemoteMsgLine, Len(RemoteMsgLine) ‑ FormatLoop)
Exit For
End If 'do not test if value of FormatLoop is equal length of RemoteMsgLine
Next FormatLoop
End If
Exit Sub
Error:
On Error GoTo 0
On Error Resume Next
RemoteMsgNumber = 0 'set message number to zero in case of any error (line is not an NN99 message line)
RemoteMsgDescription = "" 'reset
RemoteMsgwParam = "" 'reset
RemoteMsglParam = "" 'reset
Exit Sub
End Sub
Private Function ReplaceStringInFile(ByVal InputName As String, ByVal TempFile As String, ByRef Replace_String As String, ByVal Replace_StartPos As Long, ByVal Replace_EndPos As Long) As Boolean 'used by PPCsys
On Error GoTo Error: 'returns True in case of success, False if an error occurs
Dim InputNameNumber As Integer
Dim TempFileNumber As Integer
'
'NOTE: use this function to put a string into another at a fixed location.
'Files are used to allow working with large strings without running out of memory.
'The string to change must be written into the file InputName manually, and the
'changed string read out of TempFile. This is not done automatically as sometimes
'strings are not necessary (replace file parts only).
'
'verify files
If ((Dir(InputName) = "") Or (Right$(InputName, 1) = "\") Or (InputName = "")) Then
GoTo Error:
End If
If ((Right$(TempFile, 1) = "\") Or (TempFile = "")) Then
GoTo Error:
End If
'end
InputNameNumber = FreeFile(0)
Open InputName For Binary As #InputNameNumber
'verify replace start‑ and end pos
Select Case Replace_StartPos
Case Is < 1
GoTo Error:
Case Is > LOF(InputNameNumber)
GoTo Error:
End Select
Select Case Replace_EndPos
Case Is < Replace_StartPos
GoTo Error:
Case Is > LOF(InputNameNumber)
GoTo Error:
End Select
'end
TempFileNumber = FreeFile(0)
Open TempFile For Output As #TempFileNumber
Dim BlockString As String
Dim BlockStartPos As Long
Dim BlockLength As Long
For BlockStartPos = 1 To (Replace_StartPos ‑ 1) Step 128000
BlockLength = 128000
If (Replace_StartPos ‑ BlockStartPos) < BlockLength Then
BlockLength = (Replace_StartPos ‑ BlockStartPos)
End If
BlockString = String$(BlockLength, Chr$(0))
Get #InputNameNumber, BlockStartPos, BlockString
Print #TempFileNumber, BlockString;
Next BlockStartPos
Print #TempFileNumber, Replace_String;
For BlockStartPos = (Replace_EndPos + 1) To LOF(InputNameNumber) Step 128000
BlockLength = 128000
If (LOF(InputNameNumber) ‑ BlockStartPos + 1) < BlockLength Then
BlockLength = (LOF(InputNameNumber) ‑ BlockStartPos + 1)
End If
BlockString = String$(BlockLength, Chr$(0))
Get #InputNameNumber, BlockStartPos, BlockString
Print #TempFileNumber, BlockString;
Next BlockStartPos
Close #TempFileNumber
Close #InputNameNumber
ReplaceStringInFile = True 'default (no error)
Exit Function
Error:
On Error GoTo 0
On Error Resume Next 'important
Close #TempFileNumber
Close #InputNameNumber
ReplaceStringInFile = False 'error
Exit Function
End Function
'NOTE: the cryption functions were copied from NN99 (12‑09‑2000).
'****************************NN99 GENERAL CRYPTION FUNCTIONS****************************
'NOTE: use following functions to crypt short strings. (c)1999, 2000 by daynight.
Private Function EncryptWordPro(ByVal EncryptWordProData As String) As String
On Error Resume Next 'chars with ascii code from (both included) 32 to 127 may be used
'define variables
Dim KeyWordPos As Integer
Dim XxorY As Integer
Dim EncryptWordProTemp As Long
Dim EncryptWordProTempstr$
'NOTE: an initialized buffer is used to increase encryption speed.
EncryptWordPro = String$((Len(EncryptWordProData) * 2), Chr$(0)) 'initialize buffer
KeyWordPos = 0 'preset
For EncryptWordProTemp = 1 To Len(EncryptWordProData)
'encrypt using keyword
If KeyWordPos < Len(EncryptionKeyWord(1)) Then
KeyWordPos = KeyWordPos + 1
Else
KeyWordPos = 1
End If
XxorY = (Asc(Mid$(EncryptWordProData, EncryptWordProTemp, 1))) Xor (Asc(Mid$(EncryptionKeyWord(1), KeyWordPos, 1)))
'end
If Not ((XxorY < 32) Or (XxorY > 127)) Then 'not necessary, but must be used for compatibility reasons with older versions of this function
EncryptWordProTempstr$ = Hex$(XxorY)
Else
EncryptWordProTempstr$ = Hex$(Asc(Mid$(EncryptWordProData, EncryptWordProTemp, 1)))
End If
If Len(EncryptWordPro) = 1 Then
Mid$(EncryptWordPro, (EncryptWordProTemp * 2) ‑ 1, 2) = EncryptWordProTempstr$ + "0" 'already swapped
Else
Mid$(EncryptWordPro, (EncryptWordProTemp * 2) ‑ 1, 2) = Mid$(EncryptWordProTempstr$, 2, 1) + Mid$(EncryptWordProTempstr$, 1, 1)
End If
Next EncryptWordProTemp
End Function
Private Function DecryptWordPro(ByVal DecryptWordProData As String) As String
On Error Resume Next
'define vars
Dim KeyWordPos As Integer
Dim XxorY As Integer
Dim DecryptWordProTemp As Long
Dim DecryptWordProTempstr$
'NOTE: an initialized buffer is used to increase encryption speed.
DecryptWordPro = String$((Len(DecryptWordProData) / 2), Chr$(0)) 'initialize buffer
KeyWordPos = 0 'preset
For DecryptWordProTemp = 1 To Len(DecryptWordProData) Step 2
DecryptWordProTempstr$ = Mid$(DecryptWordProData, DecryptWordProTemp + 1, 1) + Mid$(DecryptWordProData, DecryptWordProTemp, 1)
'decrypt using keyword
If KeyWordPos < Len(EncryptionKeyWord(1)) Then
KeyWordPos = KeyWordPos + 1
Else
KeyWordPos = 1
End If
XxorY = (Val("&H" + DecryptWordProTempstr$)) Xor (Asc(Mid$(EncryptionKeyWord(1), KeyWordPos, 1)))
'end
If Not ((XxorY < 32) Or (XxorY > 127)) Then 'not necessary, but must be used for compatibility reasons with older versions of this function
Mid$(DecryptWordPro, ((DecryptWordProTemp + 1) / 2), 1) = Chr$(XxorY)
Else
Mid$(DecryptWordPro, ((DecryptWordProTemp + 1) / 2), 1) = Chr$((Val("&H" + DecryptWordProTempstr$)))
End If
Next DecryptWordProTemp
End Function
'*******************************END OF CRYPTION FUNCTIONS*******************************
'**********************END OF HVAR: GENERAL NN99 SYSTEM FUNCTIONS***********************
'**************************************END OF HVAR**************************************
'***********************************GENERAL FUNCTIONS***********************************
Private Function GFCDGetFileName(ByVal Title As String, ByRef FilterNumber As Integer, ByRef FilterDescriptionArray() As String, ByRef FilterStringArray() As String, ByVal DefaultFilterIndex As Integer, ByVal DefaultPath As String) As String
'on error resume next 'must be placed into a form (uses hWnd); FilterNumber may be 0 (then pass NULLARRAYSTRING()), DefaultPath should contain path and file name
Dim OPENFILENAMEVar As OPENFILENAME
Dim DefaultFileName As String
Dim DefaultDirectoryName As String
Dim Temp As Long
'
'NOTE: the FilerDescriptionArray() and the FilterStringArray() data
'must have the following format (example; description/string):
'
'Bitmap/*.bmp;*.jpg;*.gif
'
'If FilterNumber is 0, the preset filter 'All Files/*.*' is used.
'If the user pressed 'Cancel' the function returns nothing ("").
'
'initialize structure
OPENFILENAMEVar.lStructSize = Len(OPENFILENAMEVar)
OPENFILENAMEVar.hWndOwner = 0 'do not use form (module ?!) handle
OPENFILENAMEVar.hInstance = App.hInstance
If Not (FilterNumber = 0) Then
'
'NOTE: the filter string contains string pairs (filter description/string),
'the string end is marked by two null chars.
'
For Temp = 1 To FilterNumber
OPENFILENAMEVar.lpstrFilter = OPENFILENAMEVar.lpstrFilter + _
FilterDescriptionArray(Temp) + Chr$(0) + FilterStringArray(Temp) + Chr$(0)
Next Temp
OPENFILENAMEVar.lpstrFilter = OPENFILENAMEVar.lpstrFilter + Chr$(0) 'two null chars at filter string end
Else
OPENFILENAMEVar.lpstrFilter = "All Files" + Chr$(0) + "*.*" + Chr$(0) + Chr$(0)
End If
OPENFILENAMEVar.nFilterIndex = DefaultFilterIndex
If Not (GetFileName(DefaultPath) = "") Then
DefaultFileName = GetFileName(DefaultPath)
OPENFILENAMEVar.nMaxFile = 260 + 1 'MAX_PATH
OPENFILENAMEVar.lpstrFile = String$(260 + 1, Chr$(0))
Mid$(OPENFILENAMEVar.lpstrFile, 1, Len(DefaultFileName)) = Left$(DefaultFileName, 260)
Else
OPENFILENAMEVar.nMaxFile = 260 + 1 'MAX_PATH
OPENFILENAMEVar.lpstrFile = String$(260 + 1, Chr$(0))
End If
OPENFILENAMEVar.lpstrTitle = Title + Chr$(0)
DefaultDirectoryName = Left$(DefaultPath, Len(DefaultPath) ‑ Len(DefaultFileName))
OPENFILENAMEVar.lpstrInitialDir = DefaultDirectoryName + Chr$(0)
OPENFILENAMEVar.nMaxFileTitle = 260 + 1 'MAX_PATH
OPENFILENAMEVar.lpstrFileTitle = String$(260 + 1, Chr$(0)) 'receives selected file name (without directory)
OPENFILENAMEVar.Flags = OFN_HIDEREADONLY
'end of initializing structure
If Not (GetOpenFileName(OPENFILENAMEVar) = 0) Then
If Not (InStr(1, OPENFILENAMEVar.lpstrFile, Chr$(0), vbBinaryCompare) = 0) Then 'verify
GFCDGetFileName = Left$(OPENFILENAMEVar.lpstrFile, InStr(1, OPENFILENAMEVar.lpstrFile, Chr$(0), vbBinaryCompare) ‑ 1)
Else
GFCDGetFileName = OPENFILENAMEVar.lpstrFile
End If
Else
GFCDGetFileName = "" 'reset (error)
End If
End Function
Private Function GFCDSetFileName(ByVal Title As String, ByRef FilterNumber As Integer, ByRef FilterDescriptionArray() As String, ByRef FilterStringArray() As String, ByVal DefaultFilterIndex As Integer, ByVal DefaultPath As String) As String
'on error resume next 'must be placed into a form (uses hWnd); FilterNumber may be 0 (then pass NULLARRAYSTRING()), DefaultPath should contain path and file name
Dim OPENFILENAMEVar As OPENFILENAME
Dim DefaultFileName As String
Dim DefaultDirectoryName As String
Dim Temp As Long
'
'NOTE: the FilerDescriptionArray() and the FilterStringArray() data
'must have the following format (example; description/string):
'
'Bitmap/*.bmp;*.jpg;*.gif
'
'If FilterNumber is 0, the preset filter 'All Files/*.*' is used.
'If the user pressed 'Cancel' the function returns nothing ("").
'
'initialize structure
OPENFILENAMEVar.lStructSize = Len(OPENFILENAMEVar)
OPENFILENAMEVar.hWndOwner = 0 'do not use form (module ?!) handle
OPENFILENAMEVar.hInstance = App.hInstance
If Not (FilterNumber = 0) Then
'
'NOTE: the filter string contains string pairs (filter description/string),
'the string end is marked by two null chars.
'
For Temp = 1 To FilterNumber
OPENFILENAMEVar.lpstrFilter = OPENFILENAMEVar.lpstrFilter + _
FilterDescriptionArray(Temp) + Chr$(0) + FilterStringArray(Temp) + Chr$(0)
Next Temp
OPENFILENAMEVar.lpstrFilter = OPENFILENAMEVar.lpstrFilter + Chr$(0) 'two null chars at filter string end
Else
OPENFILENAMEVar.lpstrFilter = "All Files" + Chr$(0) + "*.*" + Chr$(0) + Chr$(0)
End If
OPENFILENAMEVar.nFilterIndex = DefaultFilterIndex
If Not (GetFileName(DefaultPath) = "") Then
DefaultFileName = GetFileName(DefaultPath)
OPENFILENAMEVar.nMaxFile = 260 + 1 'MAX_PATH
OPENFILENAMEVar.lpstrFile = String$(260 + 1, Chr$(0))
Mid$(OPENFILENAMEVar.lpstrFile, 1, Len(DefaultFileName)) = Left$(DefaultFileName, 260)
Else
OPENFILENAMEVar.nMaxFile = 260 + 1 'MAX_PATH
OPENFILENAMEVar.lpstrFile = String$(260 + 1, Chr$(0))
End If
OPENFILENAMEVar.lpstrTitle = Title + Chr$(0)
DefaultDirectoryName = Left$(DefaultPath, Len(DefaultPath) ‑ Len(DefaultFileName))
OPENFILENAMEVar.lpstrInitialDir = DefaultDirectoryName + Chr$(0)
OPENFILENAMEVar.nMaxFileTitle = 260 + 1 'MAX_PATH
OPENFILENAMEVar.lpstrFileTitle = String$(260 + 1, Chr$(0)) 'receives selected file name (without directory)
OPENFILENAMEVar.Flags = OFN_HIDEREADONLY
'end of initializing structure
If Not (GetSaveFileName(OPENFILENAMEVar) = 0) Then
If Not (InStr(1, OPENFILENAMEVar.lpstrFile, Chr$(0), vbBinaryCompare) = 0) Then 'verify
GFCDSetFileName = Left$(OPENFILENAMEVar.lpstrFile, InStr(1, OPENFILENAMEVar.lpstrFile, Chr$(0), vbBinaryCompare) ‑ 1)
Else
GFCDSetFileName = OPENFILENAMEVar.lpstrFile
End If
Else
GFCDSetFileName = "" 'reset (error)
End If
End Function
Private Function GFSelectDirectory(ByVal RootDirectory As String, ByVal InfoText As String) As String
On Error Resume Next 'v1.0 ‑ does not support a root directory
Dim BROWSEINFOVar As BROWSEINFO
Dim Temp As Long
Dim Tempstr$
'preset
'BROWSEINFOVar.pidlRoot = RootDirectory 'does not work
BROWSEINFOVar.hOwner = 0 'do not use an owner form (module ?)
BROWSEINFOVar.pszDisplayName = String$(MAX_PATH, Chr$(0)) 'display name (e.g. 'Windows' for C:\Windows\)
BROWSEINFOVar.lpszTitle = InfoText
BROWSEINFOVar.ulFlags = BIF_RETURNONLYFSDIRS 'file system directories only
BROWSEINFOVar.lpfn = 0 'address of event call‑back function
BROWSEINFOVar.lParam = 0 'parameter that would be passed to event call‑back function
'begin
Temp = SHBrowseForFolder(BROWSEINFOVar)
'return selected folder
'BROWSEINFOVar.pszDisplayName 'display name of selected folder
'BROWSEINFOVar.iImage 'image of selected item in system image list
If Not (Temp = 0) Then 'verify
Tempstr$ = String$(MAX_PATH, Chr$(0))
Call SHGetPathFromIDList(ByVal Temp, ByVal Tempstr$)
If Not (InStr(1, Tempstr$, Chr$(0), vbBinaryCompare) = 0) Then 'verify
GFSelectDirectory = Left$(Tempstr$, InStr(1, Tempstr$, Chr$(0), vbBinaryCompare) ‑ 1) 'ok
Else
GFSelectDirectory = "" 'error
End If
Else
GFSelectDirectory = "" 'error
End If
End Function
Private Sub GFListHScroll_AddScrollBars(ByRef TargetList As ListBox)
'on error resume next 'this sub requires GFListHScrollFontSizePicture to be located on current form
Dim TextWidthMax As Long
Dim Temp As Long
'preset
GFListHScrollFontSizePicture.Font.Name = TargetList.Font.Name
GFListHScrollFontSizePicture.Font.Size = TargetList.Font.Size
GFListHScrollFontSizePicture.Font.Bold = TargetList.Font.Bold
GFListHScrollFontSizePicture.Font.Italic = TargetList.Font.Italic
GFListHScrollFontSizePicture.Font.Weight = TargetList.Font.Weight
GFListHScrollFontSizePicture.Font.Charset = TargetList.Font.Charset
'begin
For Temp = 1 To TargetList.ListCount
If GFListHScrollFontSizePicture.TextWidth(TargetList.List(Temp ‑ 1)) > TextWidthMax Then
TextWidthMax = GFListHScrollFontSizePicture.TextWidth(TargetList.List(Temp ‑ 1))
End If
Next Temp
Call SendMessageLong(TargetList.hwnd, LB_SETHORIZONTALEXTENT, TextWidthMax + 15, ByVal 0&) '15 pixels for v scroll bar
End Sub
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 Function GenerateTempFileName(ByVal TempFilePath As String) As String 'copied from NN99 (06‑13‑2001)
On Error Resume Next 'returns name of a non‑existing file in TempFilePath, file name has following format: ########.tmp
Dim GenerateTempFileTemp As Integer
If (Not (Right$(TempFilePath, 1) = "\")) And (Not (TempFilePath = "")) Then 'verify
TempFilePath = TempFilePath + "\"
End If
Do
GenerateTempFileName = TempFilePath + Format$((Rnd(1) * 1E+08!), "00000000") + ".tmp"
GenerateTempFileTemp = GenerateTempFileTemp + 1 'just to make sure
Loop Until (Dir(GenerateTempFileName) = "") Or (GenerateTempFileTemp = 32767)
End Function
Private Sub Form_Unload(Cancel As Integer)
'on error resume next
Me.Visible = False
Me.Enabled = False
Me.Refresh
End 'important
End Sub
'***END OF MFRM CODE***
[END OF FILE]