Sub Main
	StartBrowseThruControls("Orders_Browse")
End Sub

Sub ComputeOrderTotal(poEvent As Object)
Dim oeEvent As Object, ofForm As Object, ocSum As Object, vOrderId As Variant

	Set oeEvent = Events(poEvent)
	If Not IsNull(oeEvent) Then
		Set ofForm =oeEvent.Source
		vOrderId = ofForm.Controls("OrderID").Value
		If Not IsEmpty(vOrderId) Then
			Set ocSum = ofForm.Controls("SumOfDetails")
			ocSum.Value = DSum("[Order Details].[UnitPrice] * [Order Details].[Quantity] * (1 - [Order Details].[Discount])" _
				, "[Order Details]", "[Order Details].[OrderID]=" & vOrderId)
		End If
	End If
End Sub

REM ========================================================================================================
Sub CalcButtonPressed(poEvent As Object)

Dim oEvent As Object, sName As String, oButton As Object, oDisplay As Object, sChar As String
	Set oEvent = Application.Events(poEvent)
	If oEvent.EventType <> "ACTIONEVENT" Then Exit Sub
	
	Set oButton = oEvent.Source
	sName = UCase(oButton.Name)
	Select Case sName
		Case "BTNADD"			:	sChar = "+"
		Case "BTNSUB"			:	sChar = "-"
		Case "BTNMULT"			:	sChar = "*"
		Case "BTNDIV"			:	sChar = "/"
		Case "BTNENTER"			:	sChar = "="
		Case "BTNCLEAR"			:	sChar = "C"
		Case "BTNCE"			:	sChar = "CE"
		Case "BTNINVERT"		:	sChar = "1/x"
		Case "BTNPOINT"			:	sChar = "."
		Case Else				:	sChar = Right(sName, 1)		'	DIGIT !!
	End Select
	Call ProcessKey(sChar)
	Exit Sub
	
End Sub

REM ========================================================================================================
Sub ProcessKey(ByVal psChar As String)
'	Process gCalc structure based on argument

Dim sDisplayText As String
Const cstMax = 999999999999

	Select Case psChar
		Case "C"		'	Cancel
			gCalc.DisplayText = Format(0, "0.")
			gCalc.Operand1 = 0
			gCalc.Operand2 = 0
			gCalc.NumberOfOperands = 0
			gCalc.PendingOperation = " "
			gCalc.LastInput = "NONE"
		Case "CE"		'	Cancel entry
			gCalc.DisplayText = Format(0, "0.")
			gCalc.DecimalPoint = False
			gCalc.LastInput = "CE"
		Case "."		'	Decimal point
		' If last keypress was an operator, initialize DisplayText to "0."
		' Otherwise, append a decimal point to the display.
			If gCalc.DecimalPoint Then
				Beep
			Else
				If gCalc.LastInput = "NEG" Then
					gCalc.DisplayText = Format(0, "-0.")
				ElseIf gCalc.LastInput <> "NUMS" Then
					gCalc.DisplayText = Format(0, "0.")
				End If
				gCalc.DecimalPoint = True
				gCalc.LastInput = "NUMS"
			End If
		Case "+", "-", "*", "/", "="	'	Arithmetic operators
		' If the immediately preceeding keypress was part of a number, increment DecimalPoint. If one operand is present,
		' set Operand1. If two are present, set Operand1 equal to the result of the operation on Operand1 and the current
		' input string, and display the result.
			sDisplayText = gCalc.DisplayText
			If gCalc.LastInput = "NUMS" Then
				gCalc.NumberOfOperands = gCalc.NumberOfOperands + 1
			End If
			Select Case gCalc.NumberOfOperands
				Case 0
					If psChar = "-" And gCalc.LastInput <> "NEG" Then
						gCalc.DisplayText = "-" & gCalc.DisplayText
						gCalc.LastInput = "NEG"
					End If
				Case 1
					gCalc.Operand1 = Val(gCalc.DisplayText)
					If psChar = "-" And gCalc.LastInput <> "NUMS" And gCalc.PendingOperation <> "=" Then
						gCalc.DisplayText = "-"
						gCalc.LastInput = "NEG"
					End If
				Case 2
					gCalc.Operand2 = Val(sDisplayText)
					Select Case gCalc.PendingOperation
						Case "+"
							gCalc.Operand1 = gCalc.Operand1 + gCalc.Operand2
						Case "-"
							gCalc.Operand1 = gCalc.Operand1 - gCalc.Operand2
						Case "*"
							gCalc.Operand1 = gCalc.Operand1 * gCalc.Operand2
						Case "/"
							If Sgn(gCalc.Operand2) = 0 Then
								gCalc.Operand1 = cstMax * Sgn(gCalc.Operand1)
							Else
								gCalc.Operand1 = gCalc.Operand1 / gCalc.Operand2
							End If
						Case "="
							gCalc.Operand1 = gCalc.Operand2
					End Select
					gCalc.DisplayText = Join(Split(Format(gCalc.Operand1, cstStdFormat), ","), ".")
					gCalc.NumberOfOperands = 1
			End Select
			If gCalc.LastInput <> "NEG" Then
				gCalc.LastInput = "OPS"
				gCalc.PendingOperation = psChar
			End If
		Case "1/x"	'	Invert result
			If gCalc.LastInput = "NUMS" Then gCalc.Operand1 = Val(gCalc.DisplayText)
			If Sgn(gCalc.Operand1) = 0 Then
				gCalc.Operand1 = cstMax
			Else
				gCalc.Operand1 = 1 / gCalc.Operand1
			End If
			gCalc.LastInput = "OPS"
			gCalc.DisplayText = Join(Split(Format(gCalc.Operand1, cstStdFormat), ","), ".")
		Case Else		'	DIGIT
		' Append new number to the number in the display.
			If gCalc.LastInput <> "NUMS" Then
				gCalc.DisplayText = Format(0, ".")
				gCalc.DecimalPoint = False
			End If
			If gCalc.DecimalPoint Then
				gCalc.DisplayText = gCalc.DisplayText & psChar
			Else
				gCalc.DisplayText = Left(gCalc.DisplayText, InStr(gCalc.DisplayText, ".") - 1) & psChar & "."
			End If
			If gCalc.LastInput = "NEG" Then gCalc.DisplayText = "-" & gCalc.DisplayText
			gCalc.LastInput = "NUMS"
	End Select
	
	'DebugPrint psChar, gCalc.Operand1, gCalc.Operand2, gCalc.PendingOperation, gCalc.NumberOfOperands, gCalc.LastInput, gCalc.DisplayText
	gCalc.DisplayField.Value = Join(Split(gCalc.DisplayText, "."), gcalc.LocalePoint)
	Exit Sub

