348 lines
14 KiB
QBasic
348 lines
14 KiB
QBasic
Attribute VB_Name = "iniSettings"
|
|
Private bSectionExists As Boolean
|
|
Private bKeyExists As Boolean
|
|
|
|
'---------------------------------------------------------------------------------------
|
|
' Procedure : Ini_ReadKeyVal
|
|
' Author : Daniel Pineault, CARDA Consultants Inc.
|
|
' Website : http://www.cardaconsultants.com
|
|
' Purpose : Read an Ini file's Key
|
|
' Copyright : The following may be altered and reused as you wish so long as the
|
|
' copyright notice is left unchanged (including Author, Website and
|
|
' Copyright). It may not be sold/resold or reposted on other sites (links
|
|
' back to this site are allowed).
|
|
' Req'd Refs: Uses Late Binding, so none required
|
|
' No APIs either! 100% VBA
|
|
'
|
|
' Input Variables:
|
|
' ~~~~~~~~~~~~~~~~
|
|
' sIniFile : Full path and filename of the ini file to read
|
|
' sSection : Ini Section to search for the Key to read the Key from
|
|
' sKey : Name of the Key to read the value of
|
|
'
|
|
' Usage:
|
|
' ~~~~~~
|
|
' ? Ini_Read(Application.CurrentProject.Path & "\MyIniFile.ini", "LINKED TABLES", "Path")
|
|
'
|
|
' Revision History:
|
|
' Rev Date(yyyy/mm/dd) Description
|
|
' **************************************************************************************
|
|
' 1 2012-08-09 Initial Release
|
|
'---------------------------------------------------------------------------------------
|
|
Function Ini_ReadKeyVal(ByVal sIniFile As String, _
|
|
ByVal sSection As String, _
|
|
ByVal sKey As String) As String
|
|
On Error GoTo Error_Handler
|
|
Dim sIniFileContent As String
|
|
Dim aIniLines() As String
|
|
Dim sLine As String
|
|
Dim i As Long
|
|
|
|
sIniFileContent = ""
|
|
bSectionExists = False
|
|
bKeyExists = False
|
|
|
|
'Validate that the file actually exists
|
|
If FileExist(sIniFile) = False Then
|
|
MsgBox "The specified ini file: " & vbCrLf & vbCrLf & _
|
|
sIniFile & vbCrLf & vbCrLf & _
|
|
"could not be found.", vbCritical + vbOKOnly, "File not found"
|
|
GoTo Error_Handler_Exit
|
|
End If
|
|
|
|
sIniFileContent = ReadFile(sIniFile) 'Read the file into memory
|
|
aIniLines = Split(sIniFileContent, vbCrLf)
|
|
For i = 0 To UBound(aIniLines)
|
|
sLine = Trim(aIniLines(i))
|
|
If bSectionExists = True And Left(sLine, 1) = "[" And Right(sLine, 1) = "]" Then
|
|
Exit For 'Start of a new section
|
|
End If
|
|
If sLine = "[" & sSection & "]" Then
|
|
bSectionExists = True
|
|
End If
|
|
If bSectionExists = True Then
|
|
If Len(sLine) > Len(sKey) Then
|
|
If Left(sLine, Len(sKey) + 1) = sKey & "=" Then
|
|
bKeyExists = True
|
|
Ini_ReadKeyVal = Mid(sLine, InStr(sLine, "=") + 1)
|
|
End If
|
|
End If
|
|
End If
|
|
Next i
|
|
|
|
Error_Handler_Exit:
|
|
On Error Resume Next
|
|
Exit Function
|
|
|
|
Error_Handler:
|
|
'Err.Number = 75 'File does not exist, Permission issues to write is denied,
|
|
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
|
|
"Error Number: " & Err.Number & vbCrLf & _
|
|
"Error Source: Ini_ReadKeyVal" & vbCrLf & _
|
|
"Error Description: " & Err.Description & _
|
|
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
|
|
, vbOKOnly + vbCritical, "An Error has Occured!"
|
|
Resume Error_Handler_Exit
|
|
End Function
|
|
|
|
'---------------------------------------------------------------------------------------
|
|
' Procedure : Ini_WriteKeyVal
|
|
' Author : Daniel Pineault, CARDA Consultants Inc.
|
|
' Website : http://www.cardaconsultants.com
|
|
' Purpose : Writes a Key value to the specified Ini file's Section
|
|
' If the file does not exist, it will be created
|
|
' If the Section does not exist, it will be appended to the existing content
|
|
' If the Key does not exist, it will be appended to the existing Section content
|
|
' Copyright : The following may be altered and reused as you wish so long as the
|
|
' copyright notice is left unchanged (including Author, Website and
|
|
' Copyright). It may not be sold/resold or reposted on other sites (links
|
|
' back to this site are allowed).
|
|
' Req'd Refs: Uses Late Binding, so none required
|
|
' No APIs either! 100% VBA
|
|
'
|
|
' Input Variables:
|
|
' ~~~~~~~~~~~~~~~~
|
|
' sIniFile : Full path and filename of the ini file to edit
|
|
' sSection : Ini Section to search for the Key to edit
|
|
' sKey : Name of the Key to edit
|
|
' sValue : Value to associate to the Key
|
|
'
|
|
' Usage:
|
|
' ~~~~~~
|
|
' Call Ini_WriteKeyVal(Application.CurrentProject.Path & "\MyIniFile.ini", "LINKED TABLES", "Paths", "D:\")
|
|
'
|
|
' Revision History:
|
|
' Rev Date(yyyy/mm/dd) Description
|
|
' **************************************************************************************
|
|
' 1 2012-08-09 Initial Release
|
|
'---------------------------------------------------------------------------------------
|
|
Function Ini_WriteKeyVal(ByVal sIniFile As String, _
|
|
ByVal sSection As String, _
|
|
ByVal sKey As String, _
|
|
ByVal sValue As String) As Boolean
|
|
On Error GoTo Error_Handler
|
|
Dim sIniFileContent As String
|
|
Dim aIniLines() As String
|
|
Dim sLine As String
|
|
Dim sNewLine As String
|
|
Dim i As Long
|
|
Dim bFileExist As Boolean
|
|
Dim bInSection As Boolean
|
|
Dim bKeyAdded As Boolean
|
|
|
|
sIniFileContent = ""
|
|
bSectionExists = False
|
|
bKeyExists = False
|
|
|
|
'Validate that the file actually exists
|
|
If FileExist(sIniFile) = False Then
|
|
GoTo SectionDoesNotExist
|
|
End If
|
|
bFileExist = True
|
|
|
|
sIniFileContent = ReadFile(sIniFile) 'Read the file into memory
|
|
aIniLines = Split(sIniFileContent, vbCrLf) 'Break the content into individual lines
|
|
sIniFileContent = "" 'Reset it
|
|
For i = 0 To UBound(aIniLines) 'Loop through each line
|
|
sNewLine = ""
|
|
sLine = Trim(aIniLines(i))
|
|
If sLine = "[" & sSection & "]" Then
|
|
bSectionExists = True
|
|
bInSection = True
|
|
End If
|
|
If bInSection = True Then
|
|
If sLine <> "[" & sSection & "]" _
|
|
And Left(sLine, 1) = "[" And Right(sLine, 1) = "]" Then
|
|
'Our section exists, but the key wasn't found, so append it
|
|
bInSection = False ' we're switching section
|
|
End If
|
|
If Len(sLine) > Len(sKey) Then
|
|
If Left(sLine, Len(sKey) + 1) = sKey & "=" Then
|
|
sNewLine = sKey & "=" & sValue
|
|
bKeyExists = True
|
|
bKeyAdded = True
|
|
End If
|
|
End If
|
|
End If
|
|
If Len(sIniFileContent) > 0 Then sIniFileContent = sIniFileContent & vbCrLf
|
|
If sNewLine = "" Then
|
|
sIniFileContent = sIniFileContent & sLine
|
|
Else
|
|
sIniFileContent = sIniFileContent & sNewLine
|
|
End If
|
|
Next i
|
|
|
|
SectionDoesNotExist:
|
|
'if not found, add it to the end
|
|
If bSectionExists = False Then
|
|
If Len(sIniFileContent) > 0 Then sIniFileContent = sIniFileContent & vbCrLf
|
|
sIniFileContent = sIniFileContent & "[" & sSection & "]"
|
|
End If
|
|
If bKeyAdded = False Then
|
|
sIniFileContent = sIniFileContent & vbCrLf & sKey & "=" & sValue
|
|
End If
|
|
|
|
'Write to the ini file the new content
|
|
Call OverwriteTxt(sIniFile, sIniFileContent)
|
|
Ini_WriteKeyVal = True
|
|
|
|
Error_Handler_Exit:
|
|
On Error Resume Next
|
|
Exit Function
|
|
|
|
Error_Handler:
|
|
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
|
|
"Error Number: " & Err.Number & vbCrLf & _
|
|
"Error Source: Ini_WriteKeyVal" & vbCrLf & _
|
|
"Error Description: " & Err.Description & _
|
|
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
|
|
, vbOKOnly + vbCritical, "An Error has Occured!"
|
|
Resume Error_Handler_Exit
|
|
End Function
|
|
|
|
'---------------------------------------------------------------------------------------
|
|
' Procedure : FileExist
|
|
' DateTime : 2007-Mar-06 13:51
|
|
' Author : CARDA Consultants Inc.
|
|
' Website : http://www.cardaconsultants.com
|
|
' Purpose : Test for the existance of a file; Returns True/False
|
|
'
|
|
' Input Variables:
|
|
' ~~~~~~~~~~~~~~~~
|
|
' strFile - name of the file to be tested for including full path
|
|
'---------------------------------------------------------------------------------------
|
|
Function FileExist(strFile As String) As Boolean
|
|
On Error GoTo Err_Handler
|
|
|
|
FileExist = False
|
|
If Len(Dir(strFile)) > 0 Then
|
|
FileExist = True
|
|
End If
|
|
|
|
Exit_Err_Handler:
|
|
Exit Function
|
|
|
|
Err_Handler:
|
|
MsgBox "The following error has occured." & vbCrLf & vbCrLf & _
|
|
"Error Number: " & Err.Number & vbCrLf & _
|
|
"Error Source: FileExist" & vbCrLf & _
|
|
"Error Description: " & Err.Description, _
|
|
vbCritical, "An Error has Occured!"
|
|
GoTo Exit_Err_Handler
|
|
End Function
|
|
|
|
'---------------------------------------------------------------------------------------
|
|
' Procedure : OverwriteTxt
|
|
' Author : Daniel Pineault, CARDA Consultants Inc.
|
|
' Website : http://www.cardaconsultants.com
|
|
' Purpose : Output Data to an external file (*.txt or other format)
|
|
' ***Do not forget about access' DoCmd.OutputTo Method for
|
|
' exporting objects (queries, report,...)***
|
|
' Will overwirte any data if the file already exists
|
|
' Copyright : The following may be altered and reused as you wish so long as the
|
|
' copyright notice is left unchanged (including Author, Website and
|
|
' Copyright). It may not be sold/resold or reposted on other sites (links
|
|
' back to this site are allowed).
|
|
'
|
|
' Input Variables:
|
|
' ~~~~~~~~~~~~~~~~
|
|
' sFile - name of the file that the text is to be output to including the full path
|
|
' sText - text to be output to the file
|
|
'
|
|
' Usage:
|
|
' ~~~~~~
|
|
' Call OverwriteTxt("C:\Users\Vance\Documents\EmailExp2.txt", "Text2Export")
|
|
'
|
|
' Revision History:
|
|
' Rev Date(yyyy/mm/dd) Description
|
|
' **************************************************************************************
|
|
' 1 2012-Jul-06 Initial Release
|
|
'---------------------------------------------------------------------------------------
|
|
Function OverwriteTxt(sFile As String, sText As String)
|
|
On Error GoTo Err_Handler
|
|
Dim FileNumber As Integer
|
|
|
|
FileNumber = FreeFile ' Get unused file number
|
|
Open sFile For Output As #FileNumber ' Connect to the file
|
|
Print #FileNumber, sText; ' Append our string
|
|
Close #FileNumber ' Close the file
|
|
|
|
Exit_Err_Handler:
|
|
Exit Function
|
|
|
|
Err_Handler:
|
|
MsgBox "The following error has occured." & vbCrLf & vbCrLf & _
|
|
"Error Number: " & Err.Number & vbCrLf & _
|
|
"Error Source: OverwriteTxt" & vbCrLf & _
|
|
"Error Description: " & Err.Description, _
|
|
vbCritical, "An Error has Occured!"
|
|
GoTo Exit_Err_Handler
|
|
End Function
|
|
|
|
'---------------------------------------------------------------------------------------
|
|
' Procedure : ReadFile
|
|
' Author : CARDA Consultants Inc.
|
|
' Website : http://www.cardaconsultants.com
|
|
' Purpose : Faster way to read text file all in RAM rather than line by line
|
|
' Copyright : The following may be altered and reused as you wish so long as the
|
|
' copyright notice is left unchanged (including Author, Website and
|
|
' Copyright). It may not be sold/resold or reposted on other sites (links
|
|
' back to this site are allowed).
|
|
' Input Variables:
|
|
' ~~~~~~~~~~~~~~~~
|
|
' strFile - name of the file that is to be read
|
|
'
|
|
' Usage Example:
|
|
' ~~~~~~~~~~~~~~~~
|
|
' MyTxt = ReadText("c:\tmp\test.txt")
|
|
' MyTxt = ReadText("c:\tmp\test.sql")
|
|
' MyTxt = ReadText("c:\tmp\test.csv")
|
|
'---------------------------------------------------------------------------------------
|
|
Function ReadFile(ByVal strFile As String) As String
|
|
On Error GoTo Error_Handler
|
|
Dim FileNumber As Integer
|
|
Dim sFile As String 'Variable contain file content
|
|
|
|
FileNumber = FreeFile
|
|
Open strFile For Binary Access Read As FileNumber
|
|
sFile = Space(LOF(FileNumber))
|
|
Get #FileNumber, , sFile
|
|
Close FileNumber
|
|
|
|
ReadFile = sFile
|
|
|
|
Error_Handler_Exit:
|
|
On Error Resume Next
|
|
Exit Function
|
|
|
|
Error_Handler:
|
|
MsgBox "The following error has occured." & vbCrLf & vbCrLf & _
|
|
"Error Number: " & Err.Number & vbCrLf & _
|
|
"Error Source: ReadFile" & vbCrLf & _
|
|
"Error Description: " & Err.Description, _
|
|
vbCritical, "An Error has Occured!"
|
|
Resume Error_Handler_Exit
|
|
End Function
|
|
|
|
Sub TestWriteKey()
|
|
test = Environ("APPDATA")
|
|
If Ini_WriteKeyVal(Environ("APPDATA") & "\GfSettings.ini", "Otlk", "OnlineArchiv", "\Onlinearchiv - stephan.maier@georgfischer.com\E-Mail Archiv") = True Then
|
|
MsgBox "The key was written"
|
|
Else
|
|
MsgBox "An error occured!"
|
|
End If
|
|
End Sub
|
|
|
|
Sub TestReadKey()
|
|
MsgBox "INI File: " & Application.CurrentProject.Path & "\MyIniFile.ini" & vbCrLf & _
|
|
"Section: SETTINGS" & vbCrLf & _
|
|
"Section Exist: " & bSectionExists & vbCrLf & _
|
|
"Key: License" & vbCrLf & _
|
|
"Key Exist: " & bKeyExists & vbCrLf & _
|
|
"Key Value: " & Ini_ReadKeyVal(Application.CurrentProject.Path & "\MyIniFile.ini", "SETTINGS", "License")
|
|
'You can validate the value by checking the bSectionExists and bKeyExists variable to ensure they were actually found in the ini file
|
|
End Sub
|
|
|
|
|
|
|