I'm trying to get pdf file by tenant_id using docmd.outputTo. Unfortunately this routine produce output pdf file that all are in a same single tenant_id. If I remove docmd.outputTo last parameter pathName & fileName then it's require file name through dialogue and output file nicely filtered by tenant_id. Any help would be appreciated.
Here's the query of invoice: SELECT * FROM tblInvoice WHERE tenant_id = CurTenantID()
Public Sub Output()
Dim MyRs As DAO.Recordset
Dim rpt As Report
Dim fileName As String, pathName As String, todayDate As String
pathName = "C:\Users\abzalali\Dropbox\tenant_db\Invoice\"
todayDate = Format(Date, "MMDDYYYY")
Set MyRs = CurrentDb.OpenRecordset("SELECT tenant_id, name, company, email FROM qryEmailClientList")
DoCmd.OpenReport "Invoice", acPreview, , , acHidden
Set rpt = Reports("Invoice")
With MyRs
.MoveFirst
Do While Not .EOF
fileName = "Invoice_" & todayDate & !tenant_id & ".pdf"
rpt.Filter = "[tenant_id] = " & !tenant_id
rpt.FilterOn = True
DoCmd.OutputTo acOutputReport, "Invoice", acFormatPDF, pathName & fileName
.MoveNext
Loop
End With
End Sub
Simply use the DoCmd.OpenReport method to filter report and then leave the report name blank in DoCmd.OutputTo as per the docs:
ObjectName > Optional > Variant: If you want to output the active object, specify the object's type for the ObjectType argument and leave this argument blank.
With MyRs
.MoveFirst
Do While Not .EOF
fileName = "Invoice_" & todayDate & !tenant_id & ".pdf"
DoCmd.OpenReport "Invoice", acViewReport, , "[tenant_id] = " & !tenant_id, acHidden
DoCmd.OutputTo acOutputReport, , acFormatPDF, pathName & fileName
.MoveNext
Loop
End With
Since DoCmd.OutputTo lacks parameters for filtering, the best option is to base the report on a public function to get the current ID.
E.g.
' Function to both set and retrieve the current Tenant ID
Public Function CurTenantID(Optional SetTenantID As Long = 0) As Long
Static TenantID As Long
If SetTenantID > 0 Then
TenantID = SetTenantID
End If
CurTenantID = TenantID
End Function
Your report uses this function in its record source, e.g.
SELECT * FROM tblInvoice WHERE tenant_id = CurTenantID()
And when generating the PDF reports in the loop, you use the SetTenantID parameter:
Public Sub Output()
Dim MyRs As DAO.Recordset
Dim fileName As String, pathName As String, todayDate As String
pathName = "C:\Users\abzalali\Dropbox\tenant_db\Invoice\"
todayDate = Format(Date, "MMDDYYYY")
Set MyRs = CurrentDb.OpenRecordset("SELECT tenant_id, name, company, email FROM qryEmailClientList")
With MyRs
' .MoveFirst -- unneeded after OpenRecordset()
Do While Not .EOF
fileName = "Invoice_" & todayDate & !tenant_id & ".pdf"
Call CurTenantID(!tenant_id)
DoCmd.OutputTo acOutputReport, "Invoice", acFormatPDF, pathName & fileName
.MoveNext
Loop
End With
End Sub
Related
I have a simple VBA script in Outlook 2019, script zips an attachment before sending an email, creates a new email, attaches an attachment, and sends it to the recipient. My goal is to save selected data to SQL database, Such as .To,From and zip archive as binaryattachment.zip. I have a problem finding a command to send INSERT INTO to the database, is there such a possibility?
VBA script:
#If VBA7 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal milliseconds As LongPtr) 'MS Office 64 Bit
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal milliseconds As Long) 'MS Office 32 Bit
#End If
Function FileExists(FilePath As String) As Boolean
Dim TestStr As String
TestStr = ""
On Error Resume Next
TestStr = Dir(FilePath)
On Error GoTo 0
If TestStr = "" Then
FileExists = False
Else
FileExists = True
End If
End Function
Sub MainFunction()
Const cstrFolderAttachment As String = "C:\attachments\"
'Test 32/64 bit
Dim PathZipProgram As String
PathZipProgram = "C:\Program Files\7-Zip\7z.exe"
If Not FileExists(PathZipProgram) Then
PathZipProgram = "C:\Program Files (x86)\7-Zip\7z.exe"
End If
'Password lenght
Const cintLenghtPassword As Integer = 8
'User signature file
Const cstrFileSigntature As String = "signature.htm"
Dim objMail As Outlook.MailItem
Dim objNewMail1 As Outlook.MailItem
Dim objNewMail2 As Outlook.MailItem
Dim objAttachment As Attachment
Dim objWord As Object
Dim objDocument As Object
Dim objFSO As Object
Dim objTextStream As Object
Dim strTo As String
Dim strSubject As String
Dim strBody As String
Dim strCommand As String
Dim strFilePath As String
Dim objWordRange As Object
Dim strMessage As String
Dim objApp As Object
Dim objInsp As Object
'Set objApp = GetObject("", "Outlook.Application")
'Set objInsp = objApp.ActiveInspector.CurrentItem
Dim signature As String
Dim objNS As Outlook.NameSpace
Dim objFolderItem As Outlook.Folder
Select Case Application.ActiveWindow.Class
Case olExplorer
Set objMail = ActiveExplorer.Selection.Item(1)
Case olInspector
Set objMail = ActiveInspector.CurrentItem
End Select
strMessage = "Subject: " & objMail.Subject & vbCrLf & vbCrLf & "Message: " & vbCrLf & objMail.Body
'Clear subfolder
On Error Resume Next
Kill cstrFolderAttachment & "*.*"
Kill cstrFolderAttachment & "Zip\*.*"
On Error GoTo 0
Set objMail = Application.ActiveInspector.CurrentItem
Set objNS = Application.GetNamespace("MAPI")
Set objFolderItem = objNS.Folders.Item("name.surname#domaind.com").Folders.Item("Temp")
objMail.Move objFolderItem
objDokument.Close False
'clear variables
Set objDokument = Nothing
Set objWord = Nothing
'save all attechments to folder
For Each objAttachment In objMail.Attachments
objAttachment.SaveAsFile cstrFolderAttachment & objAttachment.FileName
Next objAttachment
'7zip comprimation
strSource = cstrFolderAttachment & "*.*"
strDestination = cstrFolderAttachment & "Zip\attachment.zip"
strPassword = RandomPassword(cintLenghtPassword)
strCommand = """" & PathZipProgram & """ a -tzip """ & strCil & _
""" -p" & strPassword & " """ & strSource & """"
Shell strCommand
'Application.Wait (Now + TimeSerial(0, 0, cintBreak))
Call Sleep(1000 * cintBreak)
'FSO
strstrFilePath = Environ("appdata") & _
"\Microsoft\Signatures\" & cstrFileSigntature
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextStream = _
objFSO.GetFile(cstrFileSigntature).OpenAsTextStream(1, -2)
strSignature = objTextStream.ReadAll
objTextStream.Close
'clear variables
Set objTextStream = Nothing
Set objFSO = Nothing
Set objNewMail1 = Application.CreateItem(olMailItem)
With objNewMail1
'To
For Each recip In objMail.Recipients
Set newRecip = .Recipients.Add(recip.Address)
newRecip.Type = recip.Type
Next
.Subject = strSubject
.BodyFormat = olFormatHTML
.HTMLBody = strSignature
.Attachments.Add cstrFolderAttachment & "Zip\attachment.zip"
.Display
.Send
End With
objNewMail1.Close olSave
'clear variables
Set objMail = Nothing
Set objNewMail1 = Nothing
i = MsgBox("Email sended.", , "info box")
End Sub
Private Function RandomPassword(Delka As Integer)
'Dave Hawley
Dim i As Integer
Dim strHeslo As String
Randomize
For i = 1 To Lenght
If i Mod 2 = 0 Then
strPassword = Chr(Int((90 - 65 + 1) * Rnd + 65)) & strPassword
Else
strPassword = Int((9 * Rnd) + 1) & strPassword
End If
Next i
RandomPassword = strPassword
End Function
Database structure:
ID INT NOT NULL IDENTITY(1,1) PRIMARY KEY,
to_email VARCHAR(100) NOT NULL,
from_email VARCHAR(100) NOT NULL,
attachment VARBINARY(MAX) NOT NULL,
date_create DATETIME NOT NULL,
file_size INT NOT NULL
Currently I have a table where the 'ID' field is automatically generated through a combination of multiple other fields. Example : ID = '2017_FileName_Chancellor'
Now I've been trying to figure out a way for me to rename this attachment to that ID (by possibly pressing a button in the form)without manually copy pasting the ID and renaming the attached file as that would be tedious when doing it for thousands of records. Is there anyway for me to do this? I have no knowledge in VBA so I could not tamper with that.
Providing a picture of my table might help https://i.imgur.com/gaTUCtk.png
To Change the Name of the Attachment in Access:
Private Sub Command15_Click()
Dim NewName As String
Dim NewNameWithExt As String
NewName = Me.TestID.Value
NewNameWithExt = NewName & ".txt"
DoCmd.RunSQL ("UPDATE TestTable SET TestAttachment.FileName = '" &
NewNameWithExt & "' WHERE TestID = " & NewName)
End Sub
To Change the Name of the File on the Desktop:
Private Sub Command0_Click()
Dim NewName As String
Dim OldName As String
Dim rs As Object
Dim strSQL As String
Set rs = CreateObject("ADODB.Recordset")
strSQL = "SELECT TestAttachment.FileName FROM TestTable WHERE TestID = 1"
rs.Open strSQL, CurrentProject.Connection, 1, 3
Do Until rs.EOF
OldName = rs.Fields(0)
NewName = CurrentDb.TableDefs("TestTable").Fields(0).Name
Name "C:\Users\TestUser\desktop\" & OldName As
"C:\Users\TestUser\desktop\" & NewName & ".TXT"
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
End Sub
I've got the attached query, which shows several rows (there is more data) but only 2 email address. I would like to send the corresponding rows to their relevant email address. All these details change every week, and there will be more (and sometimes less) email addresses, so I need to keep the data coming from this form (rather than static addresses). I've tried making a report, and can manage to send that to the email address, but I get multiple forms/emails for this report. The query will show a lot of records, so this is not an acceptable solution.
Any help would be gratefully received.
EDIT - I've attached the tables which show the data. I just want to send each company their own few rows by any means possible. Please help :)
Thanks.
My Full code:
Dim rS As DAO.Recordset
Dim dbS As DAO.Database
Dim Filepath As String
Dim Folderpath As String
Dim oOutlook As Outlook.Application
Dim oEmailItem As MailItem
Set dbS = CurrentDb()
Set rS = dbS.OpenRecordset("Select DISTINCT email, [CompName], [MainContact] FROM q66NonConfirmedTimesheets")
Do While Not rS.EOF
myemail = rS!email
mycompname = rS!CompName
myMainContact = rS!MainContact
'My Email the report
Folderpath = "C:\Reports\"
Folderpath = Folderpath & "WeeklyTimesheet, " & [mycompname] & " - " & Format(date, "dd mmm yyyy") & ".pdf"
DoCmd.OpenReport "Rpt01UnconfirmedTimesheets", acViewPreview, , "email = '" & myemail & "'"
DoCmd.OutputTo acOutputReport, , "PDFFormat(*.pdf)", Folderpath, False
DoCmd.Close acReport, "Rpt01UnconfirmedTimesheets"
If oOutlook Is Nothing Then
Set oOutlook = New Outlook.Application
End If
Set oEmailItem = oOutlook.CreateItem(olMailItem)
With oEmailItem
.to = [myemail]
.Subject = "Unconfirmed Timesheets"
.Body = "Automatic email from my database"
.Attachments.Add Folderpath
.Display
End With
'End of my emailing report
rS.MoveNext
Loop
Set oEmailItem = Nothing
Set oOutlook = Nothing
Set rS = Nothing
Set dbS = Nothing
End Sub
and I've added into my "Onload" event on the Report:
Me.Filter = "[email]='" & myemail & "'"
You need to open a recordset in VBA that contains the unique email addresses.
Loop through the recordset, opening your report, filtering on the email address and emailing the report. Air code:
Dim rS as DAO.Recordset
Dim dbS as DAO.Database
Set dbS = CurrentDb()
Set rS = dbS.OpenRecordset("Select DISTINCT emailaddress FROM <yourquery>",DbOpenSnapshot)
Do While Not rS.EOF
<sometempvar> = rS!emailaddress
'your code to email filtered report using <sometempvar>'
rS.MoveNext
Loop
Set rS = Nothing
Set dbS = Nothing
You need to create a query to only return the emails and specify the query to return unique values only, there is an option for that in the query editor:
I have the following array that contains ticker symbols: Public Shared tickerArray() As String = {"GOOG", "AAPL", "V", "MSFT"}. I need to use this loop: For Each tickerValue In Form1.tickerArray to load the csv file for each ticker symbol into one large table in Microsoft Access. The csv files are located at "http://ichart.yahoo.com/table.csv?s=" & tickerValue. I also need the respective ticker symbol to be loaded into each line of the table that is imported from the csv file in order to make each line unique. So the columns in the database should be: "Ticker, Date, Open, High, Low, Close, Volumne & Adj Close".
I've found information about loading a local csv file into Access but I can't seem to figure out how to load csv files from the internet into Access through vb.net.
Also, I will need to update this table frequently so I need to only insert new unique lines from the csv file. No duplicates.
Any suggestions? Thanks!
UPDATE:
Here is the code I have so far.
Imports System.Data
Imports System.Data.OleDb
Imports System.Net
Imports System.IO
Public Class Form1
Public Shared tickerArray() As String = {"GOOG", "AAPL", "V", "MSFT"}
Private Sub btnUpdate_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnUpdate.Click
Dim myConnection As OleDbConnection
Dim DBpath As String =
Dim sConnectionString As String = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & DBpath & ";Persist Security Info=True"
myConnection = New OleDbConnection(sConnectionString)
myConnection.Open()
Dim strURL As String
Dim strBuffer As String
For Each tickerValue In Form1.tickerArray
'Creates the request URL for Yahoo.
strURL = "http://ichart.yahoo.com/table.csv?s=" & tickerValue
strBuffer = RequestWebData(strURL)
'Create array.
Dim sReader As New StringReader(strBuffer)
Dim List As New List(Of String)
Do While sReader.Peek >= 0
List.Add(sReader.ReadLine)
Loop
Dim lines As String() = List.ToArray
sReader.Close()
For Each Line In lines.Skip(1)
MsgBox(Line)
Dim myInsert As String = TextToInsert(Line, tickerValue)
Dim cmd As New OleDbCommand(myInsert, myConnection)
cmd.ExecuteNonQuery()
Next
Next
End Sub
Function TextToInsert(ByVal inputString As String, ByVal ticker As String)
Dim Dt As String = inputString.Split(",")(0).Trim
Dim Open As String = inputString.Split(",")(1).Trim
Dim High As String = inputString.Split(",")(1).Trim
Dim Low As String = inputString.Split(",")(1).Trim
Dim Close As String = inputString.Split(",")(1).Trim
Dim Volume As String = inputString.Split(",")(1).Trim
Dim Adj_Close As String = inputString.Split(",")(1).Trim
Dim SQLstr As String
SQLstr = "INSERT INTO Historical (Ticker, Date, Open, High, Low, Close, Volume, Adj Close) " & "VALUES (" & "'" & ticker & "','" & Dt & "','" & Open & "','" & High & "'," & "'" & Low & "','" & Close & "','" & Volume & "','" & Adj_Close & "'" & ")"
Return SQLstr
End Function
Private Function RequestWebData(ByVal pstrURL As String) As String
Dim objWReq As WebRequest
Dim objWResp As WebResponse
Dim strBuffer As String
'Contact the website
objWReq = HttpWebRequest.Create(pstrURL)
objWResp = objWReq.GetResponse()
'Read the answer from the Web site and store it into a stream
Dim objSR As StreamReader
objSR = New StreamReader(objWResp.GetResponseStream)
strBuffer = objSR.ReadToEnd
objSR.Close()
objWResp.Close()
Return strBuffer
End Function
End Class
I get error code "OleDBException was unhandled. Syntax error in INSERT INTO statement." at line cmd.ExecuteNonQuery() Please help!
you may use the System.Data.OleDb Namespace to define function to make insert into the db.
Something like (in a very rough way):
Dim myConnection As OleDbConnection
Dim sConnectionString As String = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & DBpath & ";Persist Security Info=True"
myConnection = New OleDbConnection(sConnectionString)
myConnection.Open()
Then make a cycle on each line in the csv
Dim myInsert as String= functionTextToInsert(inputString)
Dim cmd As New OleDbCommand(myInsert, myConnection)
cmd.ExecuteNonQuery()
The functionTextToInsert(ByVal inputString as string) is a function that converts a line from the csv in a insert string: "max;min;vol" -> "Insert into MYTABLE (Column_01,Column_02,Column_03) VALUES (max,min,vol);"
Try this:
Writing large number of records (bulk insert) to Access in .NET/C#
I've never worked with DAO, so I can't be much help here, but...
if this MSSQL syntax works on MS ACCESS, use a command object and pass it a parameter containing your csv as a varchar(max), or similar access data type, which will the content of the CSV from your app:
BULK
INSERT mytable
FROM #myCSVstring
WITH
(
FIELDTERMINATOR = ',',
ROWTERMINATOR = '\n'
)
GO
Two things, the SO post states that DAO is a lot faster, and your terminators may be different, but I'd start with these.
I think the previous answers are unnecessarily complicated. All you need to do it send an XMLHTTP request. That fetches the CSV data as a string, which can then be parsed into a table.
Below is a VBA subroutine that does that. Documentation of where I found the techniques is in the code comments. I've run this in Access 2019, and it works.
The modifications of the data indicated in the question can be performed before or after inserting the data into the table.
Sub pImportOnlineCsvAsTable(sURL As String, sTableName As String, Optional sKey As String)
' Download a CSV file from the Internet and parse it into an Access table (all strings).
' Adapted from "www.stackoverflow.com/questions/52142757/vba-download-csv-from-a-link/#52175815"
' This shows how to download an online CSV file into an ADO stream, then save it as a local file.
' and "www.stackoverflow.com/questions/33860833/convert-adodb-binary-stream-to-string-vba/#33883789"
' This shows I don't need the stream, but can use the CSV data as a string and parse it into a table.
' Documentation on "XMLHTTP" object:
' "https://learn.microsoft.com/en-us/previous-versions/windows/desktop/ms760305(v=vs.85)"
Dim oWinHttpReq As Object
Dim oDB As Database
Dim sSQL As String, sCSVdata As String, _
asCSVrows As Variant, asCSVfields As Variant, _
nCSVrows As Long, nCSVfields As Integer, _
nCountRows As Long, nCountFields As Integer
Set oDB = CurrentDb()
Set oWinHttpReq = CreateObject("Microsoft.XMLHTTP")
oWinHttpReq.Open "get", sURL, False
oWinHttpReq.send
If oWinHttpReq.status = 200 Then
sCSVdata = oWinHttpReq.ResponseText
asCSVrows = Split(sCSVdata, Chr(10))
nCSVrows = UBound(asCSVrows) + 1
asCSVfields = Split(asCSVrows(0), ",")
nCSVfields = UBound(asCSVfields) + 1
sSQL = ""
For nCountFields = 0 To (nCSVfields - 1)
sSQL = sSQL & "[" & asCSVfields(nCountFields) & "] varchar(255)" & _
IIf(nCountFields = nCSVfields - 1, "", ", ")
Next
sSQL = "create table [" & sTableName & "] (" & sSQL & ");"
oDB.Execute (sSQL)
For nCountRows = 1 To (nCSVrows - 1)
asCSVfields = Split(asCSVrows(nCountRows), ",")
sSQL = ""
For nCountFields = 0 To (nCSVfields - 1)
sSQL = sSQL & """" & asCSVfields(nCountFields) & """" & _
IIf(nCountFields = nCSVfields - 1, "", ", ")
Next
sSQL = "insert into [" & sTableName & "] values (" & sSQL & ");"
oDB.Execute (sSQL)
Next
If sKey <> "" Then _
oDB.Execute "alter table [" & sTableName & "] add primary key ([" & sKey & "]);"
End If
Set oWinHttpReq = Nothing
Set oDB = Nothing
End Sub ' pImportOnlineCsvAsTable()
i find this code, when trying to create db, using adodb and adox.
Here you can check original, it is the same. Thanks for author
Private Sub Command1_Click()
Dim db_file As String
Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim num_records As Integer
' Get the database name.
db_file = App.Path
If Right$(db_file, 1) <> "\" Then db_file = db_file & _
"\"
db_file = db_file & "People.mdb"
' Open a connection.
Set conn = New ADODB.Connection
conn.ConnectionString = _
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & db_file & ";" & _
"Persist Security Info=False"
conn.Open
' Drop the Employees table if it already exists.
On Error Resume Next
conn.Execute "DROP TABLE Employees"
On Error GoTo 0
' Create the Employees table.
conn.Execute _
"CREATE TABLE Employees(" & _
"EmployeeId INTEGER NOT NULL," & _
"LastName VARCHAR(40) NOT NULL," & _
"FirstName VARCHAR(40) NOT NULL)"
' Populate the table.
conn.Execute "INSERT INTO Employees VALUES (1, " & _
"'Anderson', 'Amy')"
conn.Execute "INSERT INTO Employees VALUES (1, 'Baker', " & _
" 'Betty')"
conn.Execute "INSERT INTO Employees VALUES (1, 'Cover', " & _
" 'Chauncey')"
' Add more records ...
' See how many records the table contains.
Set rs = conn.Execute("SELECT COUNT (*) FROM Employees")
num_records = rs.Fields(0)
conn.Close
MsgBox "Created " & num_records & " records", _
vbInformation, "Done"
End Sub
But how to make it more robust, so, i don't want to delete db.
How to check, if db exists and if db.tables contains my table?
additional question: am i right, that this code create db for ms-access 2007?
Thanks for help!
Your question includes these two:
How to check, if db exists and if db.tables contains my table?
am i right, that this code create db for ms-access 2007?
For the first part of #1, use the Dir() function.
If Len(Dir("C:\SomeFolder\YourDb.mdb")) > 0 Then
Debug.Print "db exists"
Else
Debug.Print "db not found"
End If
For the second part of #1, try this function. pTable is the name of the table you're checking for. pDbPath is the full path, including the file name, for the db file you want to examine. The path can be one which begins with a drive letter, or it can be a UNC path ( \\Server\Share\YourDb.mdb ).
Public Function TableExists(ByVal pTable As String, _
Optional ByVal pDbPath As String) As Boolean
'return True if pTable exists as either a native or linked table '
'pass any error to caller '
Dim blnReturn As Boolean
Dim db As DAO.Database
Dim tdf As DAO.TableDef
If Len(Trim(pDbPath)) > 0 Then
Set db = OpenDatabase(pDbPath)
Else
Set db = CurrentDb
End If
For Each tdf In db.TableDefs
If tdf.Name = pTable Then
blnReturn = True
Exit For
End If
Next tdf
Set tdf = Nothing
If Len(Trim(pDbPath)) > 0 Then
db.Close
End If
Set db = Nothing
TableExists = blnReturn
End Function
Regarding your second question, no that code you showed us does not create a db file for any Access version. If db_file is not the path to an existing db file, that code will throw an error at conn.Open. It does not create the missing db file.
However I doubt that code will compile as VBA, despite the fact you included VBA in your title and tagged your question as vba. Really you should have at least tried it first before including it in a question on Stack Overflow.
For creating a MDB file from VB6/VBA code you could use ADOX. Here's a sample function to create an MDB file.
Public Function CreateMDB(strDBPath As String) As Boolean
'To make code compile add a reference to Microsoft ADO Ext 2.x for DDL and Security
'(msADOX.dll)
Dim catDB As ADOX.Catalog
Dim tblNew As ADOX.Table
Dim keyPrim As New ADOX.Key
Set catDB = New ADOX.Catalog
If Dir(strDBPath) = "" Then
CreateMDB = False
End If
With catDB
.Create "Provider=Microsoft.Jet.OLEDB.4.0;Locale Identifier=" & _
1033 & ";Data Source=" & strDBPath
.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & strDBPath
End With
Set tblNew = New ADOX.Table
With tblNew
.Name = "data"
With .Columns
.Append "Field_0", adVarWChar
.Append "Field_1", adVarWChar
.Append "Field_2", adVarWChar
.Append "Field_3", adVarWChar
End With
End With
catDB.Tables.Append tblNew
Set keyPrim = New ADOX.Key
With keyPrim
.Name = "Field_0"
.Type = adKeyPrimary
.RelatedTable = "data"
.Columns.Append "Field_0"
End With
catDB.Tables("data").Keys.Append keyPrim
Set catDB = Nothing
Set tblNew = Nothing
End Function