End Sub

Sub StartCalculator(Optional poEvent As Object)
'	StartCalculator should be adapted to user's need:
'	- it is assumed to be activated from an appropriate button
'	- the field to compute is assumed in the same form or subform as the button
'	- the field to compute must be of type NUMERICFIELD or CURRENCYFIELD
'	- the name of the field to compute should be set in next line
'	- The 3rd argument is optional. True = initialize calculator with field current value

	If IsMissing(poEvent) Then poEvent = Nothing
	Call Calculator.StartCalcDialog(poEvent, "TargetCalcField", True)
	
End Sub

Sub UpdateMainForm(poEvent As Object)

Dim ofForm As Object, ocCombo As Object, sSQL As String, lEmpID As Integer
	Set ocCombo = Events(poEvent).Source
	Set ofForm = ocCombo.Parent
	lEmpID = DLookup("[EmployeeID]", "[Employees]", "[LastName]='" & ocCombo.Value & "'")
	ofForm.Filter = "[EmployeeID]=" & lEmpID
	ofForm.FilterOn = True
	
End Sub

Sub Main()
Dim sSql As String
'	sSql = MakeCrossTab( _
'    	"[FirstName] || ' ' || [LastName] As [Name]" _
'		, "Year([OrderDate]) As [Year]" _
'		, "Count(*)" _
'		, "[Employees] INNER JOIN [Orders] ON ([Employees].[EmployeeID]=[Orders].[EmployeeID])" _
'		, "DESC" _
'		)
'	sSql = MakeCrossTab( _
'    	"[FirstName] || ' ' || [LastName] As [Name]" _
'		, "YEAR([OrderDate]) || 'Q' || QUARTER([OrderDate]) As [Month]" _
'		, "Count(*)" _
'		, "[Employees] INNER JOIN [Orders] ON ([Employees].[EmployeeID]=[Orders].[EmployeeID])" _
'		, "DESC" _
'		)
'	sSql = MakeCrossTab( _
'    	"[FirstName] || ' ' || [LastName] As [Name]" _
'		, "YEAR([OrderDate]) || '-' || RIGHT('0' || MONTH([OrderDate]), 2) As [Month]" _
'		, "Count(*)" _
'		, "[Employees] INNER JOIN [Orders] ON ([Employees].[EmployeeID]=[Orders].[EmployeeID])" _
'		, "DESC" _
'
'		)
	sSql = MakeCrossTab( _
	   	"[Customers].[CompanyName] As [Customer], [Products].[ProductName] AS [Name]" _
		, "YEAR([OrderDate]) || 'Q' || QUARTER([OrderDate]) As [Quarter]" _
		, "SUM([Order Details].[UnitPrice]*[Quantity]*(1-[Discount]))" _
		, "[Order Details], [Products], [Orders], [Customers] " _
			& "WHERE [Order Details].[ProductID] = [Products].[ProductID] " _
			& "AND [Order Details].[OrderID] = [Orders].[OrderID] " _
			& "AND [Customers].[CustomerID] = [Orders].[CustomerID] " _
			& "AND YEAR([Orders].[OrderDate]) = 1997" _
		, "[Customer]" _
		)
