De zip file bevat de code voor een class module.
Je moet een nieuwe class module aanmaken in access en de code daarin plakken.
Bovenin de code is een stukje commentaar opgenomen hoe je er gebruik van maakt.
Onderstaand de code uit de zip file:
'* MsgBox Err.Number & ": " & Err.Description
'* Resume Exit_Here
'*
'*End Sub
'*
'**************************************************
#Const VBA5 = True 'True for MS Office 97, False for VB and MS Office 2000
#Const Access = True 'True for Access any version, False otherwise
#If VBA5 Then
#Else
Public Event StatusText(ByVal strStatusText As String)
Public Event ExportProgress(ByVal sngPercentDone As Single)
#End If
#If Access Then
#Else
Private Const acSysCmdInitMeter = 1
Private Const acSysCmdUpdateMeter = 2
Private Const acSysCmdSetStatus = 4
Private Const acSysCmdClearStatus = 5
#End If
Private mrsExport As DAO.Recordset
Private mvarExport As Variant
Private mstrTextQualifier As String
Private mstrFieldDelimiter As String
Private mstrRecDelimiter As String
Private mstrReplaceWith As String
Private mstrExportFilename As String
Private mstrExportType As String
Private mblnIncludeFieldNames As Boolean
Private mstrExcludeFields As String
Private mblnNoProgress As Boolean
Private mblnAppend As Boolean
Private mlngExportedCount As Long
Private mintFileNumber As Integer
Private mdbCurrent As DAO.Database
Private mintErrHandling As Integer
Private Type ArrayLayout
ColumnDimension As Long
RowDimension As Long
End Type
Private mAL As ArrayLayout 'orientation of source array
Private Const mconERR_INVALID_EXPORT_SOURCE = vbObjectError Or 1000
Private Const mconERR_INVALID_EXPORT_ARRAY = vbObjectError Or 1005
Private Const mconERR_EXP_DB_NOT_SPECIFIED = vbObjectError Or 1010
Private Const mconERR_BAD_DAO_REFERENCE = vbObjectError Or 1015
Private Const mconERR_INVALID_EXCLUDE_LIST = vbObjectError Or 1020
Public Property Let ExcludeFields(strExcludeFields As String)
'optional, .-delimited string of fields to exclude
'ignored for arrays
If Not strExcludeFields Like "[!.]*?." Then _
Err.Raise mconERR_INVALID_EXCLUDE_LIST, "TextExport::ExcludeFields", "Invalid exclude field list format."
mstrExcludeFields = strExcludeFields
End Property
Public Property Let ExportDatabase(db As DAO.Database)
'required if ExportSource is a table name, a query name, or a SQL statement
'no default
Set mdbCurrent = db
End Property
Public Function Export(Optional blnTransposeArray As Boolean) As Boolean
'wrapper for ExportRs or ExportArr
If Not IsEmpty(mvarExport) Then
If blnTransposeArray Then
mAL.ColumnDimension = 2
mAL.RowDimension = 1
End If
Export = ExportArr
ElseIf Not mrsExport Is Nothing Then
Export = ExportRs
Else
Err.Raise mconERR_INVALID_EXPORT_SOURCE, "TextExport::Export", "Invalid export source."
End If
End Function
Private Function ExportRs() As Boolean
On Error GoTo Err_Handler
Dim strHeader As String, strRecord As String
Dim intCount As Integer
Dim fld As DAO.Field
Dim lngFilePos As Long
If Not mrsExport.Fields.Count > 0 Then _
Err.Raise mconERR_INVALID_EXPORT_SOURCE, "TextExport::Export", "Invalid export source."
If mstrExportType = "WP" Then
mstrTextQualifier = vbNullString
mstrFieldDelimiter = Chr(18) & Chr(10)
mstrRecDelimiter = 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
If mblnIncludeFieldNames Then
For intCount = 0 To mrsExport.Fields.Count - 1
If Not (InStr(1, mstrExcludeFields, mrsExport.Fields(intCount).Name & ".", vbTextCompare) > 0) Then
strHeader = strHeader & mstrTextQualifier & ReplaceStr(mrsExport.Fields(intCount).Name, mstrRecDelimiter, mstrReplaceWith) & mstrTextQualifier & mstrFieldDelimiter
End If
Next intCount
strHeader = Left$(strHeader, Len(strHeader) - Len(mstrFieldDelimiter)) & mstrRecDelimiter
End If
mintFileNumber = FreeFile
Open mstrExportFilename For Binary Access Write Lock Write As mintFileNumber
If mblnAppend Then _
lngFilePos = LOF(mintFileNumber)
Put #mintFileNumber, lngFilePos + 1, strHeader 'wrote header, if any
With mrsExport
Call SysCmd(acSysCmdSetStatus, "Opening source...")
If mrsExport.RecordCount > 0 Then
.MoveLast 'to get accurate progress bar
Call SysCmd(acSysCmdClearStatus)
.MoveFirst
Call SysCmd(acSysCmdInitMeter, "Exporting text...", 100)
End If
mlngExportedCount = 0
Do Until .EOF
Call SysCmd(acSysCmdUpdateMeter, .PercentPosition)
strRecord = vbNullString
For intCount = 0 To .Fields.Count - 1
If Not (InStr(1, mstrExcludeFields, .Fields(intCount).Name & ".", vbTextCompare) > 0) Then
Set fld = .Fields(intCount)
Select Case fld.Type
Case dbText, dbMemo, dbChar
If Len(mstrTextQualifier) > 0 Then
If InStr(1, fld.Value, mstrTextQualifier, vbBinaryCompare) > 0 Then 'double text qualifiers
strRecord = strRecord & CStr(mstrTextQualifier & ReplaceStr(fld.Value, mstrTextQualifier, mstrTextQualifier & mstrTextQualifier) & mstrTextQualifier) & mstrFieldDelimiter
Else
strRecord = strRecord & CStr(Nz(mstrTextQualifier + fld.Value + mstrTextQualifier, vbNullString)) & mstrFieldDelimiter
End If
Else 'make sure there are no field delimiters in text fields
strRecord = strRecord & ReplaceStr(Nz(fld.Value, vbNullString), mstrFieldDelimiter, mstrReplaceWith) & mstrFieldDelimiter
End If
Case dbGUID 'exports canonical form
strRecord = strRecord & Mid$(Nz(fld.Value, vbNullString), 7, 38) & mstrFieldDelimiter
Case dbBinary, dbVarBinary, dbLongBinary
If Len(mstrTextQualifier) > 0 Then
If InStr(1, fld.Value, mstrTextQualifier, vbBinaryCompare) > 0 Then 'double text qualifiers
strRecord = strRecord & CStr(mstrTextQualifier & ReplaceStr(StrConv(fld.Value, vbUnicode), mstrTextQualifier, mstrTextQualifier & mstrTextQualifier) & mstrTextQualifier) & mstrFieldDelimiter
Else
strRecord = strRecord & CStr(Nz(mstrTextQualifier + StrConv(fld.Value, vbUnicode) + mstrTextQualifier, vbNullString)) & mstrFieldDelimiter
End If
Else 'make sure there are no field delimiters in text fields
strRecord = strRecord & ReplaceStr(Nz(StrConv(fld.Value, vbUnicode), vbNullString), mstrFieldDelimiter, mstrReplaceWith) & mstrFieldDelimiter
End If
Case Else
strRecord = strRecord & Nz(fld.Value, vbNullString) & mstrFieldDelimiter
End Select
Set fld = Nothing
End If
Next intCount
strRecord = ReplaceStr(strRecord, mstrRecDelimiter, mstrReplaceWith) 'make sure there's no record delimiters in records
strRecord = Left$(strRecord, Len(strRecord) - Len(mstrFieldDelimiter)) & mstrRecDelimiter
Put #mintFileNumber, , strRecord
mlngExportedCount = mlngExportedCount + 1
.MoveNext
Loop
End With
ExportRs = True
Exit_Here:
On Error Resume Next
Set fld = Nothing
Close mintFileNumber
Call SysCmd(acSysCmdClearStatus)
Exit Function
Err_Handler:
Err.Raise Err.Number, Err.Source, Err.Description
Resume Exit_Here
End Function
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 mstrExportType = "WP" Then
mstrTextQualifier = vbNullString
mstrFieldDelimiter = Chr(18) & Chr(10)
mstrRecDelimiter = 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
mintFileNumber = FreeFile
Open mstrExportFilename For Binary Access Write Lock Write As mintFileNumber
If mblnAppend Then _
lngFilePos = LOF(mintFileNumber)
Put #mintFileNumber, lngFilePos + 1, strHeader 'wrote header, if any
Call SysCmd(acSysCmdSetStatus, "Opening source...")
lngTotalRows = UBound(mvarExport, mAL.RowDimension) - LBound(mvarExport, mAL.RowDimension) + 1
If lngTotalRows > 0 Then
Call SysCmd(acSysCmdClearStatus)
Call SysCmd(acSysCmdInitMeter, "Exporting text...", lngTotalRows)
End If
mlngExportedCount = 0
For lngRowCount = LBound(mvarExport, mAL.RowDimension) To UBound(mvarExport, mAL.RowDimension)
Call SysCmd(acSysCmdUpdateMeter, lngRowCount)
strRecord = vbNullString
For lngColumnCount = LBound(mvarExport, mAL.ColumnDimension) To UBound(mvarExport, mAL.ColumnDimension)
If mAL.ColumnDimension = 2 And mAL.RowDimension = 1 Then 'transposed
varElement = mvarExport(lngRowCount, lngColumnCount)
Else
varElement = mvarExport(lngColumnCount, lngRowCount)
End If
Select Case VarType(varElement)
Case vbString
If Len(mstrTextQualifier) > 0 Then
strRecord = strRecord & mstrTextQualifier & ReplaceStr(CStr(varElement), mstrTextQualifier, mstrTextQualifier & mstrTextQualifier) & mstrTextQualifier & mstrFieldDelimiter
Else 'make sure there's no field delimiters in text fields
strRecord = strRecord & ReplaceStr(CStr(varElement), mstrFieldDelimiter, mstrReplaceWith) & mstrFieldDelimiter
End If
Case vbEmpty, vbNull, vbInteger, vbLong, vbSingle, vbDouble, _
vbCurrency, vbDate, vbBoolean, vbDecimal, vbByte
strRecord = strRecord & Nz(varElement, vbNullString) & mstrFieldDelimiter
Case Else 'unexportable element, shouldn't happen (supposed to be validated previously)
Err.Raise mconERR_INVALID_EXPORT_ARRAY, "TextExport::ExportSource", "Invalid export array."
End Select
Next lngColumnCount
strRecord = ReplaceStr(strRecord, mstrRecDelimiter, mstrReplaceWith) 'make sure there's no record delimiters in records
strRecord = Left$(strRecord, Len(strRecord) - Len(mstrFieldDelimiter)) & mstrRecDelimiter
Put #mintFileNumber, , strRecord
mlngExportedCount = mlngExportedCount + 1
Next lngRowCount
ExportArr = True
Exit_Here:
On Error Resume Next
Close mintFileNumber
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 mblnAppend 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
mstrExportFilename = 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 mrsExport = 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 mrsExport = varSource.OpenRecordset(dbOpenSnapshot)
Call SysCmd(acSysCmdClearStatus)
Else
Err.Raise mconERR_INVALID_EXPORT_SOURCE, "TextExport::ExportSource", "Invalid export source."
End If
ElseIf TypeName$(varSource) = "String" Then 'table name or query name or SQL
If mdbCurrent Is Nothing Then _
Err.Raise mconERR_EXP_DB_NOT_SPECIFIED, "ExportText::ExportSource", "Database not specified."
'try to use as SQL
If Not mrsExport Is Nothing Then mrsExport.Close: Set mrsExport = Nothing
Call SysCmd(acSysCmdSetStatus, "Opening source...")
On Error Resume Next
Set mrsExport = mdbCurrent.OpenRecordset(CStr(varSource), dbOpenSnapshot)
On Error GoTo 0
Call SysCmd(acSysCmdClearStatus)
If mrsExport Is Nothing Then 'try as table name or query name
On Error Resume Next
strQueryName = mdbCurrent.QueryDefs(CStr(varSource)).Name
If Not Len(strQueryName) > 0 Then _
strTableName = mdbCurrent.TableDefs(CStr(varSource)).Name
On Error GoTo 0
If Len(strQueryName) > 0 Then
If Not (mdbCurrent.QueryDefs(strQueryName).Type = dbQSelect Or mdbCurrent.QueryDefs(strQueryName).Type = dbQSetOperation) Then _
Err.Raise mconERR_INVALID_EXPORT_SOURCE, "TextExport::ExportSource", "Invalid export source."
'query has to be either Select or Union
Call SysCmd(acSysCmdSetStatus, "Opening source...")
Set mrsExport = mdbCurrent.OpenRecordset(strQueryName, dbOpenSnapshot)
Call SysCmd(acSysCmdClearStatus)
ElseIf Len(strTableName) > 0 Then
Call SysCmd(acSysCmdSetStatus, "Opening source...")
Set mrsExport = mdbCurrent.OpenRecordset(strTableName, dbOpenSnapshot)
Call SysCmd(acSysCmdClearStatus)
Else
Err.Raise mconERR_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 mconERR_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 mconERR_INVALID_EXPORT_ARRAY, "TextExport::ExportSource", "Invalid export array."
Next varElement
mvarExport = varSource
Else
Err.Raise mconERR_INVALID_EXPORT_SOURCE, "TextExport::ExportSource", "Invalid export source."
End If
End Property
Public Property Let ExportType(strExportType As String)
'optional, "ASCII" (default) or "WP"
mstrExportType = strExportType
End Property
Public Property Let FieldDelimiter(strFieldDelimiter As String)
'optional, Tab is default
mstrFieldDelimiter = strFieldDelimiter
End Property
Public Property Let IncludeFieldNames(blnIncludeFieldNames As Boolean)
'optional, Include is default
'ignored for arrays
mblnIncludeFieldNames = blnIncludeFieldNames
End Property
Public Property Let NoProgressBar(blnNoProgress As Boolean)
'if used, has to assigned before some other props
mblnNoProgress = blnNoProgress
End Property
Public Property Get RecordCount() As Long
'number of actually exported records
RecordCount = mlngExportedCount
End Property
Public Property Let ReplaceWith(strReplaceWith As String)
'optional
'strReplaceWith - will be used to replace mstrRecDelimiter
'and mstrFieldDelimiter (if no text qualifier is used) in the exported data
'default is to replace with one space
mstrReplaceWith = strReplaceWith
End Property
Public Property Let RecDelimiter(strRecDelimiter As String)
'optional, CrLf is default
mstrRecDelimiter = strRecDelimiter
End Property
Public Property Let AppendToFile(blnAppend As Boolean)
'optional
'will append to existing export file instead of overwriting it
mblnAppend = blnAppend
End Property
Private Static 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 = Space$(lngTempLength)
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
Mid$(strTemp, 1, alngMap(0, lngCount) - 1) = ReplaceStr
'insert the first replacement at the new mapped position
If alngMap(1, lngCount) < lngTempLength + 1 Then _
Mid$(strTemp, 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 _
Mid$(strTemp, alngMap(1, lngCount - 1) + lngReplaceLength) = Mid$(ReplaceStr, 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 _
Mid$(strTemp, alngMap(1, lngCount - 1) + lngReplaceLength) = Mid$(ReplaceStr, 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 _
Mid$(strTemp, alngMap(1, lngCount)) = strReplace
End Select
Next lngCount
End If
ReplaceStr = strTemp
Else 'simple substitution
For lngCount = 0 To lngReplacementsCount - 1
Mid$(ReplaceStr, 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 mblnNoProgress 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 Nz(varIn, varValueIfNull) As Variant
'overloads Access Nz() function
'unlike Access, second argument is non-optional
#If Access Then
Nz = Access.Nz(varIn, varValueIfNull)
#Else
Select Case True
Case IsNull(varIn), IsEmpty(varIn)
Nz = varValueIfNull
Case Else
Nz = varIn
End Select
#End If
End Function
Public Property Let TextQualifier(strTextQualifier As String)
'optional, " is default
mstrTextQualifier = strTextQualifier
End Property
Private Function ArrBoundsCheck(varExport As Variant) As Boolean
'the array has to be 2-dimensional
On Error Resume Next
Dim varTemp As Variant
varTemp = varExport(LBound(varExport, 1), LBound(varExport, 2))
If Err.Number = 0 Then
ArrBoundsCheck = True
Else
Err.Clear
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
Private Function FileExists(strFilename As String) As Boolean
On Error Resume Next
Dim intRes As Integer
intRes = GetAttr(strFilename)
If Err.Number <> 0 Then
Err.Clear
ElseIf Not (intRes And vbDirectory) > 0 Then
FileExists = True
End If
End Function
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}"
mintErrHandling = 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 mconERR_BAD_DAO_REFERENCE, "TextExport::Initialize", "A reference to DAO has to be set."
#End If
'defaults
mstrTextQualifier = VBA.Chr(34)
mstrFieldDelimiter = VBA.vbTab
mstrRecDelimiter = VBA.vbCrLf
mstrReplaceWith = " "
mstrExportType = "ASCII"
mblnIncludeFieldNames = True
mAL.ColumnDimension = 1
mAL.RowDimension = 2
End Sub
Private Sub Class_Terminate()
If Not mrsExport Is Nothing Then
mrsExport.Close 'either a clone or has been opened in the class
Set mrsExport = Nothing
End If
If Not mdbCurrent Is Nothing Then Set mdbCurrent = Nothing
Close mintFileNumber
Call SysCmd(acSysCmdClearStatus)
#If Access Then
Application.SetOption "Error Trapping", mintErrHandling
#End If
End Sub
