GFProgramResource/ProgramResourceFileCreator/Mfrm.frm
VERSION 5.00
Begin VB.Form Mfrm
BorderStyle = 1 'Fest Einfach
Caption = "ProgramResourceFileCreator (c)2001 by Louis."
ClientHeight = 4455
ClientLeft = 45
ClientTop = 450
ClientWidth = 8835
Icon = "Mfrm.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 4455
ScaleWidth = 8835
StartUpPosition = 3 'Windows‑Standard
Begin VB.CommandButton CreatorCommentCommand
Caption = "&Comment..."
Height = 375
Left = 60
TabIndex = 6
Top = 2820
Width = 1155
End
Begin VB.CommandButton CreatorBrowseCommand
Caption = "Browse..."
Height = 375
Left = 6600
TabIndex = 9
ToolTipText = "Any existing file will be overwritten without prompting"
Top = 3960
Width = 1035
End
Begin VB.TextBox CreatorProgramResourceFileText
Height = 285
Left = 6300
TabIndex = 8
Top = 3600
Width = 2415
End
Begin VB.CommandButton CreatorCreateCommand
Caption = "Create !"
Height = 375
Left = 7680
TabIndex = 10
ToolTipText = "Any existing file will be overwritten without prompting"
Top = 3960
Width = 1035
End
Begin VB.CommandButton CreatorLoadCommand
Caption = "Load from File..."
Height = 375
Left = 2700
TabIndex = 0
Top = 60
Width = 1335
End
Begin VB.CommandButton CreatorSaveCommand
Caption = "Save in File..."
Height = 375
Left = 1320
TabIndex = 1
Top = 60
Width = 1335
End
Begin VB.PictureBox GFListHScrollFontSizePicture
Enabled = 0 'False
Height = 315
Left = 240
ScaleHeight = 17
ScaleMode = 3 'Pixel
ScaleWidth = 9
TabIndex = 17
Top = 0
Visible = 0 'False
Width = 195
End
Begin VB.FileListBox CreatorFile
Enabled = 0 'False
Height = 285
Left = 0
TabIndex = 16
Top = 0
Visible = 0 'False
Width = 195
End
Begin VB.CommandButton CreatorDirAddCommand
Caption = "Add Dir..."
Height = 375
Left = 60
TabIndex = 3
ToolTipText = "Removes the file selected in the list"
Top = 1560
Width = 1155
End
Begin VB.CommandButton CreatorReplaceCommand
Caption = "Replace..."
Height = 375
Left = 60
TabIndex = 5
ToolTipText = "Replace a string in the names of the files to add (useful if e.g. the source drive of the files has changed)"
Top = 2400
Width = 1155
End
Begin VB.CommandButton CreatorFileRemoveCommand
Caption = "&Remove"
Height = 375
Left = 60
TabIndex = 4
ToolTipText = "Removes the file selected in the list"
Top = 1980
Width = 1155
End
Begin VB.CommandButton CreatorFileAddCommand
Caption = "Add File..."
Height = 375
Left = 60
TabIndex = 2
ToolTipText = "Adds another file"
Top = 1140
Width = 1155
End
Begin VB.ListBox CreatorFileList
BeginProperty Font
Name = "Courier"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 2400
Left = 1320
MultiSelect = 2 'Erweitert
TabIndex = 7
Top = 840
Width = 7395
End
Begin VB.Label CreatorCopyrightLabel
Caption = "[...]"
Height = 435
Left = 4140
TabIndex = 11
Top = 60
Width = 4575
End
Begin VB.Label CreatorFileLoadedLabel
Caption = "No file loaded."
BeginProperty Font
Name = "Courier"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 195
Left = 1320
TabIndex = 12
Top = 540
Width = 7395
End
Begin VB.Label CreatorStatusLabel
Appearance = 0 '2D
BorderStyle = 1 'Fest Einfach
Caption = "[...]"
BeginProperty Font
Name = "Courier"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 1035
Left = 1320
TabIndex = 13
Top = 3300
Width = 4815
End
Begin VB.Label CreatorProgramResourceFileLabel
Caption = "ProgramResourceFile:"
BeginProperty Font
Name = "Arial"
Size = 8.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 195
Left = 6300
TabIndex = 14
Top = 3300
Width = 1875
End
Begin VB.Label CreatorFileListLabel
Caption = "Files to add:"
BeginProperty Font
Name = "Arial"
Size = 8.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 195
Left = 60
TabIndex = 15
Top = 840
Width = 1035
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 by Louis. To be used as a tool for any program that uses GFProgramResource code.
'Created within 4 hours ("Lasst uns coden LALALALALAALAA").
'
'NOTE: this program allows to easily create a program resource file
'that can be handled by the GFProgramResource code.
'As all files to add can be saved in the 'CreatorFile', it is possible to quickly
'update a resource file.
'
'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
'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
'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
'GFCDGetFileName; GFCDSetFileName
Const OFN_HIDEREADONLY = &H4
Dim NULLARRAYSTRING(0 To 0) As String 'disable if already existing in target project
'GFListHScroll
Const LB_SETHORIZONTALEXTENT = &H194
'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
'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
'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
'CreatorFilesStruct ‑ contains the names of the files to include in the ProgramResourceFile
Private Type CreatorFileStruct
CreatorFileName As String
CreatorFileComment As String
End Type
Dim CreatorFileStructNumber As Integer
Dim CreatorFileStructArray() As CreatorFileStruct
Dim CreatorFileLoaded As String
Dim CreatorFileChangesExistingFlag As Boolean
'other
Dim AddFileDirOld As String
Private Sub Form_Load()
'on error resume next
Call DefineStatus
Call DefineVars
End Sub
Private Sub DefineStatus()
'on error resume next
CreatorCopyrightLabel.Caption = _
"ProgramResourceFileCreator (c)2001 by Louis, " + _
"SPack (c)2001 by Louis, " + _
"GFProgramResource (c)2001 by Louis."
CreatorStatusLabel.Caption = "Add resource files and optionally set comments. Define ProgramResourceFile and save information in a CreatorFile before pressing 'Create !'."
End Sub
Private Sub DefineVars()
'on error resume next
CreatorFileLoaded = App.Path 'default file name (path) for loading or saving a CreatorFile
If Not (Right(CreatorFileLoaded, 1) = "\") Then CreatorFileLoaded = CreatorFileLoaded + "\" 'verify
End Sub
'************************************COMMAND CLICKS*************************************
'NOTE: there are 4 groups of commands:
'(1) commands related to CreatorFile
'(2) commands related to CreatorFileList
'(3) commands related to CreatorProgramResourceFileText
'(4) other (CreatorCreateCommand)
'***CREATORFILE COMMANDS***
Private Sub CreatorSaveCommand_Click()
'on error resume next
Dim CreatorFile As String
Dim FilterDescriptionArray(1 To 1) As String
Dim FilterStringArray(1 To 1) As String
'
'NOTE: the names of the files to include in the
'ProgramResourceFile are saved in the 'CreatorFile'.
'
'preset
FilterDescriptionArray(1) = "CreatorFiles"
FilterStringArray(1) = "*.crf"
CreatorFile = CreatorFileLoaded
CreatorFile = GFCDSetFileName("Save CreatorFile...", 1, FilterDescriptionArray(), FilterStringArray(), 1, CreatorFile)
If CreatorFile = "" Then Exit Sub 'verify
If Not (LCase$(Right$(CreatorFile, 4)) = ".crf") Then CreatorFile = CreatorFile + ".crf"
CreatorFileLoaded = CreatorFile
CreatorFileLoadedLabel.Caption = "Loaded: " + FixMaxLineLength(CreatorFile, 50) '50 tested
'verify
If (CreatorFileStructNumber = 0) Then _
If MsgBox("No resource files are set, save anyway ?", vbYesNo + vbQuestion) = vbNo Then Exit Sub
If Len(CreatorProgramResourceFileText.Text) = 0 Then _
If MsgBox("The ProgramResourceFile (output file) is not set, save anyway ?", vbYesNo + vbQuestion) = vbNo Then Exit Sub
'begin
Call CreatorFile_Write(CreatorFile, CreatorFileStructNumber, CreatorFileStructArray())
CreatorFileChangesExistingFlag = False 'reset
Exit Sub
End Sub
Private Sub CreatorLoadCommand_Click()
'on error resume next
Dim CreatorFile As String
Dim FilterDescriptionArray(1 To 1) As String
Dim FilterStringArray(1 To 1) As String
'
'NOTE: the names of the files to include in the
'ProgramResourceFile are saved in the 'CreatorFile'.
'
'preset
FilterDescriptionArray(1) = "CreatorFiles"
FilterStringArray(1) = "*.crf"
CreatorFile = CreatorFileLoaded
CreatorFile = GFCDGetFileName("Load CreatorFile...", 1, FilterDescriptionArray(), FilterStringArray(), 1, App.Path)
If (Dir(CreatorFile) = "") Or (Right$(CreatorFile, 1) = "\") Or (Len(CreatorFile) = 0) Then Exit Sub 'verify
CreatorFileLoaded = CreatorFile
CreatorFileLoadedLabel.Caption = "Loaded: " + FixMaxLineLength(CreatorFile, 50) '50 tested
'begin
Call CreatorFile_Read(CreatorFile, CreatorFileStructNumber, CreatorFileStructArray())
Call CreatorFileList_Reload(CreatorFileStructNumber, CreatorFileStructArray())
CreatorFileChangesExistingFlag = False 'reset
End Sub
'***END OF CREATORFILE COMMANDS***
'***CREATORFILELIST COMMANDS***
Private Sub CreatorFileAddCommand_Click()
'on error resume next
Dim AddFileName As String
'preset
If AddFileDirOld = "" Then
AddFileDirOld = App.Path 'preset
If Not (Right$(AddFileDirOld, 1) = "\") Then AddFileDirOld = AddFileDirOld + "\"
End If
AddFileName = GFCDGetFileName("Select file for ProgramResourceFile", 0, NULLARRAYSTRING(), NULLARRAYSTRING(), 0, AddFileDirOld)
If AddFileName = "" Then Exit Sub 'verify
If (Dir(AddFileName) = "") Or (Right$(AddFileName, 1) = "\") Or (Len(AddFileName) = 0) Then 'verify
MsgBox "Error: file '" + AddFileName + "' not found !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
AddFileDirOld = GetDirectoryName(AddFileName)
'begin
If Not (CreatorFileStructNumber = 32766) Then 'verify
CreatorFileStructNumber = CreatorFileStructNumber + 1
ReDim Preserve CreatorFileStructArray(1 To CreatorFileStructNumber) As CreatorFileStruct
CreatorFileStructArray(CreatorFileStructNumber).CreatorFileName = AddFileName
Else
MsgBox "internal error in CreatorFileAddCommand_Click: overflow !", vbOKOnly + vbExclamation
'should not happen
End If
Call CreatorFileList_Reload(CreatorFileStructNumber, CreatorFileStructArray())
CreatorFileChangesExistingFlag = True
End Sub
Private Sub CreatorDirAddCommand_Click()
'on error resume next
Dim AddDirName As String
Dim FileLoop As Integer
'preset
AddDirName = GFSelectDirectory(App.Path, "Select directory containing files to add:")
If AddDirName = "" Then Exit Sub 'verify
If Dir(AddDirName, vbDirectory) = "" Then
MsgBox "Directory not found: " + AddDirName + " !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
'verify
If Not (Right$(AddDirName, 1) = "\") Then AddDirName = AddDirName + "\" 'verify (important)
'begin
CreatorFile.Path = AddDirName
CreatorFile.Pattern = "*.*"
CreatorFile.Refresh
For FileLoop = 1 To CreatorFile.ListCount
If Not (CreatorFileStructNumber = 32766) Then 'verify
CreatorFileStructNumber = CreatorFileStructNumber + 1
ReDim Preserve CreatorFileStructArray(1 To CreatorFileStructNumber) As CreatorFileStruct
CreatorFileStructArray(CreatorFileStructNumber).CreatorFileName = _
AddDirName + CreatorFile.List(FileLoop ‑ 1)
Else
MsgBox "internal error in CreatorDirAddCommand_Click: overflow !", vbOKOnly + vbExclamation
Exit For 'should not happen
End If
Next FileLoop
Call CreatorFileList_Reload(CreatorFileStructNumber, CreatorFileStructArray())
CreatorFileChangesExistingFlag = True
End Sub
Private Sub CreatorFileRemoveCommand_Click()
'on error resume next
Dim ListLoop As Integer
'verify
If (CreatorFileList.ListIndex < 0) Or (CreatorFileList.ListIndex > (CreatorFileList.ListCount ‑ 1)) Then
MsgBox "Please select file to remove !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
'begin
For ListLoop = CreatorFileList.ListCount To 1 Step (‑1)
If CreatorFileList.Selected(ListLoop ‑ 1) = True Then
Call CreatorFileStruct_RemoveItem(ListLoop)
End If
Next ListLoop
Call CreatorFileList_Reload(CreatorFileStructNumber, CreatorFileStructArray())
CreatorFileChangesExistingFlag = True
End Sub
Private Sub CreatorReplaceCommand_Click()
'on error resume next
Dim ReplaceSourceString As String
Dim ReplaceTargetString As String
Dim StructLoop As Integer
'preset
ReplaceSourceString = InputBox("Please enter replace source string (non‑case sensitive):", "Replace", "")
If ReplaceSourceString = "" Then Exit Sub 'verify
ReplaceTargetString = InputBox("Please enter replace target string (non‑case sensitive):", "Replace", "")
If ReplaceTargetString = "" Then Exit Sub 'verify
'begin
For StructLoop = 1 To CreatorFileStructNumber
If Not (InStr(1, CreatorFileStructArray(StructLoop).CreatorFileName, ReplaceSourceString, vbTextCompare) = 0) Then
CreatorFileStructArray(StructLoop).CreatorFileName = _
Left$(CreatorFileStructArray(StructLoop).CreatorFileName, InStr(1, CreatorFileStructArray(StructLoop).CreatorFileName, ReplaceSourceString, vbTextCompare) ‑ 1) + _
ReplaceTargetString + _
Right$(CreatorFileStructArray(StructLoop).CreatorFileName, Len(CreatorFileStructArray(StructLoop).CreatorFileName) ‑ (InStr(1, CreatorFileStructArray(StructLoop).CreatorFileName, ReplaceSourceString, vbTextCompare) + Len(ReplaceSourceString)) + 1)
End If
Next StructLoop
Call CreatorFileList_Reload(CreatorFileStructNumber, CreatorFileStructArray())
CreatorFileChangesExistingFlag = True
End Sub
Private Sub CreatorCommentCommand_Click()
'on error resume next
Dim FileComment As String
Dim ListLoop As Integer
'
'NOTE: the length of a comment is limited to 256 chars.
'
'verify
If (CreatorFileList.ListIndex < 0) Or (CreatorFileList.ListIndex > (CreatorFileList.ListCount ‑ 1)) Then
MsgBox "Please select at least one file whose comment is to be changed !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
'begin
FileComment = InputBox("Enter comment for the current file(s)" + Chr$(13) + Chr$(10) + "(e.g. 'AVI videos', 'sounds'):", "Edit file comment", CreatorFileStructArray(CreatorFileList.ListIndex + 1).CreatorFileComment)
For ListLoop = 1 To CreatorFileList.ListCount
If CreatorFileList.Selected(ListLoop ‑ 1) = True Then
CreatorFileStructArray(ListLoop).CreatorFileComment = Left$(FileComment, 256)
End If
Next ListLoop
Call CreatorFileList_Reload(CreatorFileStructNumber, CreatorFileStructArray())
CreatorFileChangesExistingFlag = True
End Sub
'***END OF CREATORFILELIST COMMANDS***
'***CREATORPROGRAMRESOURCEFILETEXT COMMANDS***
Private Sub CreatorBrowseCommand_Click()
'on error resume next
Dim CreatorProgramResourceFile As String
Dim BrowseFile As String
'begin
CreatorProgramResourceFile = CreatorProgramResourceFileText.Text
BrowseFile = GFCDSetFileName("Set ProgramResourceFile to create...", 0, NULLARRAYSTRING(), NULLARRAYSTRING(), 0, CreatorProgramResourceFile)
If BrowseFile = "" Then Exit Sub 'verify
CreatorProgramResourceFileText.Text = BrowseFile
End Sub
'***END OF CREATORPROGRAMRESOURCEFILETEXT COMMANDS***
'***OTHER COMMANDS***
Private Sub CreatorCreateCommand_Click()
'on error resume next
Dim CreatorProgramResourceFile As String
Dim CreatorProgramResourceFileNumber As Integer
Dim StructLoop As Integer
'verify
CreatorProgramResourceFile = CreatorProgramResourceFileText.Text
If (Right$(CreatorProgramResourceFile, 1) = "\") Or (Len(CreatorProgramResourceFile) = 0) Then 'verify
MsgBox "Error: ProgramResourceFile (output file) '" + CreatorProgramResourceFile + "' is invalid !", vbOKOnly + vbExclamation
CreatorProgramResourceFileText.SetFocus 'help user
Exit Sub 'error
End If
If Not (Dir(CreatorProgramResourceFile) = "") Then
Kill CreatorProgramResourceFile
End If
If Not (Dir(CreatorProgramResourceFile) = "") Then
MsgBox "Error deleting existing ProgramResourceFile '" + CreatorProgramResourceFile + "' !" + Chr$(10) + "Please make sure file can be deleted any try again.", vbOKOnly + vbExclamation
Exit Sub 'error
Else
'NOTE: CreatorProgramResourceFile must be already existing and it should be enpty.
CreatorProgramResourceFileNumber = FreeFile(0)
Open CreatorProgramResourceFile For Output As #CreatorProgramResourceFileNumber
Close #CreatorProgramResourceFileNumber
End If
'begin
For StructLoop = 1 To CreatorFileStructNumber
ReDo:
CreatorStatusLabel.Caption = "Packing: " + FixMaxLineLength(CreatorFileStructArray(StructLoop).CreatorFileName, 128) '128 tested, Label size tested
CreatorStatusLabel.Refresh 'important
If Not ((Dir(CreatorFileStructArray(StructLoop).CreatorFileName) = "") Or (Right$(CreatorFileStructArray(StructLoop).CreatorFileName, 1) = "\") Or (Len(CreatorFileStructArray(StructLoop).CreatorFileName) = 0)) Then 'verify
Call SPACKSfrm.SPACKType_Apply(1, CreatorProgramResourceFile, CreatorFileStructArray(StructLoop).CreatorFileName + " /%winsysdir%") '1 for SPACK_TYPE_FILEPACK, %winsysdir% is NOT the target directory of the packed files, it is kust used to avoid a password request
Else
CreatorStatusLabel.Caption = CreatorStatusLabel.Caption + " " + "ERROR"
CreatorStatusLabel.Refresh 'important
Select Case MsgBox("Error: file '" + CreatorFileStructArray(StructLoop).CreatorFileName + "' not found !", vbAbortRetryIgnore)
Case vbAbort
MsgBox "Note: you can use the Replace funtion to easily change source file names.", vbOKOnly + vbExclamation
Exit Sub
Case vbRetry
GoTo ReDo:
Case vbIgnore
'do nothing (file will go to hell)
End Select
End If
Next StructLoop
CreatorStatusLabel.Caption = "ProgramResourceFile " + CreatorProgramResourceFile + " created (maybe)."
CreatorStatusLabel.Refresh
Exit Sub
End Sub
'***END OF OTHER COMMANDS***
'*********************************END OF COMMAND CLICKS*********************************
'**************************************CREATORFILE**************************************
'NOTE: the whole stuff that was once entered can be saved in the CreatorFile so that
'we don't need to enter it again next time we reboot the computer.
Private Sub CreatorFile_Write(ByVal CreatorFile As String, ByRef CreatorFileStructNumber As Integer, ByRef CreatorFileStructArray() As CreatorFileStruct)
'on error resume next
Dim CreatorFileNumber As Integer
Dim StructLoop As Integer
'
'NOTE: the format of a CreateFile is the following:
'CREATORFILE
'CreatorProgramResourceFile
'[CreatorFileName1]
'[CreatorFileComment1]
'[CreatorFileName2]
'[CreatorFileComment2]
'[...]
'
'preset
CreatorFileNumber = FreeFile(0)
'begin
Open CreatorFile For Output As #CreatorFileNumber
Print #CreatorFileNumber, "CREATORFILE"
Print #CreatorFileNumber, CreatorProgramResourceFileText.Text
For StructLoop = 1 To CreatorFileStructNumber
Print #CreatorFileNumber, CreatorFileStructArray(StructLoop).CreatorFileName
Print #CreatorFileNumber, CreatorFileStructArray(StructLoop).CreatorFileComment
Next StructLoop
Close #CreatorFileNumber
End Sub
Private Sub CreatorFile_Read(ByVal CreatorFile As String, ByRef CreatorFileStructNumber As Integer, ByRef CreatorFileStructArray() As CreatorFileStruct)
On Error GoTo Error:
Dim CreatorFileNumber As Integer
Dim CreatorFileLine As String
'verify
If (Dir(CreatorFile) = "") Or (Right$(CreatorFile, 1) = "\") Or (Len(CreatorFile) = 0) Then 'verify
MsgBox "internal error in CreatorFile_Read(): file '" + CreatorFile + "' not found !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
'preset
CreatorFileNumber = FreeFile(0)
'begin
Open CreatorFile For Input As #CreatorFileNumber
Line Input #CreatorFileNumber, CreatorFileLine
If Not (CreatorFileLine = "CREATORFILE") Then
MsgBox "internal error in CreatorFile_Read(): file '" + CreatorFile + "' has an invalid format (first line is not 'CREATORFILE') !", vbOKOnly + vbExclamation
Exit Sub 'error
Else
'
Line Input #CreatorFileNumber, CreatorFileLine
CreatorProgramResourceFileText.Text = CreatorFileLine
'
CreatorFileStructNumber = 0 'reset
ReDim CreatorFileStructArray(1 To 1) As CreatorFileStruct
'
Do While Not (EOF(CreatorFileNumber) Or (Seek(CreatorFileNumber) > LOF(CreatorFileNumber)))
'
CreatorFileStructNumber = CreatorFileStructNumber + 1
ReDim Preserve CreatorFileStructArray(1 To CreatorFileStructNumber) As CreatorFileStruct
'
Line Input #1, CreatorFileLine
CreatorFileStructArray(CreatorFileStructNumber).CreatorFileName = CreatorFileLine
Line Input #1, CreatorFileLine
CreatorFileStructArray(CreatorFileStructNumber).CreatorFileComment = CreatorFileLine
'
Loop
End If
Close #CreatorFileNumber
Exit Sub
Error:
MsgBox "internal error in CreatorFile_Read(): VB returned: " + Err.Description, vbOKOnly + vbExclamation
Exit Sub
End Sub
'**********************************END OF CREATORFILE***********************************
'*****************************************OTHER*****************************************
Private Sub CreatorProgramResourceFileText_Change()
'on error resume next
CreatorFileChangesExistingFlag = True
End Sub
Private Sub CreatorFileList_Reload(ByRef CreatorFileStructNumber As Integer, ByRef CreatorFileStructArray() As CreatorFileStruct)
'on error resume next
Dim ListIndexOld As Integer
Dim StructLoop As Integer
'preset
ListIndexOld = CreatorFileList.ListIndex
'reset
CreatorFileList.Clear 'reset
'begin
For StructLoop = 1 To CreatorFileStructNumber
CreatorFileList.AddItem CreatorFileStructArray(StructLoop).CreatorFileName + _
String$(1, Chr$(32)) + "<" + CreatorFileStructArray(StructLoop).CreatorFileComment + ">" '< and > cannot be included within a Windows file name
Next StructLoop
Call GFListHScroll_AddScrollBars(CreatorFileList)
If Not ((ListIndexOld < 0) Or (ListIndexOld > (CreatorFileList.ListCount ‑ 1))) Then 'verify
CreatorFileList.Selected(ListIndexOld) = True
CreatorFileList.ListIndex = ListIndexOld
Else
If CreatorFileList.ListCount > 0 Then
CreatorFileList.Selected(CreatorFileList.ListCount ‑ 1) = True
CreatorFileList.ListIndex = (CreatorFileList.ListCount ‑ 1)
End If
End If
End Sub
Private Sub CreatorFileStruct_RemoveItem(ByVal ItemIndex As Integer)
'on error resume next
Dim StructLoop As Integer
'verify
If (ItemIndex < 1) Or (ItemIndex > CreatorFileStructNumber) Then
MsgBox "internal error in CreatorFileStruct_RemoveItem(): passed value invalid !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
'begin
For StructLoop = ItemIndex To CreatorFileStructNumber
If Not (StructLoop = CreatorFileStructNumber) Then
CreatorFileStructArray(StructLoop) = CreatorFileStructArray(StructLoop + 1)
Else
CreatorFileStructNumber = CreatorFileStructNumber ‑ 1
StructLoop = CreatorFileStructNumber 'StructLoop not used anymore
If StructLoop < 1 Then StructLoop = 1
ReDim Preserve CreatorFileStructArray(1 To StructLoop) As CreatorFileStruct
Exit For 'important
End If
Next StructLoop
Exit Sub
End Sub
'*************************************END OF OTHER**************************************
'***********************************GENERAL FUNCTIONS***********************************
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 (i.e. 'Windows' for C:\Windows\)
BROWSEINFOVar.lpszTitle = InfoText
BROWSEINFOVar.ulFlags = BIF_RETURNONLYFSDIRS 'file system directories only
BROWSEINFOVar.lpfn = 0 'address of event callback function
BROWSEINFOVar.lParam = 0 'parameter that would be passed to event callback 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 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 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 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 GetFileName(ByVal GetFileNameName As String) As String 'also used by Hmod.KeyHook_Open()
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 FixMaxLineLength(ByVal Line As String, ByVal Length As Integer) As String
On Error Resume Next
If Length < 3 Then Length = 3 'otherwise error
If Len(Line) > Length Then
FixMaxLineLength = String$(3, ".") + Right$(Line, Length ‑ 3)
Else
FixMaxLineLength = Line
End If
End Function
Private Sub Form_Unload(Cancel As Integer)
'on error resume next
If CreatorFileChangesExistingFlag = True Then
If MsgBox("There are unsaved changes existing, exit anyway ?", vbYesNo + vbQuestion + vbDefaultButton2) = vbNo Then
Cancel = True
Exit Sub
End If
End If
End 'important
End Sub
[END OF FILE]