'	OpenSQL(sSql, dbSQLPassThrough)
	CurrentDb().CreateQueryDef("Query1", sSql, dbSQLPassThrough)
End Sub

Function LongStr(psString As String) As String
Const cstLength = 20
	LongStr = Left(psString & Space(cstLength), cstLength)
End Function

Sub ScanSchemaSQL()

Dim sSql As String
	sSql = "SELECT [TABLE_NAME],[COLUMN_NAME],[SYSTEM_COLUMNS].[TYPE_NAME],[COLUMN_SIZE] " _
			& "FROM [INFORMATION_SCHEMA].[SYSTEM_TABLES],[INFORMATION_SCHEMA].[SYSTEM_COLUMNS] " _
			& "WHERE [TABLE_SCHEM]='PUBLIC' AND [SYSTEM_COLUMNS].[TABLE_NAME]=[SYSTEM_TABLES].[TABLE_NAME]"
	OpenSQL(sSql, dbSQLPassThrough)

End Sub

Public Property Let AppendToFile(blnAppend As Boolean)
'optional
'will append to existing export file instead of overwriting it
  bAppend = blnAppend
End Property

Private Sub Class_Initialize()
On Error GoTo 0

'If Access Then
''  Dim ref As Access.Reference
  Dim blnDAOReferenced As Boolean, blnBroken As Boolean
  
  Const cDAOGUID As String = "{00025E01-0000-0000-C000-000000000046}"
  
  iErrHandling = Application.GetOption("Error Trapping")
  Application.SetOption "Error Trapping", 2
  
  For Each ref In Application.References
    On Error Resume Next
    blnBroken = ref.IsBroken
    If VBA.Err Then blnBroken = True
    On Error GoTo 0
    If ref.Name = "DAO" And ref.Kind = 0 And VBA.StrComp(ref.Guid, cDAOGUID, 1) = 0 And Not blnBroken Then
      blnDAOReferenced = True
      Exit For
    End If
  Next ref
  Set ref = Nothing
  
  If Not blnDAOReferenced Then _
    Err.Raise ERR_BAD_DAO_REFERENCE, "TextExport::Initialize", "A reference to DAO has to be set."
'End If

'defaults
sTextQualifier = VBA.Chr(34)
sFieldDelimiter = VBA.vbTab
sRecDelimiter = VBA.vbCrLf
sReplaceWith = " "
sExportType = "ASCII"
bIncludeFieldNames = True
mAL.ColumnDimension = 1
mAL.RowDimension = 2

End Sub

Public Property Let ExcludeFields(strExcludeFields As String)
'optional, .-delimited string of fields to exclude
'ignored for arrays

If Not strExcludeFields Like "[!.]*?." Then _
  Err.Raise ERR_INVALID_EXCLUDE_LIST, "TextExport::ExcludeFields", "Invalid exclude field list format."

sExcludeFields = strExcludeFields

End Property

Private Function ExportArr() As Boolean
'1st dimension - "columns", 2nd dimension - "rows"
'or the other way when transposed (Me.Export(True))
On Error GoTo Err_Handler
Dim strHeader As String, strRecord As String
Dim lngRowCount As Long, lngColumnCount As Long
Dim lngTotalRows As Long
Dim varElement As Variant
Dim lngFilePos As Long

If sExportType = "WP" Then
  sTextQualifier = vbNullString
  sFieldDelimiter = Chr(18) & Chr(10)
  sRecDelimiter = Chr(5) & Chr(10)
  strHeader = Chr(255) & "WPC^" & String$(3, vbNullChar) & Chr(1) & Chr(10) & String$(6, vbNullChar) & Chr(251) & Chr(255) _
              & Chr(5) & vbNullChar & "2" & String$(5, vbNullChar) & Chr(6) & vbNullChar & Chr(8) & String$(3, vbNullChar) & "B" & String$(3, vbNullChar) _
              & Chr(8) & vbNullChar & Chr(2) & String$(3, vbNullChar) & "J" & String$(3, vbNullChar) & Chr(1) & vbNullChar _
              & Chr(18) & String$(3, vbNullChar) & "L" & String$(13, vbNullChar) & Chr(8) & vbNullChar & "|" _
              & vbNullChar & "x" & String$(5, vbNullChar) & Format$(Now, "mmm dd, yyyy") & String$(6, vbNullChar)
End If

iFileNumber = FreeFile
Open sExportFilename For Binary Access Write Lock Write As iFileNumber

If bAppend Then _
  lngFilePos = LOF(iFileNumber)

