pt/VBA
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
44555a7f13
VBA/TheBigOne.cls

3013 lines
82 KiB
OpenEdge ABL
Raw Normal View History

utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "TheBigOne"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private ADOo_con() As ADODB.Connection
Private ADOo_rs() As ADODB.Recordset
Public ADOo_errstring As String
Public Enum ADOinterface
MicrosoftJetOLEDB4 = 0
MicrosoftACEOLEDB12 = 1
SqlServer = 2
SQLServerNativeClient = 3
SQLServerNativeClient10 = 4
OracleODBC = 5
OracleOLEDB = 6
TextFile = 7
ISeries = 8
PostgreSQLODBC = 9
End Enum
Public Enum SQLsyntax
Db2 = 0
SqlServer = 1
PostgreSQL = 2
End Enum
update price list build to include status and stocked
2020-01-15 17:17:07 -05:00
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
Public Function TBLp_Aggregate(ByRef tbl() As String, ByRef needsort As Boolean, ByRef headers As Boolean, ByRef del_unused As Boolean, ParamArray groupnum_type_sumnum()) As Boolean
Dim i As Long
Dim j As Long
Dim nt() As String
Dim keep() As Integer
If needsort Then
If Not TBLp_BubbleSortAsc(tbl, Me.PAp_2DGetIntegerArray(0, groupnum_type_sumnum), Me.PAp_2DGetStringArray(1, groupnum_type_sumnum), headers) Then
TBLp_Aggregate = False
Exit Function
End If
End If
If Not TBLp_Roll(tbl, Me.PAp_2DGetIntegerArray(0, groupnum_type_sumnum), Me.PAp_2DGetIntegerArray(2, groupnum_type_sumnum), headers) Then
TBLp_Aggregate = False
Exit Function
End If
If del_unused Then
keep = Me.PAp_2DGetMultIntegerArray(Me.ARRAYp_MakeInteger(0, 2), groupnum_type_sumnum)
ReDim nt(UBound(keep()), UBound(tbl, 2))
For i = 0 To UBound(keep())
For j = 0 To UBound(tbl, 2)
nt(i, j) = tbl(keep(i), j)
Next j
Next i
tbl = nt
End If
TBLp_Aggregate = True
End Function
work on core price list
2022-04-07 12:39:00 -04:00
Public Function TBLp_Group(ByRef tbl() As String, ByRef headers As Boolean, ParamArray cols()) As String()
On Error GoTo errh
Dim i As Long 'indexes primary row
Dim j As Long 'indexes secondary chaecker row
Dim k As Integer 'used to start at 0 or 1
Dim m As Long 'used to aggregate on sequencing lines (i and j aggregate to m line) then shorten array to m length - 1
k = 0
If headers Then k = 1
m = k
For i = k To UBound(tbl, 2)
If i = UBound(tbl, 2) Then
i = i
End If
j = i + 1
Do
If j > UBound(tbl, 2) Then Exit Do
If ROWe_MatchesFlag(tbl, i, j, gflds) Then
Call ROWp_Aggregate2Rows(tbl, i, j, sflds)
Else
Exit Do
End If
j = j + 1
If j > UBound(tbl, 2) Then
Exit Do
End If
Loop
Call ROWp_Copy(tbl, i, m)
m = m + 1
i = j - 1
Next i
ReDim Preserve tbl(UBound(tbl, 1), m - 1)
errh:
If Err.Number <> 0 Then
Me.ADOo_errstring = Err.Description
TBLp_Roll = False
Exit Function
End If
TBLp_Roll = True
End Function
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
Function TBLp_BubbleSortAsc(ByRef tbl() As String, ByRef sortflds() As Integer, ByRef typeflds() As String, ByRef headers As Boolean) As Boolean
On Error GoTo errh
'get fort field numbers
'loop through each row and generate the row key
'eveluate the row key against other row keys
'perform swaps
Dim i As Long
Dim j As Long
Dim k As Long
k = 0
If headers Then k = 1
For i = k To UBound(tbl, 2) - 1
For j = i + 1 To UBound(tbl, 2)
If ROWe_AscSwapFlag(tbl, i, j, sortflds, typeflds) Then
Call ROWp_Swap(tbl, i, j)
Else
If Me.ADOo_errstring <> "" Then
TBLp_BubbleSortAsc = False
Exit Function
End If
End If
Next j
Next i
errh:
If Err.Number <> 0 Then
MsgBox ("Error at TBLP_BubbleSortAsc." & vbCrLf & Err.Description)
Me.ADOo_errstring = Err.Description
End If
TBLp_BubbleSortAsc = True
End Function
Function TBLp_KeyBubbleSortAsc(ByRef tbl() As String, ByRef sortflds() As Integer, ByRef headers As Boolean) As Boolean
On Error GoTo errh
'get fort field numbers
'loop through each row and generate the row key
'eveluate the row key against other row keys
'perform swaps
Dim i As Long
Dim j As Long
Dim k As Long
k = 0
If headers Then k = 1
For i = k To UBound(tbl, 2) - 1
For j = i + 1 To UBound(tbl, 2)
If ROWe_KeyAscSwapFlag(tbl, i, j, sortflds) Then
Call ROWp_Swap(tbl, i, j)
Else
If Me.ADOo_errstring <> "" Then
TBLp_KeyBubbleSortAsc = False
Exit Function
End If
End If
Next j
Next i
errh:
If Err.Number <> 0 Then
MsgBox ("Error at TBLP_keyBubbleSortAsc." & vbCrLf & Err.Description)
Me.ADOo_errstring = Err.Description
End If
TBLp_KeyBubbleSortAsc = True
End Function
Sub TBLp_BubbleSortDescend(ByRef tbl() As String, ByRef sortflds() As Integer, ByRef typeflds() As String, ByRef headers As Boolean)
'get fort field numbers
'loop through each row and generate the row key
'eveluate the row key against other row keys
'perform swaps
Dim i As Long
Dim j As Long
Dim k As Long
k = 0
If headers Then k = 1
For i = k To UBound(tbl, 2) - 1
For j = i + 1 To UBound(tbl, 2)
If ROWe_DescendSwapFlag(tbl, i, j, sortflds, typeflds) Then
Call ROWp_Swap(tbl, i, j)
End If
Next j
Next i
End Sub
Public Function TBLp_Roll(ByRef tbl() As String, ByRef gflds() As Integer, ByRef sflds() As Integer, ByRef headers As Boolean) As Boolean
On Error GoTo errh
Dim i As Long 'indexes primary row
Dim j As Long 'indexes secondary chaecker row
Dim k As Integer 'used to start at 0 or 1
Dim m As Long 'used to aggregate on sequencing lines (i and j aggregate to m line) then shorten array to m length - 1
k = 0
If headers Then k = 1
m = k
For i = k To UBound(tbl, 2)
If i = UBound(tbl, 2) Then
i = i
End If
j = i + 1
Do
If j > UBound(tbl, 2) Then Exit Do
If ROWe_MatchesFlag(tbl, i, j, gflds) Then
Call ROWp_Aggregate2Rows(tbl, i, j, sflds)
Else
Exit Do
End If
j = j + 1
If j > UBound(tbl, 2) Then
Exit Do
End If
Loop
Call ROWp_Copy(tbl, i, m)
m = m + 1
i = j - 1
Next i
ReDim Preserve tbl(UBound(tbl, 1), m - 1)
errh:
If Err.Number <> 0 Then
Me.ADOo_errstring = Err.Description
TBLp_Roll = False
Exit Function
End If
TBLp_Roll = True
End Function
Sub ROWp_Swap(ByRef tbl() As String, ByRef p1 As Long, ByRef p2 As Long)
Dim temprow() As String
ReDim temprow(UBound(tbl, 1))
Dim i As Integer
For i = 0 To UBound(tbl, 1)
temprow(i) = tbl(i, p2)
Next i
For i = 0 To UBound(tbl, 1)
tbl(i, p2) = tbl(i, p1)
Next i
For i = 0 To UBound(tbl, 1)
tbl(i, p1) = temprow(i)
Next i
End Sub
Sub ROWp_Copy(ByRef tbl() As String, ByRef r_from As Long, ByRef r_to As Long)
Dim i As Integer
For i = 0 To UBound(tbl, 1)
tbl(i, r_to) = tbl(i, r_from)
Next i
End Sub
Sub ROWp_Aggregate2Rows(ByRef tbl() As String, ByRef p1 As Long, ByRef p2 As Long, ByRef sflds() As Integer)
Dim i As Integer
On Error GoTo exitsub
For i = 0 To UBound(sflds, 1)
tbl(sflds(i), p1) = CDbl(tbl(sflds(i), p1)) + CDbl(tbl(sflds(i), p2))
Next i
exitsub:
End Sub
Function ROWe_AscSwapFlag(ByRef tbl() As String, ByRef row1 As Long, ByRef row2 As Long, ByRef KeyFld() As Integer, ByRef TypeFld() As String) As Boolean
'only returns true if greater than
On Error GoTo errh
Dim i As Integer
Dim compare As Integer
For i = 0 To UBound(KeyFld)
Select Case TypeFld(i)
Case "S"
compare = Me.MISCe_CompareString(CStr(tbl(KeyFld(i), row1)), CStr(tbl(KeyFld(i), row2)))
Case "N"
compare = Me.MISCe_CompareDouble(CDbl(tbl(KeyFld(i), row1)), CDbl(tbl(KeyFld(i), row2)))
Case "D"
compare = Me.MISCe_CompareDate(CDate(tbl(KeyFld(i), row1)), CDate(tbl(KeyFld(i), row2)))
End Select
Select Case compare
Case -1
ROWe_AscSwapFlag = True
Exit Function
Case 1
ROWe_AscSwapFlag = False
Exit Function
End Select
Next i
errh:
If Err.Number <> 0 Then
MsgBox ("Error at ROWe_AscSwapFlag." & vbCrLf & Err.Description)
Me.ADOo_errstring = Err.Description
Exit Function
End If
End Function
Function ROWe_KeyAscSwapFlag(ByRef tbl() As String, ByRef row1 As Long, ByRef row2 As Long, ByRef KeyFld() As Integer) As Boolean
'only returns true if greater than
On Error GoTo errh
Dim i As Integer
Dim compare As Integer
Dim key1 As String
Dim key2 As String
For i = 0 To UBound(KeyFld)
key1 = key1 & tbl(KeyFld(i), row1)
key2 = key2 & tbl(KeyFld(i), row2)
Next i
compare = Me.MISCe_CompareString(key1, key2)
Select Case compare
Case -1
ROWe_KeyAscSwapFlag = True
Exit Function
Case 1
ROWe_KeyAscSwapFlag = False
Exit Function
End Select
errh:
If Err.Number <> 0 Then
MsgBox ("Error at ROWe_keyAscSwapFlag." & vbCrLf & Err.Description)
Me.ADOo_errstring = Err.Description
Exit Function
End If
End Function
Function ROWe_DescendSwapFlag(ByRef tbl() As String, ByRef row1 As Long, ByRef row2 As Long, ByRef KeyFld() As Integer, ByRef TypeFld() As String) As Boolean
'only returns true if greater than
Dim i As Integer
Dim compare As Integer
For i = 0 To UBound(KeyFld)
Select Case TypeFld(i)
Case "S"
compare = Me.MISCe_CompareString(CStr(tbl(KeyFld(i), row1)), CStr(tbl(KeyFld(i), row2)))
Case "N"
compare = Me.MISCe_CompareDouble(CDbl(tbl(KeyFld(i), row1)), CDbl(tbl(KeyFld(i), row2)))
Case "D"
compare = Me.MISCe_CompareDate(CDate(tbl(KeyFld(i), row1)), CDate(tbl(KeyFld(i), row2)))
End Select
Select Case compare
Case 1
ROWe_DescendSwapFlag = True
Exit Function
Case -1
ROWe_DescendSwapFlag = False
Exit Function
End Select
Next i
End Function
Function ROWe_MatchesFlag(ByRef tbl() As String, ByRef row1 As Long, ByRef row2 As Long, ByRef KeyFld() As Integer) As Boolean
'only returns true if greater than
Dim i As Integer
Dim k1 As String
Dim k2 As String
For i = 0 To UBound(KeyFld())
k1 = k1 & tbl(KeyFld(i), row1)
Next i
For i = 0 To UBound(KeyFld())
k2 = k2 & tbl(KeyFld(i), row2)
Next i
If k2 = k1 Then
ROWe_MatchesFlag = True
Else
ROWe_MatchesFlag = False
End If
End Function
Sub SHTp_Dump(ByRef tbl() As String, ByRef sheet As String, ByRef row As Long, ByRef col As Long, ByRef clear As Boolean, ByRef transpose As Boolean, ParamArray NumFields())
Dim sh As Worksheet
Set sh = Sheets(sheet)
If clear Then sh.Cells.clear
If transpose Then Call Me.ARRAYp_Transpose(tbl)
sh.Range(sh.Cells(row, col).address & ":" & sh.Cells(row + UBound(tbl, 1), col + UBound(tbl, 2)).address).FormulaR1C1 = tbl
On Error GoTo errhndl
If UBound(NumFields()) <> -1 Then
Dim i As Integer
i = 0
For i = 0 To UBound(NumFields())
Call sh.Columns(NumFields(i) + 1).TextToColumns
Next i
End If
errhndl:
If Err.Number <> 0 Then MsgBox ("Error in dumping to sheet" & vbCrLf & Err.Description)
End Sub
Sub SHTp_DumpVar(ByRef tbl() As Variant, ByRef sheet As String, ByRef row As Long, ByRef col As Long, ByRef clear As Boolean, ByRef transpose As Boolean, ByRef zerobase As Boolean)
Dim sh As Worksheet
Dim address As String
Set sh = Sheets(sheet)
'If clear Then sh.Cells.clear
'If transpose Then Call Me.ARRAYp_Transpose(tbl)
If zerobase Then
address = sh.Cells(row, col).address & ":" & sh.Cells(row + UBound(tbl, 1), col + UBound(tbl, 2)).address
Else
address = sh.Cells(row, col).address & ":" & sh.Cells(row + UBound(tbl, 1) - 1, col + UBound(tbl, 2) - 1).address
End If
sh.Range(address).FormulaR1C1 = tbl
On Error GoTo errhndl
errhndl:
If Err.Number <> 0 Then MsgBox ("Error in dumping to sheet" & vbCrLf & Err.Description)
End Sub
Sub ARRAYp_Transpose(ByRef a() As String)
Dim s() As String
ReDim s(UBound(a, 2), UBound(a, 1))
Dim i As Long
Dim j As Long
For i = 0 To UBound(s, 1)
For j = 0 To UBound(s, 2)
s(i, j) = a(j, i)
Next j
Next i
a = s
End Sub
add a new route for swapping out parts
2020-03-05 01:08:10 -05:00
Function ARRAYp_TransposeVar(ByRef a() As Variant) As Variant()
Dim s() As Variant
ReDim s(UBound(a, 2), UBound(a, 1))
Dim i As Long
Dim j As Long
For i = 0 To UBound(s, 1)
For j = 0 To UBound(s, 2)
s(i, j) = a(j, i)
Next j
Next i
ARRAYp_TransposeVar = s
End Function
Function ARRAYp_zerobased_addheader(ByRef z() As Variant, ParamArray cols()) As Variant()
Dim i As Long
Dim j As Long
Dim r() As Variant
ReDim r(UBound(z, 1), UBound(z, 2) + 1)
For i = 0 To UBound(r, 1)
For j = 1 To UBound(r, 2)
r(i, j) = z(i, j - 1)
Next j
r(i, 0) = cols(i)
Next i
ARRAYp_zerobased_addheader = r
End Function
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
Public Function SHTp_Get(ByRef sheet As String, ByRef row As Long, ByRef col As Long, ByRef headers As Boolean) As String()
Dim i As Long
Dim j As Long
Dim table() As String
Dim sh As Worksheet
Set sh = Sheets(sheet)
On Error GoTo errhdnl
i = 1
While sh.Cells(row, col + i - 1) <> ""
i = i + 1
Wend
j = 1
While sh.Cells(row + j - 1, col) <> ""
j = j + 1
Wend
ReDim table(i - 2, j - 2)
i = 1
While i <= UBound(table, 1) + 1
j = 0
While j <= UBound(table, 2)
table(i - 1, j) = sh.Cells(row + j, col + i - 1)
j = j + 1
Wend
i = i + 1
Wend
errhdnl:
If Err.Number <> 0 Then
MsgBox (Err.Description)
End If
SHTp_Get = table
End Function
Public Sub TBLp_FilterSingle(ByRef table() As String, ByRef column As Long, ByVal Filter As String, ByVal Equals As Boolean)
Dim i As Long
Dim j As Long
Dim m As Long
update price list build to include status and stocked
2020-01-15 17:17:07 -05:00
j = LBound(table, 2)
i = LBound(table, 2) + 1
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
While i <= UBound(table, 2)
If (table(column, i) = Filter) = Equals Then
j = j + 1
update price list build to include status and stocked
2020-01-15 17:17:07 -05:00
m = LBound(table, 1)
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
While m <= UBound(table, 1)
table(m, j) = table(m, i)
m = m + 1
Wend
End If
i = i + 1
Wend
update price list build to include status and stocked
2020-01-15 17:17:07 -05:00
ReDim Preserve table(LBound(table, 1) To UBound(table, 1), LBound(table, 2) To j)
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
End Sub
Sub TBLp_AddEmptyCol(ByRef table() As String)
Dim i As Long
Dim j As Long
Dim temp() As String
ReDim temp(UBound(table, 1) + 1, UBound(table, 2))
i = 0
While i <= UBound(table, 1)
j = 0
While j <= UBound(table, 2)
temp(i, j) = table(i, j)
j = j + 1
Wend
i = i + 1
Wend
table() = temp()
End Sub
Function SQLp_RollingMonthList(ByRef mmmyy As String, ByRef outformat As String, ByRef monthcount As Integer) As String
Dim cy As String
Dim cmn As Integer
Dim mlist As String
Dim i As Integer
cmn = Format(DateValue(Left(mmmyy, 3) & "-01-" & Right(mmmyy, 2)), "m")
cy = Right(mmmyy, 2)
For i = 0 To monthcount - 1
If i <> 0 Then mlist = mlist & ","
mlist = mlist & "'" & UCase(Format(DateValue(cmn & "-01-" & cy), outformat)) & "'"
cmn = cmn - 1
If cmn = 0 Then
cmn = 12
cy = Format(CInt(cy) - 1, "00")
End If
Next i
SQLp_RollingMonthList = mlist
End Function
Sub TBLp_DeleteCols(ByRef tbl() As String, ByRef column() As Integer)
Dim temp() As String
ReDim temp(UBound(tbl, 1) - (UBound(column()) + 1), UBound(tbl, 2))
Dim i As Long
Dim j As Long
Dim m As Long
Dim k As Long
Dim ok As Boolean
m = -1
i = 0
While i <= UBound(tbl, 1)
k = 0
ok = True
Do While k <= UBound(column())
If i = column(k) Then
ok = False
Exit Do
End If
k = k + 1
Loop
If ok = True Then
m = m + 1
j = 0
While j <= UBound(tbl, 2)
temp(m, j) = tbl(i, j)
j = j + 1
Wend
End If
i = i + 1
Wend
tbl() = temp()
End Sub
Public Function ADOp_OpenCon(ByRef con As Integer, 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 ConnectionProblem
Dim itype As String
Dim interface As String
Dim stype As String
Dim source As String
Dim properties As String
Dim cs As String
If ADOo_con(con) Is Nothing Then
Set ADOo_con(con) = New ADODB.Connection
End If
'if the connection is not open the set the provider if it is supplied
If ADOo_con(con).State = 0 Then
Select Case value
Case 0
interface = "Microsoft.Jet.OLEDB.4.0"
itype = "Provider="
source = ConnectTo
stype = ";Data Source="
If IntgrtdSec Then
properties = ";User ID=admin"
properties = properties & ";Password="
Else
properties = ";User ID=" & UserName
properties = properties & ";Password=" & Password
End If
Case 1
interface = "Microsoft.ACE.OLEDB.12.0"
itype = "Provider="
source = ConnectTo
stype = ";Data Source="
If IntgrtdSec Then
properties = ";Persist Security Info = False"
Else
properties = ";Jet OLEDB:Database Password=" & Password
End If
Case 2
interface = "SQLOLEDB"
itype = "Provider="
source = ConnectTo
stype = ";Data Source="
If IntgrtdSec Then
properties = ";Integrated Security=SSPI"
Else
properties = ";User ID=" & UserName
properties = properties & ";Password=" & Password
End If
Case 3
interface = "SQLNCLI"
itype = "Provider="
source = ConnectTo
stype = ";Server="
If IntgrtdSec Then
properties = ";Trusted_Connection=yes"
Else
properties = ";Uid=" & UserName
properties = properties & ";Pwd=" & Password
End If
Case 4
interface = "SQLNCLI10"
itype = "Provider="
source = ConnectTo
stype = ";Server="
If IntgrtdSec Then
properties = ";Trusted_Connection=yes"
Else
properties = ";Uid=" & UserName
properties = properties & ";Pwd=" & Password
End If
Case 5
interface = "{Microsoft ODBC for Oracle}"
itype = "Driver="
source = ConnectTo
stype = ";Server="
properties = ";Uid=" & UserName
properties = properties & ";Pwd=" & Password
Case 6
interface = "OraOLEDB.Oracle"
itype = "Provider="
source = ConnectTo
stype = ";Data Source="
If IntgrtdSec Then
properties = ";OSAuthent=1"
Else
properties = ";User ID=" & UserName
properties = properties & ";Password=" & Password
End If
Case 7
interface = "Microsoft.Jet.OLEDB.4.0"
itype = "Provider="
source = ConnectTo
stype = ";Data Source="
properties = properties & ";" & textconfigs
'text;HDR=yes;FMT=Delimited as example
Case 8
interface = "{iSeries Access ODBC Driver}"
itype = "Driver="
source = ConnectTo
stype = ";System="
properties = ";Uid=" & UserName
properties = properties & ";Pwd=" & Password
Case 9
interface = "{PostgreSQL Unicode(x64)}"
itype = "Driver="
source = ConnectTo
stype = ";Server="
properties = ";Uid=" & UserName
properties = properties & ";Pwd=" & Password
properties = properties & ";" & textconfigs
End Select
cs = itype & interface & stype & source & properties
ADOo_con(con).Open (cs)
End If
ConnectionProblem:
If Err.Number <> 0 Then
ADOo_errstring = "Error Number:" & Err.Number & " -" & Err.Description
ADOp_OpenCon = False
Else
ADOo_errstring = ""
ADOp_OpenCon = True
End If
'this path is only used if there are no connection strings available
noconnectionstring:
End Function
Private Sub Class_Initialize()
ReDim ADOo_con(9)
ReDim ADOo_rs(9)
End Sub
Public Function ADOp_MoveRecords(ByRef con_from As Integer, ByRef con_to As Integer, ByRef from_sql As String, ByRef to_table As String, ByRef trim As Boolean) As Boolean
On Error GoTo err_inactive
Dim i As Long
Dim rc As Long
'---------------------------Make sure connections are good to go------------------------------------------------------
If ADOo_con(con_from) Is Nothing Then Set ADOo_con(con_from) = New ADODB.Connection
If ADOo_con(con_to) Is Nothing Then Set ADOo_con(con_to) = New ADODB.Connection
If ADOo_con(con_from).State = 0 Then
ADOo_errstring = "'From' source not connected in MoveRecords operation"
ADOp_MoveRecords = False
Exit Function
End If
If ADOo_con(con_to).State = 0 Then
ADOo_errstring = "'To' source not connected in MoveRecords operation"
ADOp_MoveRecords = False
Exit Function
End If
'-------------Start by opening a record set on the source location statement-----------------------------
ADOo_con(con_from).CommandTimeout = 600
Set ADOo_rs(con_from) = ADOo_con(con_from).Execute(from_sql)
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
Set ADOo_rs(con_from) = ADOo_rs(con_from).NextRecordset()
If ADOo_rs(con_from) Is Nothing Then Exit Do
Loop
If ADOo_rs(con_from) Is Nothing Then
ADOo_errstring = "SQL did not return any results in MoveRecords Finction"
ADOp_MoveRecords = False
Exit Function
End If
End If
'---------------Open up destination table----------------------------------
If ADOo_rs(con_to) Is Nothing Then
Set ADOo_rs(con_to) = New ADODB.Recordset
End If
If ADOo_rs(con_to).State = 1 Then
ADOo_rs(con_to).Close
End If
Call ADOo_rs(con_to).Open(to_table, ADOo_con(con_to), adOpenDynamic, adLockPessimistic)
'-------------Make sure number of fields same in both record sets--------------------
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
End If
'--------------Start movement-------------------------
ADOo_con(con_to).BeginTrans
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) = ""
Else
If trim Then
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)
End If
End If
Next i
ADOo_rs(con_to).Update
ADOo_rs(con_from).MoveNext
Wend
ADOo_con(con_to).CommitTrans
'---------------- close connections------------------
ADOo_rs(con_to).Close
ADOo_rs(con_from).Close
'--------------error handling---------------------------
err_inactive:
If Err.Number <> 0 Then
ADOo_errstring = ADOo_errstring & vbCrLf & Err.Description
ADOp_MoveRecords = False
If ADOo_rs(con_to).State <> 0 Then ADOo_rs(con_to).Close
If ADOo_rs(con_from).State <> 0 Then ADOo_rs(con_from).Close
Exit Function
Else
ADOp_MoveRecords = True
Exit Function
End If
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
ADOp_MoveRecords = False
ADOo_con(con_to).RollbackTrans
ADOo_rs(con_to).Close
ADOo_rs(con_from).Close
Else
ADOp_MoveRecords = True
End If
End Function
Public Function ADOp_SelectS(ByRef con As Integer, ByVal sql As String, ByVal trim As Boolean, 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 String()
On Error GoTo errflag
Dim rs As ADODB.Recordset
Dim x() As String
If ADOo_con(con) Is Nothing Then Set ADOo_con(con) = New ADODB.Connection
If ADOo_con(con).State = 0 Then
If Not Me.ADOp_OpenCon(con, value, ConnectTo, IntgrtdSec, UserName, Password, textconfigs) Then
GoTo conerr
End If
End If
ADOo_con(con).CommandTimeout = 3600
Set ADOo_rs(con) = ADOo_con(con).Execute(sql)
ADOp_SelectS = ADOp_ExtractRecordsetS(con, trim, ApproxSixe, InclHeaders)
If ADOo_rs(con).State <> 0 Then ADOo_rs(con).Close
Exit Function
conerr:
If Me.ADOo_errstring <> "" Then
ReDim x(0, 0)
x(0, 0) = "Error"
ADOp_SelectS = x
Exit Function
End If
errflag:
If Err.Number <> 0 Then
ReDim x(0, 0)
x(0, 0) = "Error" & Err.Number & vbCrLf & Err.Description
Me.ADOo_errstring = "Error: " & Err.Number & vbCrLf & Err.Description
ADOp_SelectS = x
End If
End Function
Private Function ADOp_ExtractRecordsetS(ByRef con As Integer, ByRef trim As Boolean, Optional ByVal Size As Long, Optional headers As Boolean) As String()
Dim i As Long
Dim j As Long
On Error GoTo err_active
'if no size is provided, dim to one million
If Size = 0 Then Size = 1000000
'size table
Dim table() As String
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
If ADOo_rs(con) Is Nothing Then
ReDim table(0, 0)
ADOp_ExtractRecordsetS = table
Exit Function
Else
ReDim table(ADOo_rs(con).Fields.Count - 1, Size)
End If
Else
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
i = i + 1
Wend
End If
'populate array
If headers Then
i = 1
Else
i = 0
End If
While ADOo_rs(con).EOF = False
j = 0
While j <= (UBound(table, 1))
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)))
Else
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
End If
j = j + 1
Wend
i = i + 1
ADOo_rs(con).MoveNext
Wend
If i = 0 Then i = 1
ReDim Preserve table(UBound(table, 1), i - 1)
err_active:
If Err.Number <> 0 Then
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
ADOo_rs(con).Close
Else
ADOp_ExtractRecordsetS = table
End If
End Function
Public Function TBLp_JoinTbls(ByRef tbl1() As String, ByRef tbl2() As String, ByRef headers As Boolean, ByRef NeedsSort As Boolean, ByRef dupfactor As Integer, ParamArray flds()) As String()
On Error GoTo errpath
'3 arrays
'the first 2 arrays are the joining fields
'the next array is what fields to attach to table1
Dim t() As String
Dim i As Long
Dim j As Long
Dim k As Long
Dim copyrow As Long
Dim toprow As Long
Dim found As Boolean
Dim ntbl() As String
Dim hr As Integer
Dim ntrow As Long
hr = 0
If headers Then hr = 1
ReDim ntbl(UBound(tbl1, 1) + UBound(flds(2)) + 1, UBound(tbl1, 2) * dupfactor)
t = Me.PAp_2DGetStringArray(0, flds)
For i = 0 To UBound(t)
t(i) = "S"
Next i
If NeedsSort Then Call Me.TBLp_KeyBubbleSortAsc(tbl2, Me.PAp_2DGetIntegerArray(1, flds), True)
For i = 0 To UBound(tbl1, 2)
'If i = 6516 Then MsgBox ("x")
For j = 0 To UBound(t)
t(j) = tbl1(flds(0)(j), i)
Next j
copyrow = Me.ROWe_FindOnSorted(tbl2, toprow, found, Me.PAp_2DGetIntegerArray(1, flds), t)
'copy both sets of rows to new table
If found Then
For k = copyrow To toprow
Call ROWp_TableJoinCopy2ToNew(tbl1, tbl2, ntbl, Me.PAp_2DGetIntegerArray(2, flds), i, k, ntrow)
Next k
Else
Call ROWp_TableJoinCopy1ToNew(tbl1, ntbl, i, ntrow)
End If
Next i
'copy headers
If headers Then
Call ROWp_TableJoinCopy2ToNew(tbl1, tbl2, ntbl, Me.PAp_2DGetIntegerArray(2, flds), 0, 0, 0)
End If
ReDim Preserve ntbl(UBound(ntbl, 1), ntrow - 1)
errpath:
If Err.Number <> 0 Then
ADOo_errstring = ADOo_errstring & "Error in TLBp_JoinTbls" & vbCrLf & Err.Description & vbCrLf
ReDim ntbl(0, 0)
ntbl(0, 0) = ADOo_errstring
End If
TBLp_JoinTbls = ntbl
End Function
Private Sub ROWp_TableJoinCopy2ToNew(ByRef tbl1() As String, ByRef tbl2() As String, ByRef ntbl() As String, ByRef tbl2flds() As Integer, ByRef tbl1row As Long, ByRef tbl2row As Long, ByRef newrow As Long)
Dim i As Integer
Dim j As Integer
For i = 0 To UBound(tbl1, 1)
ntbl(i, newrow) = tbl1(i, tbl1row)
Next i
For i = 0 To UBound(tbl2flds)
ntbl(UBound(tbl1, 1) + 1 + i, newrow) = tbl2(tbl2flds(i), tbl2row)
Next i
newrow = newrow + 1
End Sub
Private Sub ROWp_TableJoinCopy1ToNew(ByRef tbl1() As String, ByRef ntbl() As String, ByRef tbl1row As Long, ByRef newrow As Long)
Dim i As Integer
For i = 0 To UBound(tbl1, 1)
ntbl(i, newrow) = tbl1(i, tbl1row)
Next i
newrow = newrow + 1
End Sub
Function PAp_2DGetStringArray(ByRef index As Integer, ParamArray pa()) As String()
Dim str() As String
Dim i As Long
ReDim str(UBound(pa(0)(index)))
For i = 0 To UBound(pa(0)(index))
str(i) = pa(0)(index)(i)
Next i
PAp_2DGetStringArray = str
End Function
Function PAp_3DGetStringArray(ByRef index As Integer, ParamArray pa()) As String()
On Error GoTo errh
'when the parameter array gets passed into this functon as another paramtere array, an unnecessary dimension has been added
Dim str() As String
Dim i As Long
Dim j As Long
ReDim str(UBound(pa(0)(index), 1), UBound(pa(0)(index), 2))
For i = 0 To UBound(str, 2)
For j = 0 To UBound(str, 1)
str(j, i) = pa(0)(index)(j, i)
Next j
Next i
errh:
If Err.Number <> 0 Then
ADOo_errstring = ADOo_errstring & "Error at PAp_3DGetStringArray" & vbCrLf & Err.Description & vbCrLf
ReDim str(0, 0)
str(0, 0) = ADOo_errstring
End If
PAp_3DGetStringArray = str
End Function
Function PAp_2DGetVariantArray(ByRef index As Integer, ParamArray pa()) As Variant()
Dim str() As Variant
Dim i As Long
ReDim str(UBound(pa(0)(index)))
For i = 0 To UBound(pa(0)(index))
str(i) = pa(0)(index)(i)
Next i
PA_2DGetVariantArray = str
End Function
Function PAp_2DGetLongArray(ByRef index As Integer, ParamArray pa()) As Long()
Dim str() As Long
Dim i As Long
ReDim str(UBound(pa(0)(index)))
For i = 0 To UBound(pa(0)(index))
str(i) = pa(0)(index)(i)
Next i
PA_2DGetLongArray = str
End Function
Function PAp_2DGetIntegerArray(ByRef index As Integer, ParamArray pa()) As Integer()
Dim str() As Integer
Dim i As Long
If UBound(pa(0)(index)) <> -1 Then
ReDim str(UBound(pa(0)(index)))
For i = 0 To UBound(pa(0)(index))
str(i) = pa(0)(index)(i)
Next i
End If
PAp_2DGetIntegerArray = str
End Function
Function PAp_2DGetMultIntegerArray(ByRef ArraysGet() As Integer, ParamArray pa()) As Integer()
Dim str() As Integer
Dim i As Long
Dim j As Long
Dim cnt As Long
Dim index As Long
'get length of selected arrays
For i = 0 To UBound(ArraysGet, 1)
cnt = cnt + UBound(pa(0)(ArraysGet(i)))
Next i
ReDim str(cnt + 1)
cnt = 0
For i = 0 To UBound(ArraysGet, 1)
For j = 0 To UBound(pa(0)(ArraysGet(i)))
str(cnt) = pa(0)(ArraysGet(i))(j)
cnt = cnt + 1
Next j
Next i
PAp_2DGetMultIntegerArray = str
End Function
Public Function ARRAYp_MakeInteger(ParamArray items()) As Integer()
Dim x() As Integer
Dim i As Integer
ReDim x(UBound(items))
For i = 0 To UBound(items())
x(i) = items(i)
Next i
ARRAYp_MakeInteger = x
End Function
Public Function ARRAYp_MakeString(ParamArray items()) As String()
Dim x() As String
Dim i As Integer
ReDim x(UBound(items))
For i = 0 To UBound(items())
x(i) = items(i)
Next i
ARRAYp_MakeString = x
End Function
Public Function MISCe_CompareString(ByRef base As String, ByRef compare As String) As Integer
If compare < base Then
MISCe_CompareString = -1
Exit Function
End If
If compare = base Then
MISCe_CompareString = 0
Exit Function
End If
If compare > base Then
MISCe_CompareString = 1
Exit Function
End If
End Function
Public Function MISCe_CompareDouble(ByRef base As Double, ByRef compare As Double) As Integer
If compare < base Then
MISCe_CompareDouble = -1
Exit Function
End If
If compare = base Then
MISCe_CompareDouble = 0
Exit Function
End If
If compare > base Then
MISCe_CompareDouble = 1
Exit Function
End If
End Function
Public Function MISCe_MaxInt(ByRef base As Integer, ByRef compare As Integer) As Integer
If compare < base Then
MISCe_MaxInt = base
Exit Function
End If
If compare = base Then
MISCe_MaxInt = compare
Exit Function
End If
If compare > base Then
MISCe_MaxInt = compare
Exit Function
End If
End Function
Public Function MISCe_CompareDate(ByRef base As Date, ByRef compare As Date) As Integer
If compare < base Then
MISCe_CompareDate = -1
Exit Function
End If
If compare = base Then
MISCe_CompareDate = 0
Exit Function
End If
If compare > base Then
MISCe_CompareDate = 1
Exit Function
End If
End Function
Public Function ROWe_FindOnSorted(ByRef tbl() As String, ByRef Range As Long, ByRef match As Boolean, ParamArray fldsvals()) As Long
On Error GoTo errpath
'has to be a lexicographically sorted table otherwise this evaluaiton will not be the same as the sort evaluaiton
'flds has a field number and the value to get
'returns the low point and modifies the range parameter to reflect the high point
Dim maxrow As Long
Dim minrow As Long
Dim currow As Long
Dim curkey As String
Dim basekey As String
Dim i As Long
Dim j As Long
Dim found As Boolean
For i = 0 To UBound(fldsvals(1))
curkey = curkey & fldsvals(1)(i)
Next i
maxrow = UBound(tbl, 2)
currow = UBound(tbl, 2) \ 2
minrow = 0
Do
Select Case Me.MISCe_CompareString(ROWp_CreateKey(tbl, Me.PAp_2DGetIntegerArray(0, fldsvals), currow), curkey)
Case -1
maxrow = currow
currow = (currow - minrow) \ 2 + minrow
'minrow stays same
'if the spread is 10 or less just loop through due to '\' errors
If maxrow - minrow <= 10 Then
currow = minrow
Do Until Me.MISCe_CompareString(ROWp_CreateKey(tbl, Me.PAp_2DGetIntegerArray(0, fldsvals), currow), curkey) = 0
currow = currow + 1
If currow > maxrow Then
match = False
ROWe_FindOnSorted = 0
Exit Function
End If
Loop
End If
Case 0
'check both directions for duplicates
If currow < UBound(tbl, 2) Then
i = currow + 1
Do Until Me.MISCe_CompareString(ROWp_CreateKey(tbl, Me.PAp_2DGetIntegerArray(0, fldsvals), i), curkey) <> 0
i = i + 1
If i > UBound(tbl, 2) Then
Exit Do
End If
Loop
i = i - 1
Else
i = currow
End If
If currow > 0 Then
j = currow - 1
Do Until Me.MISCe_CompareString(ROWp_CreateKey(tbl, Me.PAp_2DGetIntegerArray(0, fldsvals), j), curkey) <> 0
j = j - 1
If j < 0 Then
Exit Do
End If
Loop
j = j + 1
Else
j = currow
End If
Range = i
ROWe_FindOnSorted = j
match = True
Exit Function
Case 1
minrow = currow
currow = (maxrow - minrow) / 2 + minrow
'max row stays same
'if the spread is 10 or less just loop through due to '\' errors
If maxrow - minrow <= 10 Then
currow = minrow
Do Until Me.MISCe_CompareString(ROWp_CreateKey(tbl, Me.PAp_2DGetIntegerArray(0, fldsvals), currow), curkey) = 0
currow = currow + 1
If currow > maxrow Then
match = False
ROWe_FindOnSorted = 0
Exit Function
End If
Loop
End If
End Select
Loop
errpath:
i = i
End Function
Public Function ROWp_CreateKey(ByRef tbl() As String, ByRef flds() As Integer, ByRef row As Long) As String
Dim i As Integer
Dim s As String
For i = 0 To UBound(flds)
s = s & tbl(flds(i), row)
Next i
ROWp_CreateKey = s
End Function
Public Function SHTp_GetAllCellsConcatenated(ByRef sh As Worksheet, ByRef maxw As Long, ByRef maxl As Long) As String
Dim i As Long
Dim j As Long
Dim cs As String
For i = 1 To maxl
For j = 1 To maxw
If j > 1 Then cs = cs & vbTab
cs = cs & sh.Cells(i, j)
Next j
cs = cs & " " & vbCrLf
Next i
SHTp_GetAllCellsConcatenated = cs
End Function
Public Function MISCp_msgbox_cancel(ByRef Message As String, Optional ByRef TITLE As String = "") As Boolean
Application.EnableCancelKey = xlDisabled
work with target price generation
2021-10-07 18:28:15 -04:00
MsgB.tbMSG.text = Message
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
MsgB.Caption = TITLE
MsgB.tbMSG.ScrollBars = fmScrollBarsBoth
MsgB.Show
work with target price generation
2021-10-07 18:28:15 -04:00
MISC_msgbox_cancel = MsgB.Cancel
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
Application.EnableCancelKey = xlInterrupt
End Function
Public Function TBLp_CrossJoin(ByRef tbl1() As String, ByRef tbl2() As String, ByRef headers As Boolean) As String()
Dim t() As String
Dim i As Long
Dim j As Long
Dim k As Long
Dim m As Long
Dim h As Integer
If headers Then
ReDim t(UBound(tbl1, 1) + UBound(tbl2, 1) + 1, UBound(tbl1, 2) * UBound(tbl2, 2))
Else
ReDim t(UBound(tbl1, 1) + UBound(tbl2, 1) + 1, (UBound(tbl1, 2) + 1) * (UBound(tbl2, 2) + 1) - 1)
End If
h = 0
If headers Then
j = 0
For i = 0 To UBound(tbl1, 1)
t(i, j) = tbl1(i, j)
Next i
For i = 0 To UBound(tbl2, 1)
t(i + UBound(tbl1, 1) + 1, j) = tbl2(i, j)
Next i
h = 1
End If
m = 0
If headers Then m = 1
For i = h To UBound(tbl1, 2)
For j = h To UBound(tbl2, 2)
For k = 0 To UBound(tbl1, 1)
t(k, m) = tbl1(k, i)
Next k
For k = 0 To UBound(tbl2, 1)
t(k + UBound(tbl1, 1) + 1, m) = tbl2(k, j)
Next k
m = m + 1
Next j
Next i
TBLp_CrossJoin = t
End Function
Function ADOp_InsertRecordsS(ByRef Records() As String, ByRef con As Integer, ByVal TableName As String, Optional headers As Boolean) As Boolean
Dim i As Integer
Dim j As Integer
If ADOo_rs(con) Is Nothing Then
Set ADOo_rs(con) = New ADODB.Recordset
End If
If ADOo_rs(con).State = 1 Then
ADOo_rs(con).Close
End If
Call ADOo_rs(con).Open(TableName, ADOo_con(con), adOpenDynamic, adLockPessimistic)
ADOo_con(con).BeginTrans
If headers = True Then
i = 1
Else
i = 0
End If
While i <= UBound(Records, 2)
ADOo_rs(con).AddNew
j = 0
While j <= UBound(Records, 1)
If Records(j, i) <> "" Then
ADOo_rs(con)(j) = Records(j, i)
End If
j = j + 1
Wend
i = i + 1
ADOo_rs(con).Update
Wend
ADOo_con(con).CommitTrans
ADOo_rs(con).Close
inserterror:
If Err.Number <> 0 Then
ADOo_con(con).RollbackTrans
ADOo_errstring = "Error encountered while adding records- #" & Err.Number & " " & Err.Description
ADOp_InsertRecordsS = False
Else
ADOp_InsertRecordsS = True
ADOo_errstring = ""
End If
noconnectionstring:
End Function
Function MISCe_IsNull(ByRef stringexp As String, replacement As String) As String
If stringexp = "" Then
IsNull = replacement
Else
IsNull = stringexp
End If
End Function
Sub TBLp_Concatenate(ByRef ARY1() As String, ByRef ARY2() As String)
Dim temp() As String
ReDim temp(UBound(ARY1, 1) + 1 + UBound(ARY2, 1), UBound(ARY1, 2) + UBound(ARY2, 2))
Dim i As Integer
Dim j As Integer
Dim ub1 As Integer
Dim ub2 As Integer
i = 0
While i <= UBound(ARY1, 1)
j = 0
While j <= UBound(ARY1, 2)
temp(i, j) = ARY1(i, j)
j = j + 1
Wend
i = i + 1
Wend
ub1 = i
ub2 = j - 1
While i <= UBound(temp, 1)
j = 0
While j <= ub2
temp(i, j) = ARY2(i - ub1, j)
j = j + 1
Wend
i = i + 1
Wend
ReDim Preserve temp(UBound(temp, 1), j - 1)
ARY1() = temp()
End Sub
Sub SHTp_HyperlinkConvert(ByRef sheet As Worksheet, ByRef column As Integer, ByRef startrow As Integer, ByRef stopflag As String)
Dim i As Integer
Dim sh As Worksheet
Set sh = sheet
i = startrow
Do Until sh.Cells(i, column) = stopflag
Call sh.Hyperlinks.Add(sh.Range(sh.Cells(i, column).address), sh.Cells(i, column))
i = i + 1
Loop
End Sub
Function FILEp_GetTXT(ByRef path As String, approxrecords) As String()
Dim i As Long
Dim t() As String
ReDim t(0, approxrecords)
Dim f As New Scripting.FileSystemObject
Dim ts As Scripting.TextStream
Set ts = f.OpenTextFile(path, ForReading, False, TristateUseDefault)
i = 0
While Not ts.AtEndOfStream
t(0, i) = ts.ReadLine
i = i + 1
Wend
ReDim Preserve t(0, i - 1)
ts.Close
FILEp_GetTXT = t
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
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)
For j = 0 To UBound(recs, 1)
If j = 0 Then
test_empty = Replace(Replace(recs(j, i), ",", ""), """", "")
update price list build to include status and stocked
2020-01-15 17:17:07 -05:00
wl = Replace(Replace(recs(j, i), ",", ""), """", "")
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
Else
test_empty = test_empty & Replace(Replace(recs(j, i), ",", ""), """", "")
update price list build to include status and stocked
2020-01-15 17:17:07 -05:00
wl = wl & "," & Replace(Replace(recs(j, i), ",", ""), """", "")
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
End If
Next j
If Len(test_empty) > 0 Then
If i = 0 Then
Call tsf.WriteText(wl)
Else
wl = vbCrLf & wl
Call tsf.WriteText(wl)
End If
End If
i = i + 1
Wend
Call tsf.SaveToFile(path, adSaveCreateOverWrite)
errh:
If Err.Number = 0 Then
FILEp_CreateCSV = True
Else
MsgBox (Err.Description)
FILEp_CreateCSV = False
End If
End Function
Function FILEp_CreateTXT(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
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.Open
'Set ts = f.OpenTextFile(path, ForReading, False, TristateUseDefault)
i = 0
While i <= UBound(recs, 2)
For j = 0 To UBound(recs, 1)
test_empty = recs(j, i)
wl = recs(j, i)
Next j
If Len(test_empty) > 0 Then
If i = 0 Then
Call tsf.WriteText(wl)
Else
wl = vbCrLf & wl
Call tsf.WriteText(wl)
End If
End If
i = i + 1
Wend
Call tsf.SaveToFile(path, adSaveCreateOverWrite)
errh:
If Err.Number = 0 Then
FILEp_CreateTXT = True
Else
MsgBox (Err.Description)
FILEp_CreateTXT = False
End If
End Function
work with target price generation
2021-10-07 18:28:15 -04:00
Function FILEp_Create(ByRef path As String, ByRef text 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
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.Open
'Set ts = f.OpenTextFile(path, ForReading, False, TristateUseDefault)
Call tsf.WriteText(text)
Call tsf.SaveToFile(path, adSaveCreateOverWrite)
errh:
If Err.Number = 0 Then
FILEp_Create = True
Else
MsgBox (Err.Description)
FILEp_Create = False
End If
End Function
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
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
If ADOo_con(con) Is Nothing Then Set ADOo_con(con) = New ADODB.Connection
If ADOo_con(con).State = 0 Then
If Not Me.ADOp_OpenCon(con, value, ConnectTo, IntgrtdSec, UserName, Password, textconfigs) Then
GoTo conerr
End If
End If
work on core price list
2022-04-07 12:39:00 -04:00
ADOo_con(con).CommandTimeout = 600
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
Call ADOo_con(con).Execute(sql)
ADOp_Exec = True
Exit Function
conerr:
If Me.ADOo_errstring <> "" Then
ADOp_Exec = False
Exit Function
End If
errflag:
If Err.Number <> 0 Then
ADOp_Exec = False
Me.ADOo_errstring = "Error: " & Err.Number & vbCrLf & Err.Description
End If
End Function
Sub ADOp_CloseCon(con As Integer)
ADOo_con(con).Close
End Sub
Public Function TBLp_Unpivot(ByRef arr() As String, ByRef pivot_field_header, ByRef content_header As String, ParamArray keepcols_stackcols()) As String()
On Error GoTo errh
Dim keep() As Integer
Dim stack() As Integer
Dim i As Long
Dim j As Long
Dim k As Long
Dim r As Long
keep = Me.PAp_2DGetIntegerArray(0, keepcols_stackcols)
stack = Me.PAp_2DGetIntegerArray(1, keepcols_stackcols)
Dim n() As String
ReDim n(UBound(keep) + 2, UBound(arr, 2) * (UBound(stack) + 1))
For i = 0 To UBound(keep)
n(i, 0) = arr(keep(i), 0)
Next i
n(UBound(keep) + 1, 0) = pivot_field_header
n(UBound(keep) + 2, 0) = content_header
r = 1
For i = 0 To UBound(stack) 'loop through each stack field
For j = 1 To UBound(arr, 2) 'loop through each row in the array
For k = 0 To UBound(keep) 'loop through each field to keep
n(k, r) = arr(keep(k), j)
Next k
n(UBound(keep) + 1, r) = arr(stack(i), 0) 'arr col title
n(UBound(keep) + 2, r) = arr(stack(i), j) 'arr row content
r = r + 1
Next j
Next i
errh:
If Err.Number <> 0 Then
ADOo_errstring = ADOo_errstring & "Error in tblp_unpivot" & vbCrLf & Err.Description
ReDim n(0, 0)
n(0, 0) = ADOo_errstring
End If
TBLp_Unpivot = n
End Function
Function TBLp_Stack_NewAr(ParamArray ar()) As String()
On Error GoTo errh
Dim ar1() As String
Dim ar2() As String
Dim i As Long
Dim j As Long
Dim k As Long
Dim r As Long
Dim out() As String
Dim ac As Long 'array count
Dim al As Long 'new arrray length
'get number of array is paramter array
ac = UBound(ar, 1) + 1
'get length of each array and add total for final array redim
For i = 0 To ac - 1
al = al + UBound(ar(i), 2)
Next i
'setup new combination array
ReDim Preserve out(UBound(ar(0), 1), al)
'set headers
For i = 0 To UBound(out, 1)
out(i, 0) = ar(0)(i, 0)
Next i
'get content
r = 1
For k = 0 To ac - 1 'loop through each array
For j = 1 To UBound(ar(k), 2) 'loop through each row in each array
For i = 0 To UBound(out, 1) 'loop through each column of each row of each array
out(i, r) = ar(k)(i, j)
Next i
r = r + 1
Next j
Next k
errh:
If Err.Number <> 0 Then
ADOo_errstring = ADOo_errstring & "Error at TBLp_Stack_NewAr" & vbCrLf & Err.Description
ReDim out(0, 0)
out(0, 0) = ADOo_errstring
End If
TBLp_Stack_NewAr = out
End Function
Sub TBLp_Stack_Overwrite(ar1() As String, ar2() As String)
On Error GoTo errh
Dim i As Long
Dim j As Long
Dim r As Long
r = UBound(ar1, 2)
ReDim Preserve ar1(UBound(ar1, 1), UBound(ar1, 2) + UBound(ar2, 2))
For j = 1 To UBound(ar2, 2)
For i = 0 To UBound(ar1, 1)
ar1(i, r) = ar2(i, j)
Next i
r = r + 1
Next j
errh:
If Err.Number <> 0 Then
ADOo_errstring = ADOo_errstring & "Error at TBLp_Stack_Overwrite" & vbCrLf & Err.Description
ReDim ar1(0, 0)
ar1(0, 0) = ADOo_errstring
End If
End Sub
Public Function TXTp_Pad(ByRef topad As String, ByRef left_true_right_false As Boolean, ByRef padchar As String, ByRef padlength As Integer) As String
If Len(topad) >= padlength Then
Pad = topad
Exit Function
End If
If left_true_right_false Then
Pad = String(padlength - Len(topad), padchar) & topad
Else
Pad = topad & String(padlength - Len(topad), padchar)
End If
End Function
Function TXTp_ParseCSVrow(ByRef csv() As String, row As Long, col As Integer) As String()
Dim i As Long
Dim ci As Long
Dim cc() As Long
Dim qflag As Boolean
Dim rtn() As String
ReDim cc(1000)
ci = 1
cc(0) = 0
For i = 1 To Len(csv(col, row))
If Mid(csv(col, row), i, 1) = Chr(34) Then
If qflag = True Then
qflag = False
ElseIf qflag = False Then
qflag = True
End If
End If
If Mid(csv(col, row), i, 1) = "," Then
If Not qflag Then
cc(ci) = i
ci = ci + 1
End If
End If
Next i
cc(ci) = i
ReDim rtn(ci - 1)
For i = 0 To UBound(rtn)
rtn(i) = Mid(csv(col, row), cc(i) + 1, cc(i + 1) - (cc(i) + 1))
If Mid(rtn(i), 1, 1) = Chr(34) Then rtn(i) = Mid(rtn(i), 2, Len(rtn(i)) - 2)
Next i
TXTp_ParseCSVrow = rtn
End Function
Function json_from_list(keys As Range, values As Range) As String
Dim json As String
Dim i As Integer
Dim first_comma As Boolean
Dim needs_braces As Integer
needs_comma = False
needs_braces = 0
For i = 1 To keys.Cells.Count
If values.Cells(i).value <> "" Then
needs_braces = needs_braces + 1
If needs_comma Then json = json & ","
needs_comma = True
If IsNumeric(values.Cells(i).value) Then
json = json & Chr(34) & keys.Cells(i).value & Chr(34) & ":" & values.Cells(i).value
Else
json = json & Chr(34) & keys.Cells(i).value & Chr(34) & ":" & Chr(34) & values.Cells(i).value & Chr(34)
End If
End If
Next i
If needs_braces > 0 Then json = "{" & json & "}"
json_from_list = json
End Function
Function json_concat(list As Range) As String
Dim json As String
Dim i As Integer
i = 0
For Each cell In list
If cell.value <> "" Then
i = i + 1
If i = 1 Then
json = cell.value
Else
json = json & "," & cell.value
End If
End If
Next cell
If i > 1 Then json = "[" & json & "]"
json_concat = json
End Function
add a new route for swapping out parts
2020-03-05 01:08:10 -05:00
Public Function ADOp_BuildInsertSQL(ByRef tbl() As String, Target As String, trim As Boolean, start As Long, ending As Long, ParamArray ftype()) As String
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
Dim i As Long
Dim j As Long
add function
2022-02-09 10:55:59 -05:00
Dim k As Long
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
Dim sql As String
Dim rec As String
add a new route for swapping out parts
2020-03-05 01:08:10 -05:00
sql = "INSERT INTO " & Target & " VALUES " & vbCrLf
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
For i = start To ending
rec = ""
If i <> start Then sql = sql & "," & vbCrLf
rec = rec & "("
add function
2022-02-09 10:55:59 -05:00
k = 0
For j = LBound(tbl, 1) To UBound(tbl, 1)
If j <> LBound(tbl, 1) Then rec = rec & ","
Select Case ftype(0)(k)
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
Case "N" '-------N = numeric but should probably be N for numeric----
If tbl(j, i) = "" Then
rec = rec & "NULL"
Else
rec = rec & Replace(tbl(j, i), "'", "''")
End If
Case "S" '-------S = string------------------------------------------
If trim Then
rec = rec & "'" & LTrim(RTrim(Replace(tbl(j, i), "'", "''"))) & "'"
Else
rec = rec & "'" & Replace(tbl(j, i), "'", "''") & "'"
End If
Case "D" '-------D = date---------------------------------------------
If LTrim(RTrim(tbl(j, i))) = "" Then
rec = rec & "CAST(NULL AS DATE)"
Else
rec = rec & "'" & tbl(j, i) & "'"
End If
Case Else '-------Assume text------------------------------------------
If trim Then
rec = rec & "'" & LTrim(RTrim(Replace(tbl(j, i), "'", "''"))) & "'"
Else
rec = rec & "'" & Replace(tbl(j, i), "'", "''") & "'"
End If
End Select
add function
2022-02-09 10:55:59 -05:00
k = k + 1
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
Next j
rec = rec & ")"
sql = sql & rec
Next i
ADOp_BuildInsertSQL = sql
End Function
Public Function json_from_table(ByRef tbl() As Variant, ByRef array_label As String, Optional strip_braces As Boolean) As String
Dim ajson As String
Dim json As String
Dim r As Integer
Dim c As Integer
Dim needs_comma As Boolean
Dim needs_braces As Integer
needs_comma = False
needs_braces = 0
ajson = ""
updates
2020-09-15 13:02:06 -04:00
For r = LBound(tbl, 1) + 1 To UBound(tbl, 1)
For c = LBound(tbl, 2) To UBound(tbl, 2)
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
If tbl(r, c) <> "" Then
needs_braces = needs_braces + 1
If needs_comma Then json = json & ","
needs_comma = True
If IsNumeric(tbl(r, c)) And Mid(tbl(r, c), 1, 1) <> 0 Then
updates
2020-09-15 13:02:06 -04:00
json = json & Chr(34) & tbl(LBound(tbl, 2), c) & Chr(34) & ":" & tbl(r, c)
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
Else
'test if item is a json object
If Mid(tbl(r, c), 1, 1) = "{" Or Mid(tbl(r, c), 1, 1) = "[" Then
updates
2020-09-15 13:02:06 -04:00
json = json & """" & tbl(LBound(tbl, 2), c) & """" & ":" & tbl(r, c)
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
Else
updates
2020-09-15 13:02:06 -04:00
json = json & Chr(34) & tbl(LBound(tbl, 2), c) & Chr(34) & ":" & Chr(34) & tbl(r, c) & Chr(34)
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
End If
End If
End If
Next c
If needs_braces > 0 Then json = "{" & json & "}"
needs_comma = False
needs_braces = 0
updates
2020-09-15 13:02:06 -04:00
If r > LBound(tbl, 1) + 1 Then
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
ajson = ajson & "," & json
Else
ajson = json
End If
json = ""
Next r
'if theres more the one record, include brackets for array
'if an array_label is given give the array a key and the array become the value
'then if the array is labeled with a key it should have braces unless specified otherwise
updates
2020-09-15 13:02:06 -04:00
If r > LBound(tbl, 1) + 2 Then
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
ajson = "[" & ajson & "]"
If array_label <> "" Then
ajson = """" & array_label & """:" & ajson
If Not strip_braces Then
ajson = "{" & ajson & "}"
End If
End If
Else
If strip_braces Then
ajson = Mid(ajson, 2, Len(ajson) - 2)
End If
End If
json_from_table = ajson
End Function
list of parts to change not wrapped in an array if only one row
2020-03-06 00:33:24 -05:00
Public Function json_from_table_zb(ByRef tbl() As Variant, ByRef array_label As String, ByVal force_array As Boolean, Optional strip_braces As Boolean) As String
add a new route for swapping out parts
2020-03-05 01:08:10 -05:00
Dim ajson As String
Dim json As String
Dim r As Integer
Dim c As Integer
Dim needs_comma As Boolean
Dim needs_braces As Integer
needs_comma = False
needs_braces = 0
ajson = ""
For r = 1 To UBound(tbl, 1)
For c = 0 To UBound(tbl, 2)
If tbl(r, c) <> "" Then
needs_braces = needs_braces + 1
If needs_comma Then json = json & ","
needs_comma = True
If IsNumeric(tbl(r, c)) And Mid(tbl(r, c), 1, 1) <> 0 Then
json = json & Chr(34) & tbl(0, c) & Chr(34) & ":" & tbl(r, c)
Else
'test if item is a json object
If Mid(tbl(r, c), 1, 1) = "{" Or Mid(tbl(r, c), 1, 1) = "[" Then
json = json & """" & tbl(0, c) & """" & ":" & tbl(r, c)
Else
json = json & Chr(34) & tbl(0, c) & Chr(34) & ":" & Chr(34) & tbl(r, c) & Chr(34)
End If
End If
End If
Next c
If needs_braces > 0 Then json = "{" & json & "}"
needs_comma = False
needs_braces = 0
If r > 1 Then
ajson = ajson & "," & json
Else
ajson = json
End If
json = ""
Next r
'if theres more the one record, include brackets for array
'if an array_label is given give the array a key and the array become the value
'then if the array is labeled with a key it should have braces unless specified otherwise
list of parts to change not wrapped in an array if only one row
2020-03-06 00:33:24 -05:00
If r > 2 Or force_array Then
add a new route for swapping out parts
2020-03-05 01:08:10 -05:00
ajson = "[" & ajson & "]"
If array_label <> "" Then
ajson = """" & array_label & """:" & ajson
If Not strip_braces Then
ajson = "{" & ajson & "}"
End If
End If
Else
If strip_braces Then
ajson = Mid(ajson, 2, Len(ajson) - 2)
End If
End If
json_from_table_zb = ajson
End Function
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
Public Function MISCe_MaxLng(ByRef base As Long, ByRef compare As Long) As Long
If compare < base Then
MISCe_MaxLng = base
Exit Function
End If
If compare = base Then
MISCe_MaxLng = compare
Exit Function
End If
If compare > base Then
MISCe_MaxLng = compare
Exit Function
End If
End Function
Public Function markdown_from_table(ByRef tbl() As Variant, Optional number_format As String) As String
Dim msl() As Integer
Dim md As String
Dim r As Integer
Dim c As Integer
ReDim msl(UBound(tbl, 2))
'---determine max string length per column----
For c = 1 To UBound(tbl, 2)
For r = 1 To UBound(tbl, 1)
If Len(tbl(r, c)) > msl(c) Then msl(c) = Len(tbl(r, c))
Next r
Next c
'---build markdown table-----------
For r = 1 To UBound(tbl, 1)
If r = 2 Then
'If IsNumeric(tbl(r, c)) And Mid(tbl(r, c), 1, 1) <> 0 Then
md = md & "|"
For c = 1 To UBound(tbl, 2)
md = md & "---" & String(Me.MISCe_MaxInt(msl(c), 3) - 3, "-") & "|"
Next c
md = md & vbCrLf
End If
md = md & "|"
For c = 1 To UBound(tbl, 2)
md = md & tbl(r, c) & String(Me.MISCe_MaxInt(msl(c), 3) - Len(tbl(r, c)), " ") & "|"
Next c
md = md & vbCrLf
Next r
markdown_from_table = md
End Function
Public Function json_multirange(ByRef r As Range) As String
Dim ar As Range
Dim r1() As Variant
Dim r2() As Variant
Dim rslt As String
Dim d() As String
Dim i As Integer
Dim dest As String
i = 1
For Each ar In r.Areas
r1 = ar
If i > 1 Then
rslt = rslt & "," & Me.json_from_table(r1, CStr(r1(1, 1)), True)
Else
rslt = Me.json_from_table(r1, CStr(r1(1, 1)), True)
End If
i = i + 1
Next ar
rslt = "{" & rslt & "}"
json_multirange = rslt
End Function
Function markdown_whole_sheet(ByRef sh As Worksheet) As String
Dim mr As Long
Dim mc As Long
Dim ir As Long
Dim ic As Long
Dim x As New TheBigOne
Dim tbl() As Variant
tbl = sh.Range("A1:CZ1000").FormulaR1C1
For ic = 1 To UBound(tbl, 2)
For ir = 1 To UBound(tbl, 1)
If tbl(ir, ic) <> "" Then
mr = x.MISCe_MaxLng(ir, mr)
mc = x.MISCe_MaxLng(ic, mc)
End If
Next ir
Next ic
tbl = sh.Range(sh.Cells(1, 1).address & ":" & sh.Cells(mr, mc).address).FormulaR1C1
markdown_whole_sheet = Me.markdown_from_table(tbl)
End Function
Function MISCe_col_to_letter(ByRef x As Long) As String
If x > 26 Then
MISCe_colnum_to_letter = Chr(x \ 26 + 64) & Chr((x / 26 - x \ 26) * 26 + 64)
Else
MISCe_colnum_to_letter = Chr(x + 64)
End If
End Function
optional param for pre-determined column types to be supplied instead of guessing
2021-03-15 15:40:43 -04:00
Public Function SQLp_build_sql_values(ByRef tbl() As String, trim As Boolean, headers As Boolean, syntax As SQLsyntax, ByRef quote_headers As Boolean, ParamArray typeflag()) As String
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
Dim i As Long
Dim j As Long
add function
2022-02-09 10:55:59 -05:00
Dim k As Long
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
Dim sql As String
Dim rec As String
Dim type_flag() As String
Dim col_name As String
Dim start_row As Long
use regex to better parse data for SQL loading
2020-01-29 13:30:53 -05:00
Dim rx As Object
Dim strip_text As String
Dim strip_num As String
Dim strip_date As String
optional param for pre-determined column types to be supplied instead of guessing
2021-03-15 15:40:43 -04:00
Dim nullText As String
If syntax = PostgreSQL Then
nullText = "text"
Else
nullText = "varchar(255)"
End If
use regex to better parse data for SQL loading
2020-01-29 13:30:53 -05:00
Set rx = CreateObject("vbscript.regexp")
rx.Global = True
work with target price generation
2021-10-07 18:28:15 -04:00
strip_text = "[^a-zA-Z0-9 \(\)\&\'\.\-\_\,\#\""\:]"
use regex to better parse data for SQL loading
2020-01-29 13:30:53 -05:00
strip_num = "[^0-9\.]"
add characters
2020-02-13 02:19:15 -05:00
strip_date = "[^0-9\/\-\:\.]"
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
optional param for pre-determined column types to be supplied instead of guessing
2021-03-15 15:40:43 -04:00
'------if a type flag array has been supplied copy its contents---------------
If UBound(typeflag) <> -1 Then
ReDim type_flag(UBound(typeflag))
For i = 0 To UBound(typeflag)
type_flag(i) = typeflag(i)
Next i
Else
ReDim type_flag(UBound(tbl, 1))
For j = LBound(tbl, 1) To UBound(tbl, 1)
If IsNumeric(tbl(j, LBound(tbl, 2) + 1)) Then
If InStr(1, tbl(j, 1), ".") > 0 Then
type_flag(j) = "N"
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
Else
type_flag(j) = "S"
End If
Else
optional param for pre-determined column types to be supplied instead of guessing
2021-03-15 15:40:43 -04:00
If Len(tbl(j, 1)) >= 6 Then
If IsDate(tbl(j, 1)) Then
type_flag(j) = "D"
Else
type_flag(j) = "S"
End If
Else
type_flag(j) = "S"
End If
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
End If
optional param for pre-determined column types to be supplied instead of guessing
2021-03-15 15:40:43 -04:00
Next j
End If
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
use regex to better parse data for SQL loading
2020-01-29 13:30:53 -05:00
rx.Pattern = strip_text
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
If headers Then
optional param for pre-determined column types to be supplied instead of guessing
2021-03-15 15:40:43 -04:00
start_row = LBound(tbl, 2) + 1
For i = LBound(tbl, 1) To UBound(tbl, 1)
If i > LBound(tbl, 1) Then col_name = col_name & ","
use regex to better parse data for SQL loading
2020-01-29 13:30:53 -05:00
If quote_headers Then
add 2 subroutines and SQL formatting
2021-06-16 09:03:23 -04:00
col_name = col_name & """" & Replace(rx.Replace(tbl(i, LBound(tbl, 2)), ""), "'", "''") & """"
use regex to better parse data for SQL loading
2020-01-29 13:30:53 -05:00
Else
add 2 subroutines and SQL formatting
2021-06-16 09:03:23 -04:00
col_name = col_name & Replace(rx.Replace(tbl(i, LBound(tbl, 2)), ""), "'", "''")
use regex to better parse data for SQL loading
2020-01-29 13:30:53 -05:00
End If
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
Next i
Else
optional param for pre-determined column types to be supplied instead of guessing
2021-03-15 15:40:43 -04:00
start_row = LBound(tbl, 2)
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
End If
use regex to better parse data for SQL loading
2020-01-29 13:30:53 -05:00
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
For i = start_row To UBound(tbl, 2)
rec = ""
If i <> start_row Then sql = sql & "," & vbCrLf
rec = rec & "("
add function
2022-02-09 10:55:59 -05:00
k = 0
optional param for pre-determined column types to be supplied instead of guessing
2021-03-15 15:40:43 -04:00
For j = LBound(tbl, 1) To UBound(tbl, 1)
If j <> LBound(tbl, 1) Then rec = rec & ","
add function
2022-02-09 10:55:59 -05:00
Select Case type_flag(k)
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
Case "N" '-------N = numeric but should probably be N for numeric----
use regex to better parse data for SQL loading
2020-01-29 13:30:53 -05:00
rx.Pattern = strip_num
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
If tbl(j, i) = "" Then
rec = rec & "CAST(NULL AS NUMERIC)"
Else
add 2 subroutines and SQL formatting
2021-06-16 09:03:23 -04:00
rec = rec & Replace(rx.Replace(tbl(j, i), ""), "'", "''")
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
End If
Case "S" '-------S = string------------------------------------------
use regex to better parse data for SQL loading
2020-01-29 13:30:53 -05:00
rx.Pattern = strip_text
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
If LTrim(RTrim(tbl(j, i))) = "" Then
optional param for pre-determined column types to be supplied instead of guessing
2021-03-15 15:40:43 -04:00
rec = rec & "CAST(NULL AS " & nullText & ")"
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
Else
If trim Then
add 2 subroutines and SQL formatting
2021-06-16 09:03:23 -04:00
rec = rec & "'" & Replace(LTrim(RTrim(rx.Replace(tbl(j, i), ""))), "'", "''") & "'"
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
Else
add 2 subroutines and SQL formatting
2021-06-16 09:03:23 -04:00
rec = rec & "'" & Replace(rx.Replace(tbl(j, i), ""), "'", "''") & "'"
use regex to better parse data for SQL loading
2020-01-29 13:30:53 -05:00
include a new data type flag to prevent running regex on special characters that should be retained instead of removed
2022-03-31 12:35:18 -04:00
End If
End If
Case "A" '-------A = string but dont apply any regex------------------
rx.Pattern = strip_text
If LTrim(RTrim(tbl(j, i))) = "" Then
rec = rec & "CAST(NULL AS " & nullText & ")"
Else
If trim Then
rec = rec & "'" & Replace(LTrim(RTrim(tbl(j, i))), "'", "''") & "'"
Else
rec = rec & "'" & Replace(tbl(j, i), "'", "''") & "'"
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
End If
End If
Case "D" '-------D = date---------------------------------------------
use regex to better parse data for SQL loading
2020-01-29 13:30:53 -05:00
rx.Pattern = strip_date
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
If LTrim(RTrim(tbl(j, i))) = "" Then
rec = rec & "CAST(NULL AS DATE)"
Else
add 2 subroutines and SQL formatting
2021-06-16 09:03:23 -04:00
rec = rec & "CAST('" & Replace(rx.Replace(tbl(j, i), ""), "'", "''") & "' AS DATE)"
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
End If
Case Else '-------Assume text------------------------------------------
use regex to better parse data for SQL loading
2020-01-29 13:30:53 -05:00
rx.Pattern = strip_text
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
If LTrim(RTrim(tbl(j, i))) = "" Then
optional param for pre-determined column types to be supplied instead of guessing
2021-03-15 15:40:43 -04:00
rec = rec & "CAST(NULL AS " & nullText & ")"
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
Else
If trim Then
add 2 subroutines and SQL formatting
2021-06-16 09:03:23 -04:00
rec = rec & "'" & Replace(LTrim(RTrim(rx.Replace(tbl(j, i), ""))), "'", "''") & "'"
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
Else
add 2 subroutines and SQL formatting
2021-06-16 09:03:23 -04:00
rec = rec & "'" & Replace(rx.Replace(tbl(j, i), ""), "'", "''") & "'"
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
End If
End If
End Select
add function
2022-02-09 10:55:59 -05:00
k = k + 1
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
Next j
rec = rec & ")"
sql = sql & rec
Next i
'---------build select--------------------------
Select Case syntax
Case SQLsyntax.Db2
sql = "SELECT * FROM TABLE( VALUES" & vbCrLf & sql & vbCrLf & ") x"
Case SQLsyntax.SqlServer
sql = "SELECT * FROM (VALUES" & vbCrLf & sql & vbCrLf & ") x"
Case SQLsyntax.PostgreSQL
sql = "SELECT * FROM (VALUES" & vbCrLf & sql & vbCrLf & ") x"
End Select
If headers Then sql = sql & "(" & col_name & ")"
'---------final assignment----------------------
SQLp_build_sql_values = sql
End Function
add function
2022-02-09 10:55:59 -05:00
Public Function SQLp_build_sql_values_ranged(ByRef tbl() As String, trim As Boolean, headers As Boolean, syntax As SQLsyntax, ByRef quote_headers As Boolean, start_row As Long, end_row As Long, ParamArray typeflag()) As String
Dim i As Long
Dim j As Long
Dim k As Long
Dim sql As String
Dim rec As String
Dim type_flag() As String
Dim col_name As String
Dim header_row As Long
Dim rx As Object
Dim strip_text As String
Dim strip_num As String
Dim strip_date As String
Dim nullText As String
If syntax = PostgreSQL Then
nullText = "text"
Else
nullText = "varchar(255)"
End If
Set rx = CreateObject("vbscript.regexp")
rx.Global = True
strip_text = "[^a-zA-Z0-9 \(\)\&\'\.\-\_\,\#\""\:]"
strip_num = "[^0-9\.]"
strip_date = "[^0-9\/\-\:\.]"
'------if a type flag array has been supplied copy its contents---------------
If UBound(typeflag) <> -1 Then
ReDim type_flag(UBound(typeflag))
For i = 0 To UBound(typeflag)
type_flag(i) = typeflag(i)
Next i
Else
ReDim type_flag(UBound(tbl, 1))
For j = LBound(tbl, 1) To UBound(tbl, 1)
If IsNumeric(tbl(j, LBound(tbl, 2) + 1)) Then
If InStr(1, tbl(j, 1), ".") > 0 Then
type_flag(j) = "N"
Else
type_flag(j) = "S"
End If
Else
If Len(tbl(j, 1)) >= 6 Then
If IsDate(tbl(j, 1)) Then
type_flag(j) = "D"
Else
type_flag(j) = "S"
End If
Else
type_flag(j) = "S"
End If
End If
Next j
End If
rx.Pattern = strip_text
If headers Then
header_row = LBound(tbl, 2) + 1
For i = LBound(tbl, 1) To UBound(tbl, 1)
If i > LBound(tbl, 1) Then col_name = col_name & ","
If quote_headers Then
col_name = col_name & """" & Replace(rx.Replace(tbl(i, LBound(tbl, 2)), ""), "'", "''") & """"
Else
col_name = col_name & Replace(rx.Replace(tbl(i, LBound(tbl, 2)), ""), "'", "''")
End If
Next i
Else
header_row = LBound(tbl, 2)
End If
For i = start_row To end_row
rec = ""
If i <> start_row Then sql = sql & "," & vbCrLf
rec = rec & "("
k = 0
For j = LBound(tbl, 1) To UBound(tbl, 1)
If j <> LBound(tbl, 1) Then rec = rec & ","
Select Case type_flag(k)
Case "N" '-------N = numeric but should probably be N for numeric----
rx.Pattern = strip_num
If tbl(j, i) = "" Then
rec = rec & "CAST(NULL AS NUMERIC)"
Else
rec = rec & Replace(rx.Replace(tbl(j, i), ""), "'", "''")
End If
Case "S" '-------S = string------------------------------------------
rx.Pattern = strip_text
If LTrim(RTrim(tbl(j, i))) = "" Then
rec = rec & "CAST(NULL AS " & nullText & ")"
Else
If trim Then
rec = rec & "'" & Replace(LTrim(RTrim(rx.Replace(tbl(j, i), ""))), "'", "''") & "'"
Else
rec = rec & "'" & Replace(rx.Replace(tbl(j, i), ""), "'", "''") & "'"
End If
End If
Case "D" '-------D = date---------------------------------------------
rx.Pattern = strip_date
If LTrim(RTrim(tbl(j, i))) = "" Then
rec = rec & "CAST(NULL AS DATE)"
Else
rec = rec & "CAST('" & Replace(rx.Replace(tbl(j, i), ""), "'", "''") & "' AS DATE)"
End If
Case Else '-------Assume text------------------------------------------
rx.Pattern = strip_text
If LTrim(RTrim(tbl(j, i))) = "" Then
rec = rec & "CAST(NULL AS " & nullText & ")"
Else
If trim Then
rec = rec & "'" & Replace(LTrim(RTrim(rx.Replace(tbl(j, i), ""))), "'", "''") & "'"
Else
rec = rec & "'" & Replace(rx.Replace(tbl(j, i), ""), "'", "''") & "'"
End If
End If
End Select
k = k + 1
Next j
rec = rec & ")"
sql = sql & rec
Next i
'---------build select--------------------------
Select Case syntax
Case SQLsyntax.Db2
sql = "SELECT * FROM TABLE( VALUES" & vbCrLf & sql & vbCrLf & ") x"
Case SQLsyntax.SqlServer
sql = "SELECT * FROM (VALUES" & vbCrLf & sql & vbCrLf & ") x"
Case SQLsyntax.PostgreSQL
sql = "SELECT * FROM (VALUES" & vbCrLf & sql & vbCrLf & ") x"
End Select
If headers Then sql = sql & "(" & col_name & ")"
'---------final assignment----------------------
SQLp_build_sql_values_ranged = sql
End Function
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
Public Function ARRAYp_get_range_string(ByRef r As Range) As String()
Dim i As Long
Dim j As Long
Dim t1() As Variant
Dim t2() As String
t1 = r
'---convert to 0 lower bound array----
ReDim t2(UBound(t1, 1) - 1, UBound(t1, 2) - 1)
For i = 1 To UBound(t1, 1)
For j = 1 To UBound(t1, 2)
t2(i - 1, j - 1) = CStr(t1(i, j))
Next j
Next i
Call Me.ARRAYp_Transpose(t2)
ARRAYp_get_range_string = t2
End Function
Public Function TBLp_range(ByRef dump() As Variant, ByVal upperleft As Range) As Range
Dim width As Long
width = UBound(dump, 2)
Dim newcol As String
newcol = ConvertBase10(upperleft.column + UBound(dump, 2), "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
End Function
Public Function Misc_ConvBase10(ByVal d As Double, ByVal sNewBaseDigits As String) As String
'credit: http://www.freevbcode.com/ShowCode.asp?ID=6604
Dim s As String, tmp As Double, i As Integer, lastI As Integer
Dim BaseSize As Integer
BaseSize = Len(sNewBaseDigits)
updates
2020-09-15 13:02:06 -04:00
Do While Val(d) <> 0
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
tmp = d
i = 0
Do While tmp >= BaseSize
i = i + 1
tmp = tmp / BaseSize
Loop
If i <> lastI - 1 And lastI <> 0 Then s = s & String(lastI - i - 1, Left(sNewBaseDigits, 1)) 'get the zero digits inside the number
tmp = Int(tmp) 'truncate decimals
s = s + Mid(sNewBaseDigits, tmp + 1, 1)
d = d - tmp * (BaseSize ^ i)
lastI = i
Loop
s = s & String(i, Left(sNewBaseDigits, 1)) 'get the zero digits at the end of the number
Misc_ConvBase10 = s
End Function
Public Function SHTp_get_block(point As Range) As Variant()
' Dim left As Long
' Dim right As Long
' Dim top As Long
' Dim bot As Long
' Dim i As Long
' Dim lcol As String
' Dim rcol As String
' Dim r As Range
'
'
' i = 0
' Do Until point.Worksheet.Cells(point.row, point.column + i) = ""
' i = i + 1
' Loop
' If i <> 0 Then i = i - 1
' right = point.column + i
'
' i = 0
' Do Until point.Worksheet.Cells(point.row, point.column + i) = ""
' i = i - 1
' Loop
' If i <> 0 Then i = i + 1
' left = point.column + i
'
' i = 0
' Do Until point.Worksheet.Cells(point.row + i, point.column) = ""
' i = i + 1
' Loop
' If i <> 0 Then i = i - 1
' bot = point.row + i
'
' i = 0
' Do Until point.Worksheet.Cells(point.row + i, point.column) = ""
' i = i - 1
' If point.row + i < 1 Then Exit Do
' Loop
' If i <> 0 Then i = i + 1
' top = point.row + i
'
' lcol = Me.ColumnLetter(left)
' rcol = Me.ColumnLetter(right)
'point.row (right)
SHTp_get_block = point.CurrentRegion
End Function
Public Function SHTp_GetString(point As Range) As String()
Dim x() As String
Dim pl() As Variant
pl = point.CurrentRegion
SHTp_GetString = Me.TBLp_Transpose(Me.TBLp_VarToString(pl))
End Function
Function ColumnLetter(ColumnNumber As Long) As String
Dim n As Long
Dim c As Byte
Dim s As String
n = ColumnNumber
Do
c = ((n - 1) Mod 26)
s = Chr(c + 65) & s
n = (n - c) \ 26
Loop While n > 0
ColumnLetter = s
End Function
Function TBLp_TestNumeric(ByRef table() As String, ByRef column As Long) As Boolean
Dim i As Long
Dim j As Long
Dim m As Long
TBLp_TestNumeric = True
j = 0
i = 1
For i = 1 To UBound(table, 2)
If Not IsNumeric(table(column, i)) And table(column, i) <> "" Then
TBLp_TestNumeric = False
Exit Function
End If
Next i
End Function
Function TBLp_Transpose(ByRef t() As String) As String()
Dim i As Long
Dim j As Long
Dim x() As String
If LBound(t, 1) = 1 Then
End If
ReDim x(LBound(t, 2) To UBound(t, 2), LBound(t, 1) To UBound(t, 1))
updates
2020-09-15 13:02:06 -04:00
For i = LBound(t, 2) To UBound(t, 2)
For j = LBound(t, 1) To UBound(t, 1)
utf-8 was causing strange characters in CMS, should make a param
2020-01-13 17:26:32 -05:00
x(i, j) = t(j, i)
Next j
Next i
TBLp_Transpose = x
End Function
Function TBLp_VarToString(ByRef t() As Variant) As String()
Dim i As Long
Dim j As Long
Dim x() As String
If LBound(t, 1) = 1 Then
End If
ReDim x(LBound(t, 1) To UBound(t, 1), LBound(t, 2) To UBound(t, 2))
For i = LBound(t, 1) To UBound(t, 1)
For j = LBound(t, 2) To UBound(t, 2)
x(i, j) = t(i, j)
Next j
Next i
TBLp_VarToString = x
End Function
add a new route for swapping out parts
2020-03-05 01:08:10 -05:00
updates
2020-09-15 13:02:06 -04:00
Function TBLp_StringToVar(ByRef t() As String) As Variant()
Dim i As Long
Dim j As Long
Dim x() As Variant
If LBound(t, 1) = 1 Then
End If
ReDim x(LBound(t, 1) To UBound(t, 1), LBound(t, 2) To UBound(t, 2))
For i = LBound(t, 1) To UBound(t, 1)
For j = LBound(t, 2) To UBound(t, 2)
x(i, j) = t(i, j)
Next j
Next i
TBLp_StringToVar = x
End Function
Sub frmListBoxHeader(ByRef hdr As MSForms.ListBox, ByRef det As MSForms.ListBox, ParamArray cols())
add a new route for swapping out parts
2020-03-05 01:08:10 -05:00
Dim i As Long
hdr.ColumnCount = det.ColumnCount
hdr.ColumnWidths = det.ColumnWidths
' add header elements
hdr.clear
hdr.AddItem
For i = 0 To UBound(cols, 1)
hdr.list(0, i) = cols(i)
Next i
' make it pretty
'body.ZOrder (1)
'lbHEAD.ZOrder (0)
hdr.SpecialEffect = fmSpecialEffectFlat
'hdr.BackColor = RGB(200, 200, 200)
hdr.Height = 10
' align header to body (should be done last!)
hdr.width = det.width
hdr.Left = det.Left
hdr.Top = det.Top - (hdr.Height - 1)
End Sub
updates
2020-09-15 13:02:06 -04:00
Reference in New Issue Copy Permalink