refactor some logic
This commit is contained in:
parent
5928c83a24
commit
e1053de60a
230
TheBigOne.cls
230
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
|
||||
@ -1736,59 +1736,79 @@ Function FILEp_CreateCSV(ByRef path As String, ByRef recs() As String) As Boolea
|
||||
|
||||
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
|
||||
Dim fields As Collection
|
||||
Dim f As Variant
|
||||
|
||||
' Get an available file number
|
||||
' === Read entire file ===
|
||||
fileNo = FreeFile
|
||||
Open filepath For Input As #fileNo
|
||||
fileContent = Input(LOF(fileNo), #fileNo)
|
||||
Close #fileNo
|
||||
|
||||
' Open the file with the available file number
|
||||
Open filepath For Input As fileNo
|
||||
' === Split into lines (support CRLF or LF only) ===
|
||||
fileContent = Replace(fileContent, vbCrLf, vbLf)
|
||||
fileContent = Replace(fileContent, vbCr, vbLf)
|
||||
fileLines = Split(fileContent, vbLf)
|
||||
|
||||
' 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)
|
||||
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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user