Put 'iFileNumber, lngFilePos + 1, strHeader 'wrote header, if any

Call SysCmd(acSysCmdSetStatus, "Opening source...")
lngTotalRows = UBound(vExport, mAL.RowDimension) - LBound(vExport, mAL.RowDimension) + 1
If lngTotalRows > 0 Then
  Call SysCmd(acSysCmdClearStatus)
  Call SysCmd(acSysCmdInitMeter, "Exporting text...", lngTotalRows)
End If

lExportedCount = 0
For lngRowCount = LBound(vExport, mAL.RowDimension) To UBound(vExport, mAL.RowDimension)
  Call SysCmd(acSysCmdUpdateMeter, lngRowCount)
  strRecord = vbNullString
  For lngColumnCount = LBound(vExport, mAL.ColumnDimension) To UBound(vExport, mAL.ColumnDimension)
    If mAL.ColumnDimension = 2 And mAL.RowDimension = 1 Then 'transposed
      varElement = vExport(lngRowCount, lngColumnCount)
    Else
      varElement = vExport(lngColumnCount, lngRowCount)
    End If
    Select Case VarType(varElement)
      Case vbString
        If Len(sTextQualifier) > 0 Then
          strRecord = strRecord & sTextQualifier & ReplaceStr(CStr(varElement), sTextQualifier, sTextQualifier & sTextQualifier) & sTextQualifier & sFieldDelimiter
        Else 'make sure there's no field delimiters in text fields
          strRecord = strRecord & ReplaceStr(CStr(varElement), sFieldDelimiter, sReplaceWith) & sFieldDelimiter
        End If
      Case vbEmpty, vbNull, vbInteger, vbLong, vbSingle, vbDouble, _
           vbCurrency, vbDate, vbBoolean, vbDecimal, vbByte
        strRecord = strRecord & Nz(varElement, vbNullString) & sFieldDelimiter
      Case Else 'unexportable element, shouldn't happen (supposed to be validated previously)
        Err.Raise ERR_INVALID_EXPORT_ARRAY, "TextExport::ExportSource", "Invalid export array."
    End Select
  Next lngColumnCount
  strRecord = ReplaceStr(strRecord, sRecDelimiter, sReplaceWith) 'make sure there's no record delimiters in records
  strRecord = LeftstrRecordrd, Len(strRecord) - Len(sFieldDelimiter)) & sRecDelimiter
  Put 'iFileNumber, , strRecord
  lExportedCount = lExportedCount + 1
Next lngRowCount

ExportArr = True

Exit_Here:
  On Error Resume Next
  Close iFileNumber
  Call SysCmd(acSysCmdClearStatus)
  Exit Function

Err_Handler:
  Err.Raise Err.Number, Err.Source, Err.Description
  Resume Exit_Here

End Function

Public Property Let ExportFilename(strExpFilename As String)
'required
On Error GoTo 0
Dim intFileNumber As Integer

If Not bAppend Or Not FileExists(strExpFilename) Then
  intFileNumber = FreeFile
  Open strExpFilename For Output Access Write Lock Read Write As intFileNumber
  Close intFileNumber 'set to 0-length/create a 0-length
End If

sExportFilename = strExpFilename

End Property

Public Property Let ExportSource(varSource As Variant)
'required
'accepts a recordset, a tabledef, a querydef,
'a table name, a query name, a SQL statement
'or a 2-dim array
On Error GoTo 0
Dim strQueryName As String, strTableName As String
Dim qdf As DAO.QueryDef
Dim varElement As Variant

If IsObject(varSource) Then 'recordset or querydef or tabledef
  If TypeOf varSource Is DAO.Recordset Then
    If Not varSource Is Nothing Then Set oExport = varSource.Clone 'work with a copy
  ElseIf TypeOf varSource Is DAO.TableDef Or TypeOf varSource Is DAO.QueryDef Then
   Call SysCmd(acSysCmdSetStatus, "Opening source...")
   Set oExport = varSource.OpenRecordset(dbOpenSnapshot)
   Call SysCmd(acSysCmdClearStatus)
  Else
    Err.Raise ERR_INVALID_EXPORT_SOURCE, "TextExport::ExportSource", "Invalid export source."
  End If
