Option Explicit
' filenames less extension. also worksheet names
Private Const FNM_BOOSTERS = "boosters#csv"
Private Const FNM_CHAFF = "chaff#csv"
Private Const FNM_CHAFF_TABLE = "chaff_table#csv"
Private Const FNM_CLOAKS = "cloaks#csv"
Private Const FNM_DMGTABLE = "dmgtable#csv"
Private Const FNM_DRONES = "drones#csv"
Private Const FNM_FACTIONS = "factions#csv"
Private Const FNM_MINES = "mines#csv"
Private Const FNM_MISSILES = "missiles#csv"
Private Const FNM_PARTS = "parts#csv"
Private Const FNM_PROBES = "probes#csv"
Private Const FNM_PROJECTILES = "projectiles#csv"
Private Const FNM_SHIELDS = "shields#csv"
Private Const FNM_SHIPS = "ships#csv"
Private Const FNM_STATIONS = "stations#csv"
Private Const FNM_TECH = "tech#csv"
Private Const FNM_TREASURE = "treasure#csv"
Private Const FNM_WEAPONS = "weapons#csv"
Private cn As New ADODB.Connection 'better if public in a module
Private Sub form_Load()
Dim T1 As Variant
Dim T2 As Variant
'method 1
T1 = Now
Dim sTmp As String
sTmp = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & _
App.Path & "\dn_000450\;Extended Properties=""text;HDR=Yes;FMT=Delimited"""
cn.Open sTmp
txt1.Text = Join(getdata(FNM_TECH, "name"), vbCrLf)
'Debug.Print "FNM_BOOSTERS" & vbCrLf & Join(GetData(FNM_BOOSTERS, "description"), vbCrLf) & vbCrLf
T2 = Now
txt1.Text = txt1.Text & vbCrLf & Format(DateDiff("s", T1, T2), "0") & " s"
'method 2
T1 = Now
Dim rsRet As ADODB.Recordset
Call GetDataEx(rsRet, FNM_TECH, "name")
If Not (rsRet Is Nothing) Then
txt2.Text = rsRet.GetString(, , vbTab, vbCrLf, "")
rsRet.Close
Set rsRet = Nothing
End If
T2 = Now
txt2.Text = txt2.Text & vbCrLf & Format(DateDiff("s", T1, T2), "0") & " s"
'method 3
T1 = Now
txt3.Text = Join(ggetdata("tech", "name"), vbCrLf)
T2 = Now
txt3.Text = txt3.Text & vbCrLf & Format(DateDiff("s", T1, T2), "0") & " s"
End Sub
Private Sub frm1_Unload()
If cn.State <> adStateClosed Then cn.Close
Set cn = Nothing
MsgBox ("close")
End Sub
Public Function getdata(ByVal tblname As String, ByVal colname As String) As String()
Dim rs As ADODB.Recordset
Dim sTmp As String
Dim bOk As Boolean
If cn.State = adStateClosed Then Exit Function
'check if tblname+colname exists
bOk = True 'init retval
Set rs = cn.OpenSchema(adSchemaColumns, Array(Empty, Empty, tblname, colname))
If rs Is Nothing Then
bOk = False 'error, unable to return recordset
ElseIf rs.BOF And rs.EOF Then
bOk = False 'error, tblname+colname does not exist
rs.Close
Else
rs.Close
End If
'query
If bOk Then
rs.CursorLocation = adUseClient
rs.Open "SELECT " & colname & " FROM " & tblname, cn, adOpenStatic
If rs.BOF And rs.EOF Then 'no records
rs.Close
Else
sTmp = rs.GetString(, , vbTab, vbCrLf, "")
getdata = Split(sTmp, vbCrLf) 'since your original implementation returned strings
rs.Close
End If
End If
Set rs = Nothing
End Function
Public Function GetDataEx(ByRef rsRet As ADODB.Recordset, ByVal tblname As String, ByVal colname As String) As Long
Dim sTmp As String
Dim bOk As Boolean
GetDataEx = -1 'init retval failed
If cn.State = adStateClosed Then Exit Function
'check if tblname+colname exists
bOk = True 'init retval
Set rsRet = cn.OpenSchema(adSchemaColumns, Array(Empty, Empty, tblname, colname))
If rsRet Is Nothing Then
bOk = False 'error, unable to return recordset
ElseIf rsRet.BOF And rsRet.EOF Then
bOk = False 'error, tblname+colname does not exist
rsRet.Close
Else
rsRet.Close
End If
'query
If bOk Then
rsRet.CursorLocation = adUseClient
rsRet.Open "SELECT " & colname & " FROM " & tblname, cn, adOpenStatic
GetDataEx = 0 'retval success
End If
End Function
Public Function ggetdata(file As String, var As String) As String()
''''''''''
Dim sfile As String
sfile = App.Path & "\dn_000450\" & file & ".csv"
Dim myArray() As String
ReDim myArray(0)
Open sfile For Input As #1
Do Until EOF(1)
Input #1, myArray(UBound(myArray))
ReDim Preserve myArray(UBound(myArray) + 1)
Loop
ReDim Preserve myArray(UBound(myArray) - 1)
Close #1
''''''''''''''
'get the number of varable names (use numofvarname for step)
Dim numofvarname As Integer
numofvarname = 0
Do Until myArray(numofvarname) = ""
numofvarname = numofvarname + 1
Loop
'MsgBox ("number of varable names: " & numofvarname & " : " & myArray(numofvarname))
'match the varble names
Dim varnameindex
Dim i As Integer
For i = LBound(myArray()) To UBound(myArray())
If myArray(i) = var Then varnameindex = i: Exit For
If i > numofvarname Then varnameindex = -1: MsgBox ("ERROR:" & vbCrLf & "Varable: " & var & " Not found in: " & file): Exit For
Next i
'MsgBox ("Varable name index: " & varnameindex & vbCrLf & "Reads: " & myArray(varnameindex))
'gather varable array (text seems to come out correct)
Dim index As Integer
index = 0
Dim vararray() As String
ReDim vararray(0)
For i = (LBound(myArray()) + numofvarname - 1) To UBound(myArray()) Step (numofvarname + 1)
ReDim Preserve vararray(UBound(vararray) + 1)
If (i + varnameindex + 2) <= UBound(myArray()) Then vararray(index) = myArray(i + varnameindex + 2)
index = index + 1
Next i
ReDim Preserve vararray(UBound(vararray) - 2)
ggetdata = vararray()
End Function
