This page contains some useful VBA code for Microsoft Access
Set References
Dim ref As Reference
On Error Resume Next
'ADD REFERENCES
With References
'VISUAL BASIC FOR APPLICATIONS
.AddFromGuid "{000204EF-0000-0000-C000-000000000046}", 1, 0
'MICROSOFT ACCESS 10.0 OBJECT LIBRARY
.AddFromGuid "{4AFFC9A0-5F99-101B-AF4E-00AA003F0F07}", 1, 0
'OLE AUTOMATION
.AddFromGuid "{00020430-0000-0000-C000-000000000046}", 1, 0
'MICROSOFT DAO 3.6 OBJECT LIBRARY
.AddFromGuid "{00025E01-0000-0000-C000-000000000046}", 1, 0
'MICROSOFT OFFICE 10.O OBJECT LIBRARY
.AddFromGuid "{2DF8D04C-5BFA-101B-BDE5-00AA0044DE52}", 1, 0
End With
'REMOVE REFERENCE
'MICROSOFT ACTIVEX DATA OBJECTS 2.1 OBJECT LIBRARY
Set ref = References("ADODB")
References.Remove ref
On Error GoTo 0
Format Windows Environment
'FORMAT WINDOWS ENVIRONMENT
Application.Echo = False
'STATUSBAR
SysCmd acSysCmdSetStatus, "text"
SysCmd acSysCmdSetStatus, "MESSAGE"
'METER COUNTER
SysCmd acSysCmdInitMeter, "METER TEXT", 300
For i = 0 To 300
SysCmd acSysCmdUpdateMeter, i
DoEvents
Next i
'RESET METER COUNTER
SysCmd acSysCmdRemoveMeter
'CLEAR STATUSBAR
SysCmd acSysCmdClearStatus
'RESET FORMAT WINDOWS ENVIRONMENT
Application.Echo = True
'REFRESH
RefreshDatabaseWindow
Excel Automation
'DECLARE CONSTANT VARIABLES
Private Const m_strWkb As String = "WORKBOOK_NAME.xls"
Private m_objExcel As Excel.Application
Private m_objwkb As Excel.Workbook
'OPEN EXCEL
Set m_objExcel = New Excel.Application
m_objExcel.Visible = True
Set m_objwkb = m_objExcel.Workbooks.Open(m_strDir & m_strWkb)
Get Folder Path
'GET FOLDER
Dim foldername As String
foldername = GetFolderName & "FILENAME.txt"
If foldername = "FILENAME.txt" Then
db.Close
Exit Sub
End If
Function GetFolderName() As String
Dim fd, indir
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
fd.Title = "Select Folder"
If fd.Show = True Then
indir = fd.SelectedItems(1)
Else
Exit Function
End If
If Mid(outdir, Len(indir), 1) <> "\" Then
indir = indir & "\"
End If
GetFolderName = indir
End Function
Set Database
'DECLARE PUBLIC VARIABLES
Public db As Database
'SET DATABASE
Set db = CurrentDb
Set db = DBEngine.Workspaces(0).OpenDatabase("EXTERNAL DATABASE PATHNAME")
Set Table
** 'DECLARE PUBLIC VARIABLES**
Public tbl As TableDef
'DECLARE ROUTINE VARIABLES
Dim fld As Field
Dim idx As Index
'IMPORT TABLE
DoCmd.TransferDatabase acImport, "Microsoft Access", "FILEPATHNAME", objSourceType,
"TABLEQUERY_NAME", "DESTINATIONTABLE_NAME"
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, "TABLEQUERY_NAME",
"FILEPATHNAME", True
DoCmd.TransferText acImportDelim, "SPECIFICATION_NAME", "TABLEQUERY_NAME",
"FILEPATHNAME", True
'LINK TABLE
'A:
DoCmd.TransferDatabase acLink, "Microsoft Access", "FILEPATHNAME", objSourceType,
"TABLEQUERY_NAME", "DESTINATIONTABLE_NAME"
DoCmd.TransferSpreadsheet acLink, acSpreadsheetTypeExcel9, "TABLEQUERY_NAME",
"FILEPATHNAME", True
DoCmd.TransferText acLinkDelim, "SPECIFICATION_NAME", "TABLEQUERY_NAME",
"FILEPATHNAME", True
'B:
Set tdl = db.CreateTableDef("TABLE_NAME")
tdl.Connect = ";DATABASE=" & "PATH_NAME" & "DATABASE_NAME"
tdl.SourceTableName = "TABLE_NAME"
db.TableDefs.Append tbl
tdl.RefreshLink
'CREATE TABLE
Set tbl = db.CreateTableDef("TABLE_NAME")
Set fld = tbl.CreateField("FIELD_NAME", dbText)
With fld
.Size = 255
.OrdinalPosition = 1
.Required = True
.Attributes = dbAutoIncrField
End With
tbl.Fields.Append fld
Set idx = tbl.CreateIndex("INDEX_NAME")
With idx
.Primary = True
.Required = True
.Unique = True
End With
Set fld = idx.CreateField("FIELD_NAME")
idx.Fields.Append fld
tbl.Indexes.Append idx
db.TableDefs.Append tbl
'EXPORT TABLE
'A: EXTERNAL ACCESS DATABASE
DoCmd.TransferDatabase acExport, "Microsoft Access", "FILEPATHNAME", objSourceType,
"TABLEQUERY_NAME", "DESTINATIONTABLE_NAME"
'B: EXCEL
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "TABLEQUERY_NAME",
"FILEPATHNAME", True
** 'C: TEXT FILE**
DoCmd.TransferText acExportDelim, "SPECIFICATION_NAME", "TABLEQUERY_NAME",
"FILEPATHNAME", True
'UNLINK TABLES
For Each tbl In db.TableDefs
If tbl.RecordCount = -1 Then
db.TableDefs.Delete (tbl.Name)
End If
Next
'DELETE TABLE
db.TableDefs.Delete ("TABLE_NAME")
Set Query
'DECLARE PUBLIC VARIABLES
Public qry As QueryDef
'DECLARE ROUTINE VARIABLES
Dim strSQLString As String
'QUERY
Set qry = db.CreateQueryDef("QUERY_NAME")
Set qry = db.CreateQueryDef("")
strSQLString = "SQL_STATEMENT;"
qry.Sql = strSQLString
'A:
DoCmd.RunSQL (strSQLString)
'B:
DoCmd.OpenQuery ("QUERY_NAME")
'C:
db.QueryDefs("QUERY NAME").Execute
qry.Execute
qry.RecordsAffected 'Returns number of records in Query
'DELETE QUERY
'A:
db.QueryDefs.Delete ("QUERY_NAME")
'B:
For Each qry In db.QueryDefs
Qryname = qry.Name
db.QueryDefs.Delete (Qryname)
Next
'RESET VARIABLES
qry.Close
Set Recordset
'DECLARE PUBLIC VARIABLES
Public rec As Recordset
'DECLARE ROUTINE VARIABLES
Dim strBookmark As String
'OPEN RECORDSET
Set rec = db.OpenRecordset("TABLE_NAME/strSQLString", dbOpenDynaset) 'RecordTypes = Table,Dynaset,Snapshot,ForwardOnly,Dynamic
With rec
.MoveLast
.MoveFirst
End With
With rec
.RecordCount 'Counts records in Dynaset or Snapshot Recordset
.Requery 'Refreshes Recordset
.CancelUpdate 'Cancels record updating
End With
'SEARCH RECORDSET
'A: Find record on Table Recordset
rec.Seek "=<>", strVariable
'B: Find record in Dynaset or Snapshot Recordset
With rec
.FindFirst
.FindLast
.FindNext
.FindPrevious
.Nomatch 'Returns True/False
End With
'SET BOOKMARK
strBookmark = rec.Bookmark 'Stores current record as string
rec.Index 'Indexname of recordset
'UPDATE RECORDSET
Do While Not rec.EOF
strVariable = "PARAMETER"
If rec.Updatable = True Then
rec.Edit
rec("FIELD_NAME") = strVariable
rec.Update
End If
With rec
.AddNew
.Delete
End With
rec.MoveNext
Loop
'RESET VARIABLE
rec.Close
Array in Access
Option Base 1
'DECLARE PUBLIC VARIABLES
Public myArray As Variant
'DECLARE ROUTINE VARIABLES
Dim iRecordNumber As Integer
Dim iRowNumber As Integer
Dim iColumnNumber As Integer
'NUMBER OF RECORDS
iRecordNumber = PARAMETER
iRecordNumber = rec.RecordCount
'INPUT INTO ARRAY
myArray = rec.GetRows(iRecordNumber)
iRowNumber = UBound(myArray, 2)
iColumnNumber = UBound(myArray, 1)
'RESET ARRAY
Erase myArray
Set Form
'OPEN FORM
DoCmd.OpenForm ("FORM_NAME")
DoCmd.Maximize
'SET VALUES IN FORM
'A:
FORM_NAME.Controls("CONTROL_NAME").Value = PARAMETER
'B: ADD LISTBOX VALUES
With Application.Forms("FORM_NAME").Controls("LIST_NAME")
.RowSource = .RowSource & RECORDSET_NAME("FIELD_NAME") & ";"
End With
'CLOSE FORM
DoCmd.Close
Set Date Variable
'DECLARE ROUTINE VARIABLES
Dim DateToday As Date
Dim DateVariable As Date
Dim DateChange As Date
Dim TimeNow As Date
Dim strSQLWhere As String
'SET VARIABLES
DateToday = Date
DateVariable = #4/30/1968 6:00:00 AM#
TimeNow = Time()
'FORMAT VARIABLES
DateVariable = Format(DateVariable, "Long Date", FIRSTDAYOFWEEK, FIRSTDAYOFYEAR) 'Short Date, Short Time, Long Date, Long Time
DateVariable = Format(DateVariable, "dd mm yyyy", FIRSTDAYOFWEEK, FIRSTDAYOFYEAR) 'dddd = DayName, mmmm = MonthName
'CHANGE VARIABLE
DateChange = DatePart("m", DateVariable)
DateChange = DateDiff("y", DateToday, DateVariable)
DateChange = DateAdd("d", 3, DateToday)
'SQL VARIABLE
strSQLWhere = "WHERE DATEFIELD = #" & Format(DateVariable, "mm/dd/yy hh:mm:ss") & "#" 'Convert Date to American Format
strSQL = strSQL & strSQLWhere
Word Automation
'DECLARE CONSTANT VARIABLES
Private Const m_strDir As String = "C:\PATHNAME\"
Private Const m_strDoc As String = "DOCUMENT_NAME.doc"
Private m_objWord As Word.Application
Private m_objDoc As Word.Document
Public Sub refToWord(rec As Recordset)
'SET VARIABLES
Set m_objWord = New Word.Application
Set m_objDoc = m_objWord.Documents.Add(m_strDir & m_strDoc)
Call InsertItemsList(recRef)
m_objDoc.SaveAs Filename:=m_strDir & "m_strDoc"
'RESET VARIABLES
m_objDoc.Close
m_objWord.Quit
Set m_objDoc = Nothing
Set m_objWord = Nothing
End Sub
Private Sub InsertItemsList(rec As Recordset)
'DECLARE VARIABLES
Dim strVariable As String
rec.MoveFirst
Do While Not rec.EOF
strVariable = strVariable & rec("FIELD_NAME") & vbCr
rec.MoveNext
Loop
Call InsertTextAtBookMark("BOOKMARK_NAME", strVariable)
End Sub
Private Sub InsertTextAtBookMark(strBkmk As String, varText As Variant)
'DECLARE VARIABLES
Dim objTable As Word.Table
'INSERT TEXT
m_objDoc.Bookmarks(strBkmk).Select
m_objWord.Selection.Text = varText & " "
'CONVERT TO TABLE
Set objTable = r_objWord.Selection.ConvertToTable(Separator:=vbTab)
With objTable
.AutoFormat Format:=wdTableFormatSimple1, ApplyHeadingRows:=True, AutoFit:=True, ApplyColor:=False
.Rows(1).HeadingFormat = wdToggle
.Columns(1).PreferredWidth = MillimetersToPoints(43)
.Columns(2).PreferredWidth = MillimetersToPoints(38)
.Columns(1).Select
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
End With
objTable.Rows(1).Select
With Selection
.Font.Bold = True
.Rows.Height = MillimetersToPoints(12)
.Cells.VerticalAlignment = wdCellAlignVerticalCenter
End With
For i = 1 To objTable.Rows.Count
objTable.Rows(i).Cells(1).Select
With Selection
.Font.Bold = wdToggle
.Font.Italic = wdToggle
End With
Next i
'RESET VARIABLES
Set objTable = Nothing
End Sub
Print to Text file
Open FILENAME For Output As #1
Print #1, "VALUES"
Close #1
Open Hyperlink
Application.FollowHyperlink "HYPERLINK ADDRESS"
Quit Access
DoCmd.Quit