ElseIf TypeNamevarSourcece) = "String" Then 'table name or query name or SQL
  If odbCurrent Is Nothing Then _
    Err.Raise ERR_EXP_DB_NOT_SPECIFIED, "ExportText::ExportSource", "Database not specified."
  'try to use as SQL
  If Not oExport Is Nothing Then oExport.Close: Set oExport = Nothing
  Call SysCmd(acSysCmdSetStatus, "Opening source...")
  On Error Resume Next
  Set oExport = odbCurrent.OpenRecordset(CStr(varSource), dbOpenSnapshot)
  On Error GoTo 0
  Call SysCmd(acSysCmdClearStatus)
  If oExport Is Nothing Then 'try as table name or query name
    On Error Resume Next
    strQueryName = odbCurrent.QueryDefs(CStr(varSource)).Name
    If Not Len(strQueryName) > 0 Then _
      strTableName = odbCurrent.TableDefs(CStr(varSource)).Name
    On Error GoTo 0
    If Len(strQueryName) > 0 Then
      If Not (odbCurrent.QueryDefs(strQueryName).Type = dbQSelect Or odbCurrent.QueryDefs(strQueryName).Type = dbQSetOperation) Then _
        Err.Raise ERR_INVALID_EXPORT_SOURCE, "TextExport::ExportSource", "Invalid export source."
        'query has to be either Select or Union
      Call SysCmd(acSysCmdSetStatus, "Opening source...")
      Set oExport = odbCurrent.OpenRecordset(strQueryName, dbOpenSnapshot)
      Call SysCmd(acSysCmdClearStatus)
    ElseIf Len(strTableName) > 0 Then
      Call SysCmd(acSysCmdSetStatus, "Opening source...")
      Set oExport = odbCurrent.OpenRecordset(strTableName, dbOpenSnapshot)
      Call SysCmd(acSysCmdClearStatus)
    Else
      Err.Raise ERR_INVALID_EXPORT_SOURCE, "TextExport::ExportSource", "Invalid export source."
    End If
  End If
ElseIf VarType(varSource) >= vbArray Then 'array
  If Not ArrBoundsCheck(varSource) Then _
    Err.Raise ERR_INVALID_EXPORT_ARRAY, "TextExport::ExportSource", "Invalid export array."
  'make sure it's not an array of objects or array of arrays
  'or something similarly unexportable
  For Each varElement In varSource
    If Not VarTypeCheck(varElement) Then _
      Err.Raise ERR_INVALID_EXPORT_ARRAY, "TextExport::ExportSource", "Invalid export array."
  Next varElement
  vExport = varSource
Else
  Err.Raise ERR_INVALID_EXPORT_SOURCE, "TextExport::ExportSource", "Invalid export source."
End If

End Property

Public Property Let FieldDelimiter(strFieldDelimiter As String)
'optional, Tab is default
  sFieldDelimiter = strFieldDelimiter
End Property

Public Property Let NoProgressBar(blnNoProgress As Boolean)
'if used, has to assigned before some other props
  bNoProgress = blnNoProgress
End Property

Public Property Let RecDelimiter(strRecDelimiter As String)
'optional, CrLf is default
  sRecDelimiter = strRecDelimiter
End Property

Private Function ReplaceStr(strIn As String, strFind As String, strReplace As String) As String
Dim alngMap() As Long
Dim lngPos As Long
Dim lngCount As Long
Dim lngReplacementsCount As Long
Dim lngFindLength As Long
Dim lngReplaceLength As Long
Dim strTemp As String
Dim lngTempLength As Long

ReplaceStr = strIn

If LenB(ReplaceStr) <> 0 And LenB(strFind) <> 0 And StrComp(strFind, strReplace, vbBinaryCompare) <> 0 Then
  lngReplacementsCount = 0
  'map the replacements in the old string
  lngPos = InStr(1, ReplaceStr, strFind, vbBinaryCompare)
  If lngPos <> 0 Then
    ReDim alngMap(0 To 1, 0 To Len(ReplaceStr) - 1) 'max required size
    'alngMap(0, ) - old map before replacements
    'alngMap(1, ) - new map after replacements
    alngMap(0, 0) = lngPos
    lngReplacementsCount = 1
  Else
    Exit Function
  End If
  lngFindLength = Len(strFind)
  Do
    lngPos = InStr(lngPos + lngFindLength, ReplaceStr, strFind, vbBinaryCompare)
    If lngPos <> 0 Then
      alngMap(0, lngReplacementsCount) = lngPos
      lngReplacementsCount = lngReplacementsCount + 1
    End If
  Loop While lngPos <> 0

  If lngReplacementsCount <> 0 Then 'at least one replacement
    lngReplaceLength = Len(strReplace)
    If lngFindLength <> lngReplaceLength Then
      'calculate new string length after replacements
      'and allocate temp string accordingly
      lngTempLength = Len(ReplaceStr) + lngReplacementsCount * (lngReplaceLength - lngFindLength)
      strTemp = SpacelngTempLengthth)
      If lngTempLength <> 0 Then
        'create new string mapping after replacements
        For lngCount = 0 To lngReplacementsCount - 1
          alngMap(1, lngCount) = alngMap(0, lngCount) + (lngReplaceLength - lngFindLength) * lngCount
        Next lngCount
        'replace
        For lngCount = 0 To lngReplacementsCount
          Select Case lngCount
            Case 0 'string before first replacement position
              'insert a piece of the original string before first replacement
              MidstrTempmp, 1, alngMap(0, lngCount) - 1) = ReplaceStr
              'insert the first replacement at the new mapped position
              If alngMap(1, lngCount) < lngTempLength + 1 Then _
                MidstrTempmp, alngMap(1, lngCount)) = strReplace
            Case lngReplacementsCount 'string after last replacement position
              'insert a piece of the original string, if any, after last replacement
              If alngMap(1, lngCount - 1) + lngReplaceLength < lngTempLength + 1 Then _
                MidstrTempmp, alngMap(1, lngCount - 1) + lngReplaceLength) = MidReplaceStrtr, alngMap(0, lngCount - 1) + lngFindLength)
            Case Else 'string after previous and before next replacement
              'insert a piece of the original string before next replacement
              If alngMap(1, lngCount - 1) + lngReplaceLength < lngTempLength + 1 Then _
                MidstrTempmp, alngMap(1, lngCount - 1) + lngReplaceLength) = MidReplaceStrtr, alngMap(0, lngCount - 1) + lngFindLength, alngMap(0, lngCount) - (alngMap(0, lngCount - 1) + lngFindLength))
              'insert the next replacement at the new mapped position
              If alngMap(1, lngCount) < lngTempLength + 1 Then _
                MidstrTempmp, alngMap(1, lngCount)) = strReplace
          End Select
        Next lngCount
      End If
      ReplaceStr = strTemp
    Else 'simple substitution
      For lngCount = 0 To lngReplacementsCount - 1
        MidReplaceStrtr, alngMap(0, lngCount)) = strReplace
      Next lngCount
    End If
  End If
