From VBA Word, the INI files (and Windows registry) can be accessed and modified through the VBA Object library function System.PrivateProfileString(). In VBA Excel, this library call is not available. To read INI files, one option is to employ the Windows API function GetPrivateProfileString Lib "kernel32". The other option is to write your own INI parser, which is what I did the other day.
Apart from the normal comments (comments start with # in this version of INI), the script also tolerates end-of-line comments.
The script also enforces unique section names by generating an error if a duplicate section name is detected. This is quite important as the script stores the INI data as key-value pairs, and the way it ensures unique key names is by prefixing section names to key names, with a dot separating the two.
The script also gives users the option of loading the generated data file to Teradata using the FastLoad utility.
Sample ini file:
# Author: Ram Limbu
# Date: 2009/11/28
#
#
#
[FILE_SETTINGS] # start of file settings
DestDir=C:\Documents and Settings\Ram_2\My Documents\Excel Projects\Config # don't end this line with slash
Delimiter=,
DestFileName=ErrorFiles.csv
[DATABASE_SETTINGS] # start of database settings
InsertData=Yes # Acceptable values: Yes or No
DbName=IPSHARE
TblName=RL_PP_Hist
DbUsername=cncra/RLIMBU
DbPw=secret
Option Explicit
Const MsgTitle As String = "Wooden Horse Pty Ltd"
Sub Batch_Err_Parser()
'//define constants
Const OldDelim As String = "|"
Const NewDefDelim As String = ","
Const Colon As String = ":"
Const BackSlash As String = "\"
'//define vars
Dim LastRow As Long
Dim Rec As String
Dim TimeStamp As String
Dim Msn As String
Dim RejCode As String
Dim RejMsg As String
Dim FileName As String
Dim DestDir As String
Dim DestFile As String
Dim NewDelim As String
Dim Identifier As String
Dim OrderNotes As String
Dim Status As String
Dim t1 As Double
Dim t2 As Double
Dim Rng As Range
Dim C As Range
Dim Arr As Variant
Dim ColonPos1 As Integer
Dim ColonPos2 As Integer
Dim TotPasses As Integer
Dim TotFails As Integer
Dim RecCtr As Long
Dim DatExists As Boolean
Dim fs As Object
Dim ts As Object
Dim ws As Worksheet
Dim INI_COL As New Collection
On Error GoTo Err_Rtn:
t1 = Timer
'// call initialization rtn
InitRtn
'//ensure that it is a batch error rpt
If Mid(Cells(1, 1), 3, 8) <> "RPT_OPOM" Then
If Not MsgBox("Is this Marketing Batch Error report?", vbYesNo + vbQuestion, MsgTitle) Then
Exit Sub
End If
End If
Set ws = ActiveSheet
'// find the last row
LastRow = ws.Cells(65536, 1).End(xlUp).Row
'// if there is no data, exit
If LastRow = 1 Then
MsgBox "Goodbye!", vbExclamation, MsgTitle
Exit Sub
End If
'// get ini data
If Rtn_Config_Col(INI_COL) <> 0 Then '// 0 = successful func call
Exit Sub
End If
'// read new delim from ini settings
NewDelim = INI_COL.Item("[FILE_SETTINGS].Delimiter")
If Trim(NewDelim) = "" Then
NewDelim = NewDefDelim
End If
'// read identifier
Identifier = INI_COL.Item("[FILE_SETTINGS].Identifier")
'// if headers are turned on, write them to data file
If UCase(INI_COL.Item("[FILE_SETTINGS].Headers")) = "ON" Then
Rec = "service_no" & NewDelim & "status" & NewDelim & "time_stamp" & NewDelim & _
"rej_code" & NewDelim & "rej_descript" & NewDelim & "identifier" & vbCrLf
End If
'// create the data range
Set Rng = ws.Cells(1, 1).Resize(LastRow)
'// loop the cells and parse the records
Application.DisplayStatusBar = True
For Each C In Rng
Status = Trim(Left(C, 4))
If Status = "PASS" Or Status = "FAIL" Then
RecCtr = RecCtr + 1
Application.StatusBar = "Processing record: " & RecCtr
If Status = "PASS" Then
TotPasses = TotPasses + 1
Else
TotFails = TotFails + 1
End If
If Status = "FAIL" Or (Status = "PASS" And UCase(INI_COL.Item("[FILE_SETTINGS].FailOnly")) <> "YES") Then
Arr = Split(C, OldDelim)
Msn = Right(Arr(4), 10)
ColonPos1 = InStr(1, Arr(6), Colon, vbTextCompare) ' find 1st position of colon
ColonPos2 = InStr(ColonPos1 + 1, Arr(6), Colon, vbTextCompare) ' find 2nd position of colon
RejCode = Trim(Mid(Arr(6), ColonPos1 + 1, ColonPos2 - ColonPos1 - 1)) ' extract rej code
RejMsg = Trim(Mid(Arr(6), ColonPos2 + 1, Len(Arr(6)))) ' extract rejection description
OrderNotes = Trim(Arr(7)) 'extract order notes
OrderNotes = Right(OrderNotes, Len(OrderNotes) - InStr(OrderNotes, Colon)) 'extract only aft colon
RejMsg = RejMsg & " " & OrderNotes
RejMsg = Left(RejMsg, 298) ' ensure that rejmsg is not more than 298 characters as db vartext field is 300 only
Rec = Rec & Msn & NewDelim & Arr(0) & NewDelim & TimeStamp & NewDelim & _
RejCode & NewDelim & RejMsg & NewDelim & Identifier & vbCrLf
DatExists = True
End If
ElseIf Status = "DATE" Then
TimeStamp = Right(C, 19)
ElseIf UCase(Left(C, 15)) = "INPUT FILE NAME" Then
FileName = Trim(Right(C, Len(C) - 16))
End If
DoEvents
Next C '// end of main loop
'// if error records exist, write them to a file
If DatExists Then
Application.StatusBar = "Writing to text file ..."
'// read dest folder and file details from ini setting collection
DestDir = INI_COL.Item("[FILE_SETTINGS].DestDir")
'// if there is no slash at the end of destination folder, put one there
If Right$(DestDir, 1) <> BackSlash Then
DestDir = DestDir & BackSlash
End If
DestFile = INI_COL.Item("[FILE_SETTINGS].DestFile")
If UCase(Trim(DestFile)) = "DEFAULT" Or Trim(DestFile) = "" Then '// if no filename has been supplied, name it after error file
If FileName <> "" Then '// ensure error report filename exists
DestFile = FileName
Else
MsgBox "Error: No valid destination file could be found. Exiting ...", vbOKOnly + vbInformation, MsgTitle
Exit Sub
End If
End If
Set fs = CreateObject("Scripting.FileSystemObject")
If fs.FolderExists(DestDir) Then
DestFile = DestDir & DestFile 'prepend dest dir
Set ts = fs.CreateTextFile(DestFile)
ts.Write Rec
ts.Close
Else
MsgBox DestDir & " doesn't exist or not accessible!", vbOKOnly + vbCritical, MsgTitle
Exit Sub
End If
'do clean up
Set fs = Nothing
Set ts = Nothing
Set ws = Nothing
'if the user has elected to write records to db, fastload them
If UCase(INI_COL.Item("[DATABASE_SETTINGS].InsertData")) = "YES" Then
'//ensure all other database setting values are provided
With INI_COL
If .Item("[DATABASE_SETTINGS].DbName") <> "" And .Item("[DATABASE_SETTINGS].TblName") <> "" & _
.Item("[DATABASE_SETTINGS].DbUsername") <> "" And .Item("[DATABASE_SETTINGS].DbPw") <> "" Then
DbRtn Db:=.Item("[DATABASE_SETTINGS].DbName"), Tbl:=.Item("[DATABASE_SETTINGS].TblName"), _
UsrNm:=.Item("[DATABASE_SETTINGS].DbUsername"), Pw:=.Item("[DATABASE_SETTINGS].DbPw"), _
InputFile:=DestFile, TargetDir:=DestDir, Start:=IIf(UCase(.Item("[FILE_SETTINGS].Headers")) = "ON", 2, 1), _
Delim:=NewDelim
Else
MsgBox "Since you didn't provide all required database settings, records were not " & vbCrLf _
& "written to database!", vbInformation + vbOKOnly, MsgTitle
End If
End With
End If
t2 = Timer
Application.StatusBar = "Done!"
MsgBox "Finito! Time taken = " & Format(t2 - t1, "##0.000") & " seconds" & vbCrLf _
& "Total Passes = " & TotPasses & vbCrLf _
& "Total Fails = " & TotFails & vbCrLf _
& "Total Records = " & TotPasses + TotFails, vbInformation + vbOKOnly, MsgTitle
End If
Application.StatusBar = ""
Exit Sub
Err_Rtn:
Application.StatusBar = ""
MsgBox Err.Description, vbInformation + vbOKOnly, MsgTitle
End Sub
Private Function Rtn_Config_Col(ByRef INI_COL As Collection) As Integer
Dim INI_File As String
Dim Rec As String
Dim SecName As String
Dim Kee As String
Dim val As String
Dim SubStrPos As Integer
Dim fs As Object
Dim f As Object
Dim flds As Object
Dim SecCol As New Collection
'// define some constants to make script more userfrieldly
Const READ_ONLY As Integer = 1
Const CommStr As String = "#"
Const Eq As String = "="
Const SecStart As String = "["
Const SecEnd As String = "]"
Const MinValLen As String = 3
Const Blank As String = ""
Set fs = CreateObject("WScript.Shell")
Set flds = fs.SpecialFolders
INI_File = flds("mydocuments") & "\Batch_Errors\Batch_Errors.ini"
Set fs = CreateObject("Scripting.FileSystemObject")
'//ensure ini file exists
If Not fs.FileExists(INI_File) Then
MsgBox "My Documements\Batch_Errors folder " & vbCrLf & _
"or INI file does not exist! Exiting ...", vbCritical + vbOKOnly, MsgTitle
Rtn_Config_Col = -1
End If
Set f = fs.OpenTextFile(INI_File, READ_ONLY)
'//read the ini file
Do Until f.AtEndOfStream
Rec = Trim(f.ReadLine)
'// ignore comments and blank lines
If Left(Rec, 1) <> CommStr And Rec <> Blank Then
'// check to see if there are comments at end of key-value pair
'// if so, take them out of current record
SubStrPos = InStr(2, Rec, CommStr)
If SubStrPos > 0 Then '// end of line comments exists
Rec = Trim(Left(Rec, SubStrPos - 1)) '// eliminate comments
End If
'//check for section name
If Left(Rec, 1) = SecStart Then
If Right(Rec, 1) = SecEnd And Len(Rec) >= MinValLen Then '// ensure it is valid section name
'ensure that there are no duplicate section names
SecName = Rec
On Error Resume Next
SecCol.Add SecName, SecName
If Err <> 0 Then
MsgBox "Error: The INI file has duplicate section names! Exiting ...", vbCritical + vbOKOnly, MsgTitle
Rtn_Config_Col = -1
End If
End If
Else
'// check if it is key-value pair
SubStrPos = InStr(2, Rec, Eq)
If SubStrPos > 0 And Len(Rec) >= MinValLen Then
'// insert key-value pair into collection
'// prepend section name to key name to make it unique
Kee = Left(Rec, SubStrPos - 1)
val = Trim(CleanData(Right(Rec, Len(Rec) - SubStrPos)))
Kee = Trim(CleanData(SecName & "." & Kee))
INI_COL.Add val, CStr(Kee)
End If
End If
End If
Loop
f.Close
Set fs = Nothing
Set flds = Nothing
Rtn_Config_Col = 0
End Function
Private Function CleanData(Data As String) As String
Dim i As Integer
For i = 0 To 31
While InStr(1, Data, Chr(i)) > 0
Data = Replace(Data, Chr(i), " ")
Wend
Next i
For i = 127 To 255
While InStr(1, Data, Chr(i)) > 0
Data = Replace(Data, Chr(i), " ")
Wend
Next i
CleanData = Data
End Function
Private Sub InitRtn()
'// in this routine, ensure that user has
'// Batch_Errors.ini file within Batch_Errors in My Documents folder. If not, create one
'// and inform user
Dim fso As Object
Dim fws As Object
Dim sfld As Object
Dim Rec As String
Dim txt_file_o As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set fws = CreateObject("WScript.Shell")
Set sfld = fws.SpecialFolders
If Not fso.FolderExists(sfld("mydocuments") & "\Batch_Errors") Then
'// create Batch_Errors folder
Application.StatusBar = "Creating " & sfld("mydocuments") & "\Batch_Errors"
fso.CreateFolder (sfld("mydocuments") & "\Batch_Errors")
Application.StatusBar = "Creating .ini file ..."
'// create ini file
Rec = "# This .ini file was created by batch error parser on " & Format(Now, "YYYY-MM-DD HH:MM:SS") & vbCrLf & "#" & vbCrLf
Rec = Rec & "# Comments start with the hash symbol (#), just like this line" & vbCrLf & "#" & vbCrLf & "#" & vbCrLf
Rec = Rec & "# start of file settings" & vbCrLf & vbCrLf
Rec = Rec & "[FILE_SETTINGS]" & vbCrLf & vbCrLf
Rec = Rec & "DestDir=" & sfld("mydocuments") & "\Batch_Errors" & vbCrLf
Rec = Rec & "Delimiter=, # leaving it blank will choose comma as default delimiter" & vbCrLf
Rec = Rec & "DestFile=default # the destination file name defaults to error report name" & vbCrLf
Rec = Rec & "Headers=On # On or Off" & vbCrLf
Rec = Rec & "Identifier= # write something descriptive to identify service numbers or leave blank" & vbCrLf
Rec = Rec & "FailOnly=No # Yes or No. If Yes, only services that returned rejections will be extracted" & vbCrLf & vbCrLf
Rec = Rec & "# start of database settings" & vbCrLf & vbCrLf
Rec = Rec & "# If you want the error report data to insert into a table, then provide appropriate values " & vbCrLf
Rec = Rec & "# for the following database settings, starting with 'InsertData'." & vbCrLf
Rec = Rec & "# *** Please, note: you need to create the required table as follows" & vbCrLf
Rec = Rec & "# before attempting to load data into it via this utility!" & vbCrLf
Rec = Rec & "#" & String(50, "-") & vbCrLf
Rec = Rec & "# CREATE SET TABLE DB_FOO.TBL_BAR (" & vbCrLf
Rec = Rec & "# service_no VARCHAR(20)" & vbCrLf
Rec = Rec & "# ,status VARCHAR(10)" & vbCrLf
Rec = Rec & "# ,tm_stamp VARCHAR(30)" & vbCrLf
Rec = Rec & "# ,rej_code VARCHAR(10)" & vbCrLf
Rec = Rec & "# ,rej_descript VARCHAR(300)" & vbCrLf
Rec = Rec & "# ,identifier VARCHAR(50)" & vbCrLf
Rec = Rec & "# ,open_dt DATE" & vbCrLf
Rec = Rec & "# ,close_dt VARCHAR(30)" & vbCrLf
Rec = Rec & "# ) PRIMARY INDEX (service_no);" & vbCrLf
Rec = Rec & "#" & String(50, "-") & vbCrLf & vbCrLf
Rec = Rec & "# Since the data get FastLoaded, you need to have FastLoad utility installed on your machine." & vbCrLf & vbCrLf
Rec = Rec & "[DATABASE_SETTINGS]" & vbCrLf & vbCrLf
Rec = Rec & "InsertData=No # Yes or No. To insert data into database, write 'Yes'" & vbCrLf
Rec = Rec & "DbName=xx_my_db # replace 'xx_my_db' with your database name, i.e. IPSHARE" & vbCrLf
Rec = Rec & "TblName=xx_my_tbl # replace 'xx_my_tbl' with your table name" & vbCrLf
Rec = Rec & "DbUsername=cncra/jdoe # replace 'cncra/jdoe' with your data source name/username" & vbCrLf
Rec = Rec & "DbPw=secret # replace 'secret' with your password"
Set txt_file_o = fso.CreateTextFile(sfld("mydocuments") & "\Batch_Errors\Batch_Errors.ini")
txt_file_o.Write Rec
txt_file_o.Close
Set txt_file_o = Nothing
Application.StatusBar = ""
End If
End Sub
Sub DbRtn(Db As String, Tbl As String, UsrNm As String, Pw As String, InputFile As String, TargetDir As String, Start As Integer, Delim As String)
'// this routine fastloads error records into named tables
Dim flScript As String
Dim fso As Object
Dim fo As Object
Dim ScriptInput As String
Dim ScriptOutput As String
Dim ShStatus As Double
Dim BatOut As String
'// start creating fastload script
flScript = "/* " & String(84, "+") & " */" & vbCrLf
flScript = flScript & "/* FASTLOAD SCRIPT CREATED BY BATCH ERROR PARSER */" & vbCrLf
flScript = flScript & "/* ON " & Format(Now, "YYYY-MM-DD hh:mm:ss") & " TO FASTLOAD BATCH ERROR DATA */" & vbCrLf
flScript = flScript & "/* " & String(84, "+") & " */" & vbCrLf
flScript = flScript & vbCrLf & "/* Setup FastLoad parameters */" & vbCrLf & vbCrLf
flScript = flScript & "SESSIONS 50;" & vbCrLf
flScript = flScript & "ERRLIMIT 50;" & vbCrLf
flScript = flScript & "LOGON " & UsrNm & ", " & Pw & ";" & vbCrLf
flScript = flScript & "SHOW VERSIONS;" & vbCrLf
flScript = flScript & "RECORD " & Start & ";" & vbCrLf
flScript = flScript & "SET RECORD VARTEXT """ & Delim & """ DISPLAY_ERRORS NOSTOP;" & vbCrLf & vbCrLf
flScript = flScript & "/* Define text file layout and input file */" & vbCrLf & vbCrLf
flScript = flScript & "DEFINE service_number (VARCHAR(20))" & vbCrLf
flScript = flScript & " ,status (VARCHAR(10))" & vbCrLf
flScript = flScript & " ,tm_stamp (VARCHAR(30))" & vbCrLf
flScript = flScript & " ,rej_code (VARCHAR(10))" & vbCrLf
flScript = flScript & " ,rej_descript (VARCHAR(300))" & vbCrLf
flScript = flScript & " ,identifier (VARCHAR(50)) " & vbCrLf
flScript = flScript & "FILE=" & InputFile & ";" & vbCrLf & vbCrLf
flScript = flScript & "SHOW;" & vbCrLf & vbCrLf
flScript = flScript & "BEGIN LOADING " & Db & "." & Tbl & vbCrLf
flScript = flScript & " ERRORFILES " & Db & ".Batch_Err1, " & Db & ".Batch_Err2" & vbCrLf
flScript = flScript & " CHECKPOINT 500;" & vbCrLf & vbCrLf
flScript = flScript & "INSERT INTO " & Db & "." & Tbl & " VALUES" & vbCrLf
flScript = flScript & " ( :service_number " & vbCrLf
flScript = flScript & " ,:status " & vbCrLf
flScript = flScript & " ,:tm_stamp " & vbCrLf
flScript = flScript & " ,:rej_code " & vbCrLf
flScript = flScript & " ,:rej_descript " & vbCrLf
flScript = flScript & " ,:identifier " & vbCrLf
flScript = flScript & " ,CURRENT_DATE " & vbCrLf
flScript = flScript & " ,'2899-12-31'); " & vbCrLf & vbCrLf
flScript = flScript & "END LOADING;" & vbCrLf
flScript = flScript & "LOGOFF;"
Set fso = CreateObject("Scripting.FileSystemObject")
ScriptInput = TargetDir & "FastLoadThis" & ".src"
ScriptOutput = TargetDir & "FastLoad_" & Format(Date, "YYYY_MM_DD") & ".log"
BatOut = TargetDir & "Batch_Errors.bat"
On Error Resume Next
Kill BatOut
Kill ScriptInput
On Error GoTo 0
Set fo = fso.CreateTextFile(ScriptInput)
fo.Write flScript
fo.Close
'//create bat file
flScript = "FastLoad < """ & ScriptInput & """ > """ & ScriptOutput & """ 2>&1"
Set fo = fso.CreateTextFile(BatOut)
fo.Write flScript
fo.Close
'do clean-up
Set fso = Nothing
Set fo = Nothing
'//start fastload
Call Shell(BatOut)
End Sub
