From e1053de60a0a122c12525ca8fe25840522a94780 Mon Sep 17 00:00:00 2001 From: Paul Trowbridge Date: Thu, 10 Jul 2025 21:59:33 -0400 Subject: [PATCH] refactor some logic --- TheBigOne.cls | 248 +++++++++++++++++++++++++++++++------------------- 1 file changed, 153 insertions(+), 95 deletions(-) diff --git a/TheBigOne.cls b/TheBigOne.cls index 9f4f538..ea10ec1 100644 --- a/TheBigOne.cls +++ b/TheBigOne.cls @@ -451,7 +451,7 @@ Sub SHTp_Dump(ByRef tbl() As String, ByRef sheet As String, ByRef row As Long, B Dim i As Integer i = 0 For i = 0 To UBound(NumFields()) - Call sh.Columns(NumFields(i) + 1).TextToColumns + Call sh.Columns(NumFields(i) + col).TextToColumns Next i End If @@ -869,8 +869,8 @@ On Error GoTo err_active '---------------get first recordset that has >0 column count-------------------- - If ADOo_rs(con_from).Fields.Count = 0 Then - Do Until ADOo_rs(con_from).Fields.Count <> 0 + If ADOo_rs(con_from).fields.Count = 0 Then + Do Until ADOo_rs(con_from).fields.Count <> 0 Set ADOo_rs(con_from) = ADOo_rs(con_from).NextRecordset() If ADOo_rs(con_from) Is Nothing Then Exit Do Loop @@ -898,7 +898,7 @@ On Error GoTo err_active '-------------Make sure number of fields same in both record sets-------------------- - If ADOo_rs(con_to).Fields.Count <> ADOo_rs(con_from).Fields.Count Then + If ADOo_rs(con_to).fields.Count <> ADOo_rs(con_from).fields.Count Then ADOo_errstring = "Field count in MoveRecords function not equal" ADOp_MoveRecords = False Exit Function @@ -913,14 +913,14 @@ On Error GoTo err_active While ADOo_rs(con_from).EOF = False rc = rc + 1 ADOo_rs(con_to).AddNew - For i = 0 To ADOo_rs(con_from).Fields.Count - 1 - If IsNull(ADOo_rs(con_from).Fields(i)) Then - ADOo_rs(con_to).Fields(i) = "" + For i = 0 To ADOo_rs(con_from).fields.Count - 1 + If IsNull(ADOo_rs(con_from).fields(i)) Then + ADOo_rs(con_to).fields(i) = "" Else If trim Then - ADOo_rs(con_to).Fields(i) = LTrim(RTrim(ADOo_rs(con_from).Fields(i))) + ADOo_rs(con_to).fields(i) = LTrim(RTrim(ADOo_rs(con_from).fields(i))) Else - ADOo_rs(con_to).Fields(i) = ADOo_rs(con_from).Fields(i) + ADOo_rs(con_to).fields(i) = ADOo_rs(con_from).fields(i) End If End If Next i @@ -951,7 +951,7 @@ err_inactive: err_active: If Err.Number <> 0 Then - ADOo_errstring = ADOo_errstring & vbCrLf & Err.Description & " at field =" & ADOo_rs(con_from).Fields(i).Name & " record " & rc + ADOo_errstring = ADOo_errstring & vbCrLf & Err.Description & " at field =" & ADOo_rs(con_from).fields(i).Name & " record " & rc ADOp_MoveRecords = False ADOo_con(con_to).RollbackTrans ADOo_rs(con_to).Close @@ -1015,8 +1015,8 @@ Private Function ADOp_ExtractRecordsetS(ByRef con As Integer, ByRef trim As Bool 'size table Dim table() As String - If ADOo_rs(con).Fields.Count = 0 Then - Do Until ADOo_rs(con).Fields.Count <> 0 + If ADOo_rs(con).fields.Count = 0 Then + Do Until ADOo_rs(con).fields.Count <> 0 Set ADOo_rs(con) = ADOo_rs(con).NextRecordset() If ADOo_rs(con) Is Nothing Then Exit Do Loop @@ -1026,17 +1026,17 @@ Private Function ADOp_ExtractRecordsetS(ByRef con As Integer, ByRef trim As Bool ADOp_ExtractRecordsetS = table Exit Function Else - ReDim table(ADOo_rs(con).Fields.Count - 1, Size) + ReDim table(ADOo_rs(con).fields.Count - 1, Size) End If Else - ReDim table(ADOo_rs(con).Fields.Count - 1, Size) + ReDim table(ADOo_rs(con).fields.Count - 1, Size) End If 'populate headers if requested If headers Then i = 0 While i <= UBound(table, 1) - table(i, 0) = ADOo_rs(con).Fields(i).Name + table(i, 0) = ADOo_rs(con).fields(i).Name i = i + 1 Wend End If @@ -1052,14 +1052,14 @@ Private Function ADOp_ExtractRecordsetS(ByRef con As Integer, ByRef trim As Bool While ADOo_rs(con).EOF = False j = 0 While j <= (UBound(table, 1)) - If IsNull(ADOo_rs(con).Fields(j)) Then + If IsNull(ADOo_rs(con).fields(j)) Then table(j, i) = "" Else On Error Resume Next If trim Then - table(j, i) = LTrim(RTrim(ADOo_rs(con).Fields(j))) + table(j, i) = LTrim(RTrim(ADOo_rs(con).fields(j))) Else - table(j, i) = ADOo_rs(con).Fields(j) + table(j, i) = ADOo_rs(con).fields(j) End If If Err.Number <> 0 Then table(j, i) = "Error:" & Err.Number On Error GoTo err_active @@ -1076,7 +1076,7 @@ Private Function ADOp_ExtractRecordsetS(ByRef con As Integer, ByRef trim As Bool err_active: If Err.Number <> 0 Then - ADOo_errstring = ADOo_errstring & vbCrLf & Err.Description & " at field =" & ADOo_rs(con).Fields(j).Name & " record " & i + ADOo_errstring = ADOo_errstring & vbCrLf & Err.Description & " at field =" & ADOo_rs(con).fields(j).Name & " record " & i ReDim table(0, 0) table(0, 0) = ADOo_errstring ADOp_ExtractRecordsetS = table @@ -1733,62 +1733,82 @@ End Function Function FILEp_CreateCSV(ByRef path As String, ByRef recs() As String) As Boolean - + Dim i As Long Dim j As Long - Dim t() As String Dim wl As String Dim test_empty As String Dim tsf As New ADODB.Stream - + Dim field As String + On Error GoTo errh - -' Dim f As New Scripting.FileSystemObject -' Dim ts As Scripting.TextStream -' Set ts = f.CreateTextFile(path, True, True) -' ts.Close - - + tsf.Type = 2 - 'tsf.Charset = "utf-8" tsf.Charset = "Windows-1252" tsf.Open - - 'Set ts = f.OpenTextFile(path, ForReading, False, TristateUseDefault) - + i = 0 While i <= UBound(recs, 2) + test_empty = "" + wl = "" + For j = 0 To UBound(recs, 1) + field = EscapeCSVField(recs(j, i)) If j = 0 Then - test_empty = Replace(Replace(recs(j, i), ",", ""), """", "") - wl = Replace(Replace(recs(j, i), ",", ""), """", "") + wl = field + test_empty = trim(recs(j, i)) Else - test_empty = test_empty & Replace(Replace(recs(j, i), ",", ""), """", "") - wl = wl & "," & Replace(Replace(recs(j, i), ",", ""), """", "") + wl = wl & "," & field + test_empty = test_empty & trim(recs(j, i)) End If Next j + If Len(test_empty) > 0 Then If i = 0 Then - Call tsf.WriteText(wl) + tsf.WriteText wl Else - wl = vbCrLf & wl - Call tsf.WriteText(wl) + tsf.WriteText vbCrLf & wl End If End If + i = i + 1 Wend - Call tsf.SaveToFile(path, adSaveCreateOverWrite) - + + tsf.SaveToFile path, adSaveCreateOverWrite + + FILEp_CreateCSV = True + Exit Function + errh: - If Err.Number = 0 Then - FILEp_CreateCSV = True - Else - MsgBox (Err.Description) - FILEp_CreateCSV = False - End If + MsgBox (Err.Description) + FILEp_CreateCSV = False End Function +Private Function EscapeCSVField(ByVal s As Variant) As String + ' Make sure s is a string even if Null or Empty + If IsNull(s) Or IsEmpty(s) Then + s = "" + Else + s = CStr(s) + End If + + Dim needsQuotes As Boolean + needsQuotes = (InStr(1, s, ",") > 0) _ + Or (InStr(1, s, """") > 0) _ + Or (InStr(1, s, vbCr) > 0) _ + Or (InStr(1, s, vbLf) > 0) + + If needsQuotes Then + s = Replace(s, """", """""") + EscapeCSVField = """" & s & """" + Else + EscapeCSVField = s + End If +End Function + + + Function FILEp_CreateTXT(ByRef path As String, ByRef recs() As String) As Boolean Dim i As Long @@ -1877,63 +1897,101 @@ errh: End Function Function FILEp_GetCSV(filepath As String) As String() - Dim fileNo As Integer Dim fileContent As String Dim fileLines() As String Dim dataArray() As String - Dim splitArray() As String - Dim rowCount As Long, colCount As Long + Dim parsed() As String + Dim rowCount As Long Dim i As Long, j As Long - Dim final() As String - - ' Get an available file number + Dim fields As Collection + Dim f As Variant + + ' === Read entire file === fileNo = FreeFile - - ' Open the file with the available file number - Open filepath For Input As fileNo - - ' Read the entire file content into a single string - fileContent = Input(LOF(fileNo), fileNo) - - ' Close the file - Close fileNo - - ' Split the file content into lines - fileLines = Split(fileContent, vbCrLf) - - ' Get the number of rows (lines) + Open filepath For Input As #fileNo + fileContent = Input(LOF(fileNo), #fileNo) + Close #fileNo + + ' === Split into lines (support CRLF or LF only) === + fileContent = Replace(fileContent, vbCrLf, vbLf) + fileContent = Replace(fileContent, vbCr, vbLf) + fileLines = Split(fileContent, vbLf) + rowCount = UBound(fileLines) - LBound(fileLines) - - ' Check if there are any lines in the file - If rowCount > 0 Then - ' Split the first line into columns (using comma as a delimiter) - dataArray = Split(fileLines(0), ",") - - ' Get the number of columns - colCount = UBound(dataArray) - LBound(dataArray) - - ' Redimension the dataArray to the appropriate size - ReDim dataArray(0 To rowCount, 0 To colCount) - - ' Loop through the lines and columns to populate the dataArray - For i = 0 To rowCount - ' Split the current line into columns - splitArray = Split(fileLines(i), ",") - - ' Loop through the columns - For j = 0 To colCount - ' Assign the values to the dataArray - dataArray(i, j) = splitArray(j) - Next j - Next i - FILEp_GetCSV = dataArray - Else - MsgBox "The file is empty or not available." + If rowCount < 0 Then + MsgBox "File is empty." + Exit Function End If - + + ' === First pass: count max columns === + Dim maxCols As Long + maxCols = 0 + For i = 0 To UBound(fileLines) + Set fields = ParseCSVLine(fileLines(i)) + If fields.Count > maxCols Then maxCols = fields.Count + Next i + + ' === Allocate array === + ReDim dataArray(0 To UBound(fileLines), 0 To maxCols - 1) + + ' === Second pass: fill array === + For i = 0 To UBound(fileLines) + Set fields = ParseCSVLine(fileLines(i)) + For j = 1 To fields.Count + dataArray(i, j - 1) = fields(j) + Next j + Next i + + FILEp_GetCSV = dataArray End Function +Private Function ParseCSVLine(ByVal line As String) As Collection + Dim fields As New Collection + Dim i As Long + Dim c As String + Dim token As String + Dim inQuotes As Boolean + + i = 1 + token = "" + inQuotes = False + + Do While i <= Len(line) + c = Mid$(line, i, 1) + + If inQuotes Then + If c = """" Then + If i < Len(line) And Mid$(line, i + 1, 1) = """" Then + ' Escaped quote + token = token & """" + i = i + 1 + Else + inQuotes = False + End If + Else + token = token & c + End If + Else + If c = """" Then + inQuotes = True + ElseIf c = "," Then + fields.Add token + token = "" + Else + token = token & c + End If + End If + + i = i + 1 + Loop + + fields.Add token + Set ParseCSVLine = fields +End Function + + + Public Function ADOp_Exec(ByRef con As Integer, ByVal sql As String, Optional ApproxSixe As Long, Optional InclHeaders As Boolean, Optional ByVal value As ADOinterface, Optional ConnectTo As String, Optional IntgrtdSec As Boolean, Optional UserName As String, Optional Password As String, Optional textconfigs As String) As Boolean On Error GoTo errflag