End If

End Function

Private Function SysCmd(Arg1 As Variant, Optional Arg2 As Variant, Optional Arg3 As Variant)
'overloads Access.SysCmd() within this module

If Not bNoProgress Then
  'If Not VBA5 Then 'use events
    If IsMissing(Arg2) And IsMissing(Arg3) Then 'clear status and progress
      RaiseEvent StatusText(vbNullString)
      RaiseEvent ExportProgress(0)
    ElseIf Not IsMissing(Arg2) And IsMissing(Arg3) Then
      Select Case Arg1
        Case acSysCmdUpdateMeter
          RaiseEvent ExportProgress(CSng(Arg2))
        Case acSysCmdSetStatus
          RaiseEvent StatusText(CStr(Arg2))
      End Select
    ElseIf Not IsMissing(Arg2) And Not IsMissing(Arg3) Then 'init progress
      RaiseEvent StatusText(CStr(Arg2))
      RaiseEvent ExportProgress(0)
    End If
  'ElseIf VBA5 And Access Then 'use Access SysCmd()
    If IsMissing(Arg2) And IsMissing(Arg3) Then
      ''SysCmd = Access.SysCmd(Arg1)
    ElseIf Not IsMissing(Arg2) And IsMissing(Arg3) Then
      ''SysCmd = Access.SysCmd(Arg1, Arg2)
    ElseIf Not IsMissing(Arg2) And Not IsMissing(Arg3) Then
      ''SysCmd = Access.SysCmd(Arg1, Arg2, Arg3)
    End If
  'Else 'no status/progress reported
  'End If
End If

End Function

Private Function VarTypeCheck(varCheck As Variant) As Boolean
'Returns True if varCheck is an array element exportable as text
On Error GoTo 0
Dim intType As Integer

intType = VarType(varCheck)

If intType = vbEmpty Or _
   intType = vbNull Or _
   intType = vbInteger Or _
   intType = vbLong Or _
   intType = vbSingle Or _
   intType = vbDouble Or _
   intType = vbCurrency Or _
   intType = vbDate Or _
   intType = vbString Or _
   intType = vbBoolean Or _
   intType = vbDecimal Or _
   intType = vbByte Then _
   VarTypeCheck = True
   
End Function

Sub InitList(Optional poEvent As Object)	'	Optional because also called from CaptureChar routine
'Activated when form opened and when ESC key is pressed in listbox

Const cstForm = "Products_FastSearch"
Const cstList = "FastList"
Dim ocList As Object, sSource As String

	Set ocList = Forms(cstForm).Controls(cstList)
	If Not IsMissing(poEvent) Then ocList.Tag = ""		'	Initialized only when form opened

	ocList.RowSourceType = com.sun.star.form.ListSourceType.SQL
	ocList.RowSource = "SELECT [ProductName] FROM [Products] ORDER BY [ProductName] ASC"	'Requery implicit

	sSource = Join(ocList.ItemData, ";")
	ocList.RowSourceType = com.sun.star.form.ListSourceType.VALUELIST	'	For performance
	ocList.RowSource = sSource
	
End Sub

