pt/VBA
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

refactor some logic

Browse Source
This commit is contained in:
Paul Trowbridge 2025-07-10 21:59:33 -04:00
parent 5928c83a24
commit e1053de60a
1 changed files with 153 additions and 95 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

248
TheBigOne.cls
View File

@ -451,7 +451,7 @@ Sub SHTp_Dump(ByRef tbl() As String, ByRef sheet As String, ByRef row As Long, B
Dim i As Integer Dim i As Integer
i = 0 i = 0
For i = 0 To UBound(NumFields()) For i = 0 To UBound(NumFields())
Call sh.Columns(NumFields(i) + 1).TextToColumns Call sh.Columns(NumFields(i) + col).TextToColumns
Next i Next i
End If End If
@ -869,8 +869,8 @@ On Error GoTo err_active
'---------------get first recordset that has >0 column count-------------------- '---------------get first recordset that has >0 column count--------------------
If ADOo_rs(con_from).Fields.Count = 0 Then If ADOo_rs(con_from).fields.Count = 0 Then
Do Until ADOo_rs(con_from).Fields.Count <> 0 Do Until ADOo_rs(con_from).fields.Count <> 0
Set ADOo_rs(con_from) = ADOo_rs(con_from).NextRecordset() Set ADOo_rs(con_from) = ADOo_rs(con_from).NextRecordset()
If ADOo_rs(con_from) Is Nothing Then Exit Do If ADOo_rs(con_from) Is Nothing Then Exit Do
Loop Loop
@ -898,7 +898,7 @@ On Error GoTo err_active
'-------------Make sure number of fields same in both record sets-------------------- '-------------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" ADOo_errstring = "Field count in MoveRecords function not equal"
ADOp_MoveRecords = False ADOp_MoveRecords = False
Exit Function Exit Function
@ -913,14 +913,14 @@ On Error GoTo err_active
While ADOo_rs(con_from).EOF = False While ADOo_rs(con_from).EOF = False
rc = rc + 1 rc = rc + 1
ADOo_rs(con_to).AddNew ADOo_rs(con_to).AddNew
For i = 0 To ADOo_rs(con_from).Fields.Count - 1 For i = 0 To ADOo_rs(con_from).fields.Count - 1
If IsNull(ADOo_rs(con_from).Fields(i)) Then If IsNull(ADOo_rs(con_from).fields(i)) Then
ADOo_rs(con_to).Fields(i) = "" ADOo_rs(con_to).fields(i) = ""
Else Else
If trim Then 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 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
End If End If
Next i Next i
@ -951,7 +951,7 @@ err_inactive:
err_active: err_active:
If Err.Number <> 0 Then 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 ADOp_MoveRecords = False
ADOo_con(con_to).RollbackTrans ADOo_con(con_to).RollbackTrans
ADOo_rs(con_to).Close ADOo_rs(con_to).Close
@ -1015,8 +1015,8 @@ Private Function ADOp_ExtractRecordsetS(ByRef con As Integer, ByRef trim As Bool
'size table 'size table
Dim table() As String Dim table() As String
If ADOo_rs(con).Fields.Count = 0 Then If ADOo_rs(con).fields.Count = 0 Then
Do Until ADOo_rs(con).Fields.Count <> 0 Do Until ADOo_rs(con).fields.Count <> 0
Set ADOo_rs(con) = ADOo_rs(con).NextRecordset() Set ADOo_rs(con) = ADOo_rs(con).NextRecordset()
If ADOo_rs(con) Is Nothing Then Exit Do If ADOo_rs(con) Is Nothing Then Exit Do
Loop Loop
@ -1026,17 +1026,17 @@ Private Function ADOp_ExtractRecordsetS(ByRef con As Integer, ByRef trim As Bool
ADOp_ExtractRecordsetS = table ADOp_ExtractRecordsetS = table
Exit Function Exit Function
Else Else
ReDim table(ADOo_rs(con).Fields.Count - 1, Size) ReDim table(ADOo_rs(con).fields.Count - 1, Size)
End If End If
Else Else
ReDim table(ADOo_rs(con).Fields.Count - 1, Size) ReDim table(ADOo_rs(con).fields.Count - 1, Size)
End If End If
'populate headers if requested 'populate headers if requested
If headers Then If headers Then
i = 0 i = 0
While i <= UBound(table, 1) 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 i = i + 1
Wend Wend
End If End If
@ -1052,14 +1052,14 @@ Private Function ADOp_ExtractRecordsetS(ByRef con As Integer, ByRef trim As Bool
While ADOo_rs(con).EOF = False While ADOo_rs(con).EOF = False
j = 0 j = 0
While j <= (UBound(table, 1)) While j <= (UBound(table, 1))
If IsNull(ADOo_rs(con).Fields(j)) Then If IsNull(ADOo_rs(con).fields(j)) Then
table(j, i) = "" table(j, i) = ""
Else Else
On Error Resume Next On Error Resume Next
If trim Then If trim Then
table(j, i) = LTrim(RTrim(ADOo_rs(con).Fields(j))) table(j, i) = LTrim(RTrim(ADOo_rs(con).fields(j)))
Else Else
table(j, i) = ADOo_rs(con).Fields(j) table(j, i) = ADOo_rs(con).fields(j)
End If End If
If Err.Number <> 0 Then table(j, i) = "Error:" & Err.Number If Err.Number <> 0 Then table(j, i) = "Error:" & Err.Number
On Error GoTo err_active On Error GoTo err_active
@ -1076,7 +1076,7 @@ Private Function ADOp_ExtractRecordsetS(ByRef con As Integer, ByRef trim As Bool
err_active: err_active:
If Err.Number <> 0 Then 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) ReDim table(0, 0)
table(0, 0) = ADOo_errstring table(0, 0) = ADOo_errstring
ADOp_ExtractRecordsetS = table ADOp_ExtractRecordsetS = table
@ -1733,62 +1733,82 @@ End Function
Function FILEp_CreateCSV(ByRef path As String, ByRef recs() As String) As Boolean Function FILEp_CreateCSV(ByRef path As String, ByRef recs() As String) As Boolean
Dim i As Long Dim i As Long
Dim j As Long Dim j As Long
Dim t() As String
Dim wl As String Dim wl As String
Dim test_empty As String Dim test_empty As String
Dim tsf As New ADODB.Stream Dim tsf As New ADODB.Stream
Dim field As String
On Error GoTo errh 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.Type = 2
'tsf.Charset = "utf-8"
tsf.Charset = "Windows-1252" tsf.Charset = "Windows-1252"
tsf.Open tsf.Open
'Set ts = f.OpenTextFile(path, ForReading, False, TristateUseDefault)
i = 0 i = 0
While i <= UBound(recs, 2) While i <= UBound(recs, 2)
test_empty = ""
wl = ""
For j = 0 To UBound(recs, 1) For j = 0 To UBound(recs, 1)
field = EscapeCSVField(recs(j, i))
If j = 0 Then If j = 0 Then
test_empty = Replace(Replace(recs(j, i), ",", ""), """", "") wl = field
wl = Replace(Replace(recs(j, i), ",", ""), """", "") test_empty = trim(recs(j, i))
Else Else
test_empty = test_empty & Replace(Replace(recs(j, i), ",", ""), """", "") wl = wl & "," & field
wl = wl & "," & Replace(Replace(recs(j, i), ",", ""), """", "") test_empty = test_empty & trim(recs(j, i))
End If End If
Next j Next j
If Len(test_empty) > 0 Then If Len(test_empty) > 0 Then
If i = 0 Then If i = 0 Then
Call tsf.WriteText(wl) tsf.WriteText wl
Else Else
wl = vbCrLf & wl tsf.WriteText vbCrLf & wl
Call tsf.WriteText(wl)
End If End If
End If End If
i = i + 1 i = i + 1
Wend Wend
Call tsf.SaveToFile(path, adSaveCreateOverWrite)
tsf.SaveToFile path, adSaveCreateOverWrite
FILEp_CreateCSV = True
Exit Function
errh: errh:
If Err.Number = 0 Then MsgBox (Err.Description)
FILEp_CreateCSV = True FILEp_CreateCSV = False
Else
MsgBox (Err.Description)
FILEp_CreateCSV = False
End If
End Function 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 Function FILEp_CreateTXT(ByRef path As String, ByRef recs() As String) As Boolean
Dim i As Long Dim i As Long
@ -1877,63 +1897,101 @@ errh:
End Function End Function
Function FILEp_GetCSV(filepath As String) As String() Function FILEp_GetCSV(filepath As String) As String()
Dim fileNo As Integer Dim fileNo As Integer
Dim fileContent As String Dim fileContent As String
Dim fileLines() As String Dim fileLines() As String
Dim dataArray() As String Dim dataArray() As String
Dim splitArray() As String Dim parsed() As String
Dim rowCount As Long, colCount As Long Dim rowCount As Long
Dim i As Long, j As Long Dim i As Long, j As Long
Dim final() As String Dim fields As Collection
Dim f As Variant
' Get an available file number
' === Read entire file ===
fileNo = FreeFile fileNo = FreeFile
Open filepath For Input As #fileNo
' Open the file with the available file number fileContent = Input(LOF(fileNo), #fileNo)
Open filepath For Input As fileNo Close #fileNo
' Read the entire file content into a single string ' === Split into lines (support CRLF or LF only) ===
fileContent = Input(LOF(fileNo), fileNo) fileContent = Replace(fileContent, vbCrLf, vbLf)
fileContent = Replace(fileContent, vbCr, vbLf)
' Close the file fileLines = Split(fileContent, vbLf)
Close fileNo
' Split the file content into lines
fileLines = Split(fileContent, vbCrLf)
' Get the number of rows (lines)
rowCount = UBound(fileLines) - LBound(fileLines) rowCount = UBound(fileLines) - LBound(fileLines)
If rowCount < 0 Then
' Check if there are any lines in the file MsgBox "File is empty."
If rowCount > 0 Then Exit Function
' 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."
End If 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 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 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 On Error GoTo errflag