GFDataFile/Form1.frm
VERSION 5.00
Begin VB.Form Form1
Caption = "Form1"
ClientHeight = 3185
ClientLeft = 65
ClientTop = 351
ClientWidth = 4680
LinkTopic = "Form1"
ScaleHeight = 3185
ScaleWidth = 4680
StartUpPosition = 3 'Windows‑Standard
Begin VB.TextBox Text4
Height = 285
Left = 2160
TabIndex = 9
Top = 1380
Width = 1695
End
Begin VB.TextBox Text3
Height = 285
Left = 2160
TabIndex = 8
Top = 1080
Width = 1695
End
Begin VB.TextBox Text2
Height = 285
Left = 2160
TabIndex = 7
Top = 480
Width = 1695
End
Begin VB.TextBox Text1
Height = 285
Left = 2160
TabIndex = 6
Top = 180
Width = 1695
End
Begin VB.CommandButton Command2
Caption = "Write"
Height = 315
Left = 2520
TabIndex = 1
Top = 2640
Width = 1935
End
Begin VB.CommandButton Command1
Caption = "Read"
Height = 315
Left = 180
TabIndex = 0
Top = 2640
Width = 1935
End
Begin VB.Label Label4
Caption = "BackColor"
Height = 195
Left = 120
TabIndex = 5
Top = 1440
Width = 1935
End
Begin VB.Label Label3
Caption = "AutoRedraw"
Height = 195
Left = 120
TabIndex = 4
Top = 1140
Width = 1935
End
Begin VB.Label Label2
Caption = "AutoSize"
Height = 195
Left = 120
TabIndex = 3
Top = 540
Width = 1935
End
Begin VB.Label Label1
Caption = "AutoRedraw"
Height = 195
Left = 120
TabIndex = 2
Top = 240
Width = 1935
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'(c)2001 by Louis.
'GFDataFile
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)
'
'NOTE: GFDataFile is used to read/write a DataFile with the following
'format (example file content):
'
'[Colors] <‑GFDFHeadLine
'TextForeGround=200349 <‑GFDFCommandLine (consisting of command and value)
'TextBackGround=132443
'
'Every line in the DataFile has one of the GFDataFileLineTypes
'(listed below). The meaning of the GFDataFileLine[w/lParam]
'depends on this line type (type/meaning):
'
'HEADLINE: wParam: headline text, lParam: "" (ignored)
'COMMANDLINE: wParam: command, lParam: value
'
'NOTE: creating a DataFile works as follows (to do when inserting
'GFDataFile into the target project):
'
'‑define what will be written into DataFile by calling GFDataFileStruct_AddLine()
'‑set default values using GFDataFileStruct_SetValue()
'‑write/read DataFile using GFDataFile_[Write/Read]()
'‑get read values using GFDataFileStruct_GetValue()
'
'View sample code at bottom of this form for further information.
'
'NOTE: this code does not support multiple instances, either create an addition
'GFDataFileStructArray() or copy this code to multiple forms of the target project.
'
'GFDataFile
Private Const GFDATAFILE_LINETYPE_HEADLINE As Integer = 1
Private Const GFDATAFILE_LINETYPE_COMMANDLINE As Integer = 2
'GFDataFile
Private Type GFDataFileStruct
DataFileLineType As Integer
DataFileLinewParam As String
DataFileLinelParam As String
End Type
Dim GFDataFileStructNumber As Integer 'one structure 'copy' per DataFile line
Dim GFDataFileStructArray() As GFDataFileStruct
Dim DEBUG_DataFile As String 'NOT TO BE COPIED
'**************************************GFDATAFILE***************************************
'NOTE: use the GFDataFile code to quickly write/read DataFiles.
'Search general function source project for further information.
Private Sub GFDataFileStruct_Reset(ByRef GFDataFileStructArray() As GFDataFileStruct, ByRef GFDataFileStructNumber As Integer)
'on error resume next 'call before adding DataFile line to struct
GFDataFileStructNumber = 0
ReDim GFDataFileStructArray(1 To 1) As GFDataFileStruct
End Sub
Private Function GFDataFileStruct_AddLine(ByVal DataFileLineType As Integer, ByVal DataFileLinewParam As String, ByRef GFDataFileStructArray() As GFDataFileStruct, ByRef GFDataFileStructNumber As Integer) As Boolean
On Error GoTo Error: 'function returns True for success or False in case of any error (memory low)
If Not (GFDataFileStructNumber = 32767) Then 'verify (line number limited to 32767)
GFDataFileStructNumber = GFDataFileStructNumber + 1
Else
MsgBox "internal error in GFDataFileStruct_AddLine(): overflow !", vbOKOnly + vbExclamation
GFDataFileStruct_AddLine = False 'error
Exit Function 'error
End If
ReDim Preserve GFDataFileStructArray(1 To GFDataFileStructNumber) As GFDataFileStruct
GFDataFileStructArray(GFDataFileStructNumber).DataFileLineType = DataFileLineType
GFDataFileStructArray(GFDataFileStructNumber).DataFileLinewParam = DataFileLinewParam
GFDataFileStruct_AddLine = True 'ok
Exit Function
Error: 'i.e. memory low
'do not jump to error (error description displayed)
MsgBox "internal error in GFDataFileStruct_AddLine(): " + Left$(Err.Description, 512) + " !", vbOKOnly + vbExclamation
GFDataFileStruct_AddLine = False 'error
Exit Function
End Function
Private Function GFDataFileStruct_SetValue(ByVal DataFileCommand As String, ByVal DataFIleValue As String, ByRef GFDataFileStructArray() As GFDataFileStruct, ByVal GFDataFileStructNumber As Integer) As Boolean
'on error resume next 'function returns True for success or False in case of error (DataFileCommand not found within struct)
Dim Temp As Long
For Temp = 1 To GFDataFileStructNumber
'compare to GFDataFile_AllocateDataFileLine()
If GFDataFileStructArray(Temp).DataFileLinewParam = DataFileCommand Then
If GFDataFileStructArray(Temp).DataFileLineType = GFDATAFILE_LINETYPE_COMMANDLINE Then 'command mustn't be exchanged with head line
GFDataFileStructArray(Temp).DataFileLinelParam = DataFIleValue
GFDataFileStruct_SetValue = True 'ok
Exit Function 'ok
End If
End If
Next Temp
GFDataFileStruct_SetValue = False 'error (DataFileCommand not found within struct)
Exit Function 'error
End Function
Private Function GFDataFileStruct_GetValue(ByVal DataFileCommand As String, ByRef GFDataFileStructArray() As GFDataFileStruct, ByVal GFDataFileStructNumber As Integer) As String
'on error resume next 'sub will set DataFileValue
Dim Temp As Long
For Temp = 1 To GFDataFileStructNumber
'compare to GFDataFile_AllocateDataFileLine()
If GFDataFileStructArray(Temp).DataFileLinewParam = DataFileCommand Then
If GFDataFileStructArray(Temp).DataFileLineType = GFDATAFILE_LINETYPE_COMMANDLINE Then 'command mustn't be exchanged with head line
GFDataFileStruct_GetValue = GFDataFileStructArray(Temp).DataFileLinelParam
Exit Function 'ok
End If
End If
Next Temp
GFDataFileStruct_GetValue = "" 'reset (error)
Exit Function 'error
End Function
Private Function GFDataFile_Write(ByVal DataFile As String, ByRef GFDataFileStructArray() As GFDataFileStruct, ByRef GFDataFileStructNumber As Integer) As Boolean
On Error GoTo Error: 'returns True if DataFile has been completely written, False if not
Dim DataFileFileNumber As Integer
Dim DataFileLine As String
Dim DataFileLineType As Integer
Dim DataFileLineTypeOld As Integer
Dim Temp As Long
'preset
DataFileLineTypeOld = GFDATAFILE_LINETYPE_HEADLINE
DataFileFileNumber = FreeFile(0)
If DataFileFileNumber = 0 Then
MsgBox "internal error in GFDataFile_Write() !", vbOKOnly + vbExclamation
GFDataFile_Write = False 'error
Exit Function 'important
End If
'begin
If Not ((Right$(DataFile, 1) = "\") Or (DataFile = "")) Then 'verify
Open DataFile For Output As #DataFileFileNumber
For Temp = 1 To GFDataFileStructNumber
DataFileLineType = GFDataFileStructArray(Temp).DataFileLineType
DataFileLine = GFDataFile_GetDataFileLineFromDataFileStruct(GFDataFileStructArray(), Temp)
If (DataFileLineType = GFDATAFILE_LINETYPE_HEADLINE) And _
(Not (DataFileLineTypeOld = GFDATAFILE_LINETYPE_HEADLINE)) Then
Print #DataFileFileNumber, "" 'empty line before head line (of not at file start)
End If
Print #DataFileFileNumber, DataFileLine
DataFileLineTypeOld = DataFileLineType
Next Temp
Close #DataFileFileNumber
Else
MsgBox "internal error in GFDataFile_Write(): file '" + Left$(DataFile, 512) + "' not found !", vbOKOnly + vbExclamation
GFDataFile_Write = False 'error
Exit Function 'important
End If
GFDataFile_Write = True 'ok
Exit Function
Error: 'if disk space insufficient
Close #DataFileFileNumber 'make sure file is closed
'NOTE: do not jump to Error:
MsgBox "internal error in GFDataFile_Write(): " + Left$(Err.Description, 512) + " !", vbOKOnly + vbExclamation
GFDataFile_Write = False 'error
Exit Function
End Function
Private Function GFDataFile_GetDataFileLineFromDataFileStruct(ByRef GFDataFileStructArray() As GFDataFileStruct, ByVal GFDataFileStructNumberPointer As Integer) As String
'on error resume next
Dim Tempstr$
'verify
If (GFDataFileStructNumberPointer < 1) Or (GFDataFileStructNumberPointer > GFDataFileStructNumber) Then 'verify
GFDataFile_GetDataFileLineFromDataFileStruct = "" 'reset (error)
MsgBox "internal error in GFDataFile_GetDataFileLineFromDataFileStruct(): passed value invalid !", vbOKOnly + vbExclamation
Exit Function 'error
End If
'begin
Select Case GFDataFileStructArray(GFDataFileStructNumberPointer).DataFileLineType
Case GFDATAFILE_LINETYPE_HEADLINE
With GFDataFileStructArray(GFDataFileStructNumberPointer)
Tempstr$ = "[" + .DataFileLinewParam + "]" 'use short temporary var to increase speed
GFDataFile_GetDataFileLineFromDataFileStruct = Tempstr$
End With
Case GFDATAFILE_LINETYPE_COMMANDLINE
With GFDataFileStructArray(GFDataFileStructNumberPointer)
Tempstr$ = .DataFileLinewParam + "=" + .DataFileLinelParam
GFDataFile_GetDataFileLineFromDataFileStruct = Tempstr$
End With
Case Else
MsgBox "internal error in GFDataFile_GetDataFileLineFromDataFileStruct() !", vbOKOnly + vbExclamation
GFDataFile_GetDataFileLineFromDataFileStruct = "" 'reset (error)
End Select
End Function
Private Function GFDataFile_Read(ByVal DataFile As String, ByRef GFDataFileStructArray() As GFDataFileStruct, ByVal GFDataFileStructNumber As Integer) As Boolean
'on error resume next 'function returns True for success or False for error
Dim DataFileFileNumber As Integer
Dim DataFileLine As String
'preset
DataFileFileNumber = FreeFile(0)
If DataFileFileNumber = 0 Then 'verify
MsgBox "internal error in GFDataFile_Read() !", vbOKOnly + vbExclamation
GFDataFile_Read = False 'error
Exit Function 'error
End If
'begin
If Not ((Dir(DataFile) = "") Or (Right$(DataFile, 1) = "\") Or (DataFile = "")) Then 'verify
Open DataFile For Input As #DataFileFileNumber
Do While Not ((EOF(DataFileFileNumber)) Or (Seek(DataFileFileNumber) = LOF(DataFileFileNumber)))
Line Input #DataFileFileNumber, DataFileLine
Call GFDataFile_AllocateDataFileLine(DataFileLine, GFDataFileStructArray(), GFDataFileStructNumber)
Loop
Close #DataFileFileNumber
GFDataFile_Read = True 'ok
Exit Function 'ok
Else
MsgBox "internal error in GFDataFile_Read(): file '" + Left$(DataFile, 512) + "' not found !", vbOKOnly + vbExclamation
GFDataFile_Read = False 'error
Exit Function 'error
End If
End Function
Private Sub GFDataFile_AllocateDataFileLine(ByVal DataFileLine As String, ByRef GFDataFileStructArray() As GFDataFileStruct, ByVal GFDataFileStructNumber As Integer)
'on error resume next 'allocates a DataFile value for related command
Dim DataFileCommand As String
Dim DataFIleValue As String
Dim Temp As Long
Dim Temp2 As Long
'begin
Temp = InStr(1, DataFileLine, "=", vbBinaryCompare)
Select Case Temp
Case 0
Exit Sub 'nothing to allocate
Case Else
DataFileCommand = Left$(DataFileLine, Temp ‑ 1)
DataFIleValue = Right$(DataFileLine, Len(DataFileLine) ‑ Temp)
Select Case Len(DataFileCommand)
Case 0
Exit Sub 'nothing to allocate
Case Else
For Temp2 = 1 To GFDataFileStructNumber
'compare to GFDataFile_GetLine()
If DataFileCommand = GFDataFileStructArray(Temp2).DataFileLinewParam Then
If GFDataFileStructArray(Temp2).DataFileLineType = GFDATAFILE_LINETYPE_COMMANDLINE Then 'command mustn't be exchanged with head line
GFDataFileStructArray(Temp2).DataFileLinelParam = DataFIleValue
Exit For 'important
End If
End If
Next Temp2
End Select
End Select
End Sub
'***********************************END OF GFDATAFILE***********************************
'***SAMPLE CODE (DO NOT COPY WITHOUT MANIPULATION)***
Private Sub Form_Load()
'on error resume next
Call DefineVars
Call DefineDataFile
End Sub
Private Sub Command1_Click()
'on error resume next 'read
Call DataFile_Read
End Sub
Private Sub Command2_Click()
'on error resume next 'write
Call DataFile_Write
End Sub
Private Sub DefineVars()
'on error resume next
DEBUG_DataFile = App.Path + "\" + "sample.txt" 'sample DataFile
End Sub
Private Sub DefineDataFile()
'on error resume next
Call GFDataFileStruct_Reset(GFDataFileStructArray(), GFDataFileStructNumber)
Call GFDataFileStruct_AddLine(GFDATAFILE_LINETYPE_HEADLINE, "Options", GFDataFileStructArray(), GFDataFileStructNumber)
Call GFDataFileStruct_AddLine(GFDATAFILE_LINETYPE_COMMANDLINE, "AutoRedraw", GFDataFileStructArray(), GFDataFileStructNumber)
Call GFDataFileStruct_AddLine(GFDATAFILE_LINETYPE_COMMANDLINE, "AutoSize", GFDataFileStructArray(), GFDataFileStructNumber)
Call GFDataFileStruct_AddLine(GFDATAFILE_LINETYPE_HEADLINE, "Colors", GFDataFileStructArray(), GFDataFileStructNumber)
Call GFDataFileStruct_AddLine(GFDATAFILE_LINETYPE_COMMANDLINE, "ForeColor", GFDataFileStructArray(), GFDataFileStructNumber)
Call GFDataFileStruct_AddLine(GFDATAFILE_LINETYPE_COMMANDLINE, "BackColor", GFDataFileStructArray(), GFDataFileStructNumber)
End Sub
Private Sub DataFile_Write()
'on error resume next
Call GFDataFileStruct_SetValue("AutoRedraw", Text1.Text, GFDataFileStructArray(), GFDataFileStructNumber)
Call GFDataFileStruct_SetValue("AutoSize", Text2.Text, GFDataFileStructArray(), GFDataFileStructNumber)
Call GFDataFileStruct_SetValue("ForeColor", Text3.Text, GFDataFileStructArray(), GFDataFileStructNumber)
Call GFDataFileStruct_SetValue("BackColor", Text4.Text, GFDataFileStructArray(), GFDataFileStructNumber)
Debug.Print GFDataFile_Write(DEBUG_DataFile, GFDataFileStructArray(), GFDataFileStructNumber)
End Sub
Private Sub DataFile_Read()
'on error resume next
Debug.Print GFDataFile_Read(DEBUG_DataFile, GFDataFileStructArray(), GFDataFileStructNumber)
Text1.Text = GFDataFileStruct_GetValue("AutoRedraw", GFDataFileStructArray(), GFDataFileStructNumber)
Text2.Text = GFDataFileStruct_GetValue("AutoSize", GFDataFileStructArray(), GFDataFileStructNumber)
Text3.Text = GFDataFileStruct_GetValue("ForeColor", GFDataFileStructArray(), GFDataFileStructNumber)
Text4.Text = GFDataFileStruct_GetValue("BackColor", GFDataFileStructArray(), GFDataFileStructNumber)
End Sub
[END OF FILE]