Sub MoveItems(poEvent As Object)
Dim oEvent As Object, ocLeftList As Object, ocRightList As Object
Dim i As Integer, vLeft() As Variant, vRight() As Variant, vSelected() As Variant
Dim iMaxDim As Integer, iLeftSize As Integer, iRightSize As Integer, sSource As String
	Set oEvent = Events(poEvent)
	Set ocLeftList = Forms(cstForm).Controls(cstLeftList)
	Set ocRightList = Forms(cstForm).Controls(cstRightList)
	'	Initial load of arrays
	vLeft = ocLeftList.ItemData
	vRight = ocRightList.ItemData
	iLeftSize = UBound(vLeft)
	iRightSize = UBound(vRight)
	iMaxDim = iLeftSize + 1 + iRightSize + 1
	ReDim Preserve vLeft(iMaxDim)
	ReDim Preserve vRight(iMaxDim)

	Select Case oEvent.Source.Name
		Case "MoveOneRight"		'	>
			vSelected = ocLeftList.Selected
			For i = 0 To iLeftSize
				If vSelected(i) Then
					iRightSize = iRightSize + 1
					vRight(iRightSize) = vLeft(i)
					vLeft(i) = ""
				End If
			Next i
		Case "MoveAllRight"		'	>>
			For i = 0 To iLeftSize
				iRightSize = iRightSize + 1
				vRight(iRightSize) = vLeft(i)
				vLeft(i) = ""
			Next i
		Case "MoveOneLeft"		'	<
			vSelected = ocRightList.Selected
			For i = 0 To iRightSize
				If vSelected(i) Then
					iLeftSize = iLeftSize + 1
					vLeft(iLeftSize) = vRight(i)
					vRight(i) = ""
				End If
			Next i
		Case "MoveAllLeft"		'	<<
			For i = 0 To iRightSize
				iLeftSize = iLeftSize + 1
				vLeft(iLeftSize) = vRight(i)
				vRight(i) = ""
			Next i
	End Select

	'Reload listboxes
	sSource = ""
	For i = 0 To iLeftSize
		If vLeft(i) <> "" Then sSource = sSource & vLeft(i) & ";"
	Next i
	If Len(sSource) = 0 Then ocLeftList.RowSource = "" Else ocLeftList.RowSource = Left(sSource, Len(sSource) - 1)	'	Remove last ";"
	sSource = ""
	For i = 0 To iRightSize
		If vRight(i) <> "" Then sSource = sSource & vRight(i) & ";"
	Next i
	If Len(sSource) = 0 Then ocRightList.RowSource = "" Else ocRightList.RowSource = Left(sSource, Len(sSource) - 1)'	Remove last ";"

	'Deselect listboxes
	For i = 0 To ocLeftList.ListCount - 1
		setSelected(ocLeftList, False, i)
	Next i	
	For i = 0 To ocRightList.ListCount - 1
		setSelected(ocRightList, False, i)
	Next i	
End Sub

Sub AddRecordToShippers()
Dim odbNorthwind As Object
Dim orsShippers As Object

	Set odbNorthwind = Application.CurrentDb
	Set orsShippers = odbNorthwind.OpenRecordset("Shippers")

	With orsShippers
		.AddNew
		.Fields("CompanyName").Value = "Global Open Source Service"
		'
		' Set remaining fields.
		'
		.Update
		.mClose()
	End With
End Sub

Sub CreateRecordsetFromQuery
Dim odbNorthwind As Object
Dim orsCustomers As Object

	Set odbNorthwind = Application.CurrentDb
	Set orsCustomers = odbNorthwind.OpenRecordset("Customers union All")

	'	...
	orsCustomers.MoveLast
	MsgBox orsCustomers.RecordCount
	
	orsCustomers.mClose()
End Sub

Sub DisplayPosition()

Dim odbNorthwind As Object
Dim orsEmployees As Object
Dim sMsg As String
Dim lCount As Long
Dim sSQL As String
Dim dPercent As Double
 
On Local Error GoTo ErrorHandler 
 
	Set odbNorthwind = Application.CurrentDb 

	sSQL = "SELECT * FROM Employees"
	Set orsEmployees = odbNorthwind.OpenRecordset(sSQL, , , dbReadOnly)

	With orsEmployees
		If .EOF Then            '	If no records, exit
			Exit Sub
		Else
			sMsg = "Processing Employees table..."
			DoCmd.SysCmd(acSysCmdInitMeter, sMsg, 100)
			.MoveLast			'	Determine number of records
			lCount = .RecordCount
			.MoveFirst
		End If
		Do Until .EOF
'
'			Any processing ...
'
			Wait 100		'	just to see what happens ...
			dPercent = .AbsolutePosition / lCount
			If dPercent <> 0 Then DoCmd.SysCmd(acSysCmdUpdateMeter, sMsg, Int(100*dPercent))
			.MoveNext
		Loop
	End With 
	MsgBox "Processing ended"
	DoCmd.SysCmd(acSysCmdRemoveMeter)

	orsEmployees.mClose
	Set orsEmployees = Nothing
	Set odbNorthwind = Nothing

Exit Sub
 
ErrorHandler: 
	TraceError("ERROR", Err, "DisplayPosition", Erl)
End Sub

Sub ExtractDataTableBulk()
Dim odbNorthwind As Object
Dim orsOrders As Object
Dim vRecords As Variant
Dim iNumRows As Integer
Dim iNumColumns As Integer
Dim iRow As Integer
Dim iColumn As Integer
Dim sSQL As String 
 
On Local Error GoTo ErrorHandler 
 
	Set odbNorthwind = Application.CurrentDb
	sSQL = "SELECT [OrderDate],[ShipAddress],[ShipCity] FROM Orders"
	Set orsOrders = odbNorthwind.OpenRecordset(sSQL)

	vRecords = orsOrders.GetRows(10)
	iNumRows = UBound(vRecords, 1) + 1
	iNumColumns = UBound(vRecords, 2) + 1

	For iRow = 0 To inumRows - 1
		For iColumn = 0 To iNumColumns - 1
			DebugPrint vRecords(iRow, iColumn)
		Next iColumn
	Next iRow

	orsOrders.mClose()
	Set orsOrders = Nothing
	Exit Sub

ErrorHandler: 
	TraceError("ERROR", Err, "ExtractDataTableBulk", Erl)
End Sub

Function FindRecordCount(sSQL As String) As Long

Dim odbNorthwind As Object
Dim orsRecords As Object
On Local Error GoTo ErrorHandler 

	Set odbNorthwind = Application.CurrentDb
	Set orsRecords = odbNorthwind.OpenRecordset(sSQL)
	With orsRecords
		If .EOF Then
			FindRecordCount = 0
		Else
			.MoveLast
			FindRecordCount = .RecordCount
		End If
		.mClose
	End With

	Set orsRecords = Nothing
	Set odbNorthwind = Nothing
	Exit Function 
 
ErrorHandler:
	TraceError("ERROR", Err, "FindRecordCount", Erl)
End Function

Sub ExportImages(psPath As String)

Dim oTable As Object, oRecordset As Object, sCatName As String
	Set oTable = Application.CurrentDb().TableDefs("CATEGORIES")
	Set oRecordset = oTable.OpenRecordset()
	
	With oRecordset
		Do While Not .EOF()
			sCatName = Join(Split(.Fields("CATEGORYNAME").Value, "/"), " ")
			.Fields("Picture").WriteAllBytes(psPath & sCatName & ".png")
			.MoveNext
		Loop
		.mClose()
	End With
	
End Sub

Sub Main
	'ImportImages("Put/here/a/correct/pathname/")
	'ExportImages("Put/here/a/correct/pathname/")
End Sub

Sub SyncFormListBoxFilter(poEvent As Object)

Dim oEvent As Object, ocList As Object, oForm As Object
Dim sSupplier As String, lSupplier As Long

	Set oEvent = Events(poEvent)
	Set ocList = oEvent.Source				'	Retrieve listbox object
	Set oForm = ocList.Parent				'	Retrieve parent form
	sSupplier = Join(Split(ocList.Value, "'"), "''")	'	For the case the company name contains quotes
	lSupplier = DLookup("[SupplierID]", "[Suppliers]", "[CompanyName]='" & sSupplier & "'")
	oForm.Filter = "[SupplierID]=" & lSupplier
	oForm.FilterOn = True

End Sub

Sub SyncFormListBoxMulti(poEvent As Object)

Dim oEvent As Object, ocList As Object, oForm As Object
Dim sSupplier As String, lSupplier As Long, i As Integer, sSQL As String
Const cstCriteria = " OR [SupplierID]="

	Set oEvent = Events(poEvent)
	Set ocList = oEvent.Source				'	Retrieve listbox object
	Set oForm = ocList.Parent				'	Retrieve parent form
	sSQL = "SELECT [SupplierID], [ProductID], [ProductName], [UnitPrice] FROM [Products] WHERE [SupplierID]="
	For i = 0 To UBound(oclist.Selected)
		If ocList.Selected(i) Then
			sSupplier = Join(Split(ocList.ItemData(i), "'"), "''")	'	For the case the company name contains quotes
			lSupplier = DLookup("[SupplierID]", "[Suppliers]", "[CompanyName]='" & sSupplier & "'")
			sSQL = sSQL & lSupplier & cstCriteria
		End If
	Next i
	oForm.RecordSource = Left(sSQL, Len(sSQL) - Len(cstCriteria))	'	Trim SQL phrase

End Sub