i posted an earlier thread about exporting data from a subform in an
..ADP to an .MDB file. i had only one gracious response but it
wouldn't work in the given situation. so i thought i would share the
code with you that i wrote to solve the problem. certainly nothing
sophisticated but it would have been very helpful to me had i gotten
ahold of it when i started out to tackle the problem. i welcome any
feedback.
the solution uses a both ADO and DAO. u get ADO recordsets when u
clone a forms recordset in an ADP which is why ADO is necessary and
it's much easier to create a database in DAO. hence, you'll beed a
reference to both libraries.
Private Sub cmdAccess_Click ()
On Error GoTo HandleErrors
Dim wrkDefault As DAO.Workspace
Dim dbsNew As DAO.Database
Dim rstResults As DAO.Recordset
Dim rst As ADODB.Recordset
Dim fld As ADODB.Field
Dim strFileName As String
Dim strMsg As String
Dim strSQL As String
Dim oProgressBar As New clsProgressBar
' Get default Workspace.
Set wrkDefault = DBEngine.Worksp aces(0)
'Prompt user for file name
strFileName = InputBox("What would you like to name this new
Access database?", "Client Team Reporting")
If Len(strFileName ) = 0 Then Exit Sub
'Create the new database
Set dbsNew = wrkDefault.Crea teDatabase("C:\ " & strFileName,
dbLangGeneral)
strFileName = dbsNew.Name
'Get recordset and create table in new db
Set rst = Me.sfrReport.Fo rm.Recordset.Cl one
strSQL = "create table tblResults(" & vbCrLf
For Each fld In rst.Fields
strSQL = strSQL & vbTab & Replace(fld.Nam e, "$", "") & " " &
DataType(fld.Ty pe) & ", " & vbCrLf
Next fld
strSQL = Left(strSQL, Len(strSQL) - 4) & ")"
dbsNew.Execute strSQL
'Import records into tblResults
oProgressBar.St eps = rst.RecordCount
oProgressBar.Ti tle = "Importing " & rst.RecordCount & "
records..."
Set rstResults = dbsNew.OpenReco rdset("tblResul ts")
Do Until rst.EOF
rstResults.AddN ew
For Each fld In rst.Fields
rstResults.Fiel ds(Replace(fld. Name, "$", "")) =
rst.Fields(fld. Name)
Next fld
rstResults.Upda te
rst.MoveNext
oProgressBar.In crement
Loop
Set oProgressBar = Nothing
dbsNew.Close
MsgBox "Database has been created as " & strFileName, vbInformation,
"Client Team Reporting"
ExitHere:
Exit Sub
HandleErrors:
Select Case Err.Number
Case 3204
strMsg = "The database C:\" & strFileName & ".mdb" & "
already exists."
Case Else
strMsg = Err.Description
End Select
MsgBox strMsg, vbCritical, "Client Team Reporting"
GoTo ExitHere
End Sub
Public Function DataType(intADO As Integer) As String
Select Case intADO
Case adBigInt 'Indicates an eight-byte signed integer (DBTYPE_I8).
DataType = "number"
Case adBinary 'Indicates a binary value (DBTYPE_BYTES).
DataType = "text"
Case adBoolean 'Indicates a boolean value (DBTYPE_BOOL).
DataType = "yesno"
Case adBSTR 'Indicates a null-terminated character string
(Unicode) (DBTYPE_BSTR).
DataType = "text"
Case adChapter 'Indicates a four-byte chapter value that
identifies rows in a child rowset (DBTYPE_HCHAPTE R).
DataType = "text"
Case adChar 'Indicates a string value (DBTYPE_STR).
DataType = "text"
Case adCurrency 'Indicates a currency value (DBTYPE_CY). Currency
is a fixed-point number with four digits to the right of the decimal
point. It is stored in an eight-byte signed integer scaled by 10,000.
DataType = "currency"
Case adDate 'Indicates a date value (DBTYPE_DATE). A date is
stored as a double, the whole part of which is the number of days
since December 30, 1899, and the fractional part of which is the
fraction of a day.
DataType = "datetime"
Case adDBDate 'Indicates a date value (yyyymmdd)
(DBTYPE_DBDATE) .
DataType = "datetime"
Case adDBTime 'Indicates a time value (hhmmss) (DBTYPE_DBTIME) .
DataType = "datetime"
Case adDBTimeStamp 'Indicates a date/time stamp (yyyymmddhhmmss
plus a fraction in billionths) (DBTYPE_DBTIMES TAMP).
DataType = "datetime"
Case adDecimal 'Indicates an exact numeric value with a fixed
precision and scale (DBTYPE_DECIMAL ).
DataType = "number"
Case adDouble 'Indicates a double-precision floating-point
value (DBTYPE_R8).
DataType = "number"
Case adEmpty 'Specifies no value (DBTYPE_EMPTY).
DataType = "text"
Case adError 'Indicates a 32-bit error code (DBTYPE_ERROR).
DataType = "text"
Case adFileTime 'Indicates a 64-bit value representing the number
of 100-nanosecond intervals since January 1, 1601 (DBTYPE_FILETIM E).
DataType = "text"
Case adGUID 'Indicates a globally unique identifier (GUID)
(DBTYPE_GUID).
DataType = "text"
Case adIDispatch 'Indicates a pointer to an IDispatch interface on
a COM object (DBTYPE_IDISPAT CH).
DataType = "text"
Case adInteger 'Indicates a four-byte signed integer
(DBTYPE_I4).
DataType = "number"
Case adIUnknown 'Indicates a pointer to an IUnknown interface on
a COM object (DBTYPE_IUNKNOW N).
DataType = "text"
Case adLongVarBinary 'Indicates a long binary value.
DataType = "text"
Case adLongVarChar 'Indicates a long string value.
DataType = "text"
Case adLongVarWChar 'Indicates a long null-terminated Unicode
string value.
DataType = "text"
Case adNumeric 'Indicates an exact numeric value with a fixed
precision and scale (DBTYPE_NUMERIC ).
DataType = "number"
Case adPropVariant 'Indicates an Automation PROPVARIANT
(DBTYPE_PROP_VA RIANT).
DataType = "text"
Case adSingle 'Indicates a single-precision floating-point
value (DBTYPE_R4).
DataType = "number"
Case adSmallInt 'Indicates a two-byte signed integer (DBTYPE_I2).
DataType = "number"
Case adTinyInt 'Indicates a one-byte signed integer (DBTYPE_I1).
DataType = "number"
Case adUnsignedBigIn t 'Indicates an eight-byte unsigned integer
(DBTYPE_UI8).
DataType = "number"
Case adUnsignedInt 'Indicates a four-byte unsigned integer
(DBTYPE_UI4).
DataType = "number"
Case adUnsignedSmall Int 'Indicates a two-byte unsigned integer
(DBTYPE_UI2).
DataType = "number"
Case adUnsignedTinyI nt 'Indicates a one-byte unsigned integer
(DBTYPE_UI1).
DataType = "number"
Case adUserDefined 'Indicates a user-defined variable
(DBTYPE_UDT).
DataType = "text"
Case adVarBinary 'Indicates a binary value.
DataType = "text"
Case adVarChar 'Indicates a string value.
DataType = "text"
Case adVariant 'Indicates an Automation Variant
(DBTYPE_VARIANT ).
DataType = "text"
Case adVarNumeric 'Indicates a numeric value.
DataType = "number"
Case adVarWChar 'Indicates a null-terminated Unicode character
string.
DataType = "text"
Case adWChar 'Indicates a null-terminated Unicode character string
(DBTYPE_WSTR).
DataType = "text"
End Select
End Function
here's the code for the clsProgressBar. this is modified version of a
class i got off of someone's web site here in the group. can't
remember who to give them credit.
Option Compare Database
Option Explicit
Private frm As Access.Form
Private mintSteps As Integer
Private msngIncrement As Single
Private mintMaxWidth As Integer
Private msngWidth As Single
Public Property Let Title(pstrTitle As String)
frm!lblTitle.Ca ption = pstrTitle
End Property
Public Property Let Steps(pintSteps As Integer)
mintSteps = pintSteps
msngIncrement = mintMaxWidth / mintSteps
End Property
Public Sub Increment()
Dim intNewWidth As Integer
msngWidth = msngWidth + msngIncrement
intNewWidth = msngWidth
If intNewWidth <= mintMaxWidth Then
frm!rectProgres sBar.Width = intNewWidth
frm!txtPercent = intNewWidth / mintMaxWidth
frm.Repaint
End If
End Sub
Private Sub Class_Initializ e()
Set frm = New Form_frmProgres s
mintMaxWidth = frm!rectProgres sBar.Width
frm!rectProgres sBar.Width = 1
frm.Visible = True
frm.SetFocus
End Sub
Private Sub Class_Terminate ()
Set frm = Nothing
End Sub
..ADP to an .MDB file. i had only one gracious response but it
wouldn't work in the given situation. so i thought i would share the
code with you that i wrote to solve the problem. certainly nothing
sophisticated but it would have been very helpful to me had i gotten
ahold of it when i started out to tackle the problem. i welcome any
feedback.
the solution uses a both ADO and DAO. u get ADO recordsets when u
clone a forms recordset in an ADP which is why ADO is necessary and
it's much easier to create a database in DAO. hence, you'll beed a
reference to both libraries.
Private Sub cmdAccess_Click ()
On Error GoTo HandleErrors
Dim wrkDefault As DAO.Workspace
Dim dbsNew As DAO.Database
Dim rstResults As DAO.Recordset
Dim rst As ADODB.Recordset
Dim fld As ADODB.Field
Dim strFileName As String
Dim strMsg As String
Dim strSQL As String
Dim oProgressBar As New clsProgressBar
' Get default Workspace.
Set wrkDefault = DBEngine.Worksp aces(0)
'Prompt user for file name
strFileName = InputBox("What would you like to name this new
Access database?", "Client Team Reporting")
If Len(strFileName ) = 0 Then Exit Sub
'Create the new database
Set dbsNew = wrkDefault.Crea teDatabase("C:\ " & strFileName,
dbLangGeneral)
strFileName = dbsNew.Name
'Get recordset and create table in new db
Set rst = Me.sfrReport.Fo rm.Recordset.Cl one
strSQL = "create table tblResults(" & vbCrLf
For Each fld In rst.Fields
strSQL = strSQL & vbTab & Replace(fld.Nam e, "$", "") & " " &
DataType(fld.Ty pe) & ", " & vbCrLf
Next fld
strSQL = Left(strSQL, Len(strSQL) - 4) & ")"
dbsNew.Execute strSQL
'Import records into tblResults
oProgressBar.St eps = rst.RecordCount
oProgressBar.Ti tle = "Importing " & rst.RecordCount & "
records..."
Set rstResults = dbsNew.OpenReco rdset("tblResul ts")
Do Until rst.EOF
rstResults.AddN ew
For Each fld In rst.Fields
rstResults.Fiel ds(Replace(fld. Name, "$", "")) =
rst.Fields(fld. Name)
Next fld
rstResults.Upda te
rst.MoveNext
oProgressBar.In crement
Loop
Set oProgressBar = Nothing
dbsNew.Close
MsgBox "Database has been created as " & strFileName, vbInformation,
"Client Team Reporting"
ExitHere:
Exit Sub
HandleErrors:
Select Case Err.Number
Case 3204
strMsg = "The database C:\" & strFileName & ".mdb" & "
already exists."
Case Else
strMsg = Err.Description
End Select
MsgBox strMsg, vbCritical, "Client Team Reporting"
GoTo ExitHere
End Sub
Public Function DataType(intADO As Integer) As String
Select Case intADO
Case adBigInt 'Indicates an eight-byte signed integer (DBTYPE_I8).
DataType = "number"
Case adBinary 'Indicates a binary value (DBTYPE_BYTES).
DataType = "text"
Case adBoolean 'Indicates a boolean value (DBTYPE_BOOL).
DataType = "yesno"
Case adBSTR 'Indicates a null-terminated character string
(Unicode) (DBTYPE_BSTR).
DataType = "text"
Case adChapter 'Indicates a four-byte chapter value that
identifies rows in a child rowset (DBTYPE_HCHAPTE R).
DataType = "text"
Case adChar 'Indicates a string value (DBTYPE_STR).
DataType = "text"
Case adCurrency 'Indicates a currency value (DBTYPE_CY). Currency
is a fixed-point number with four digits to the right of the decimal
point. It is stored in an eight-byte signed integer scaled by 10,000.
DataType = "currency"
Case adDate 'Indicates a date value (DBTYPE_DATE). A date is
stored as a double, the whole part of which is the number of days
since December 30, 1899, and the fractional part of which is the
fraction of a day.
DataType = "datetime"
Case adDBDate 'Indicates a date value (yyyymmdd)
(DBTYPE_DBDATE) .
DataType = "datetime"
Case adDBTime 'Indicates a time value (hhmmss) (DBTYPE_DBTIME) .
DataType = "datetime"
Case adDBTimeStamp 'Indicates a date/time stamp (yyyymmddhhmmss
plus a fraction in billionths) (DBTYPE_DBTIMES TAMP).
DataType = "datetime"
Case adDecimal 'Indicates an exact numeric value with a fixed
precision and scale (DBTYPE_DECIMAL ).
DataType = "number"
Case adDouble 'Indicates a double-precision floating-point
value (DBTYPE_R8).
DataType = "number"
Case adEmpty 'Specifies no value (DBTYPE_EMPTY).
DataType = "text"
Case adError 'Indicates a 32-bit error code (DBTYPE_ERROR).
DataType = "text"
Case adFileTime 'Indicates a 64-bit value representing the number
of 100-nanosecond intervals since January 1, 1601 (DBTYPE_FILETIM E).
DataType = "text"
Case adGUID 'Indicates a globally unique identifier (GUID)
(DBTYPE_GUID).
DataType = "text"
Case adIDispatch 'Indicates a pointer to an IDispatch interface on
a COM object (DBTYPE_IDISPAT CH).
DataType = "text"
Case adInteger 'Indicates a four-byte signed integer
(DBTYPE_I4).
DataType = "number"
Case adIUnknown 'Indicates a pointer to an IUnknown interface on
a COM object (DBTYPE_IUNKNOW N).
DataType = "text"
Case adLongVarBinary 'Indicates a long binary value.
DataType = "text"
Case adLongVarChar 'Indicates a long string value.
DataType = "text"
Case adLongVarWChar 'Indicates a long null-terminated Unicode
string value.
DataType = "text"
Case adNumeric 'Indicates an exact numeric value with a fixed
precision and scale (DBTYPE_NUMERIC ).
DataType = "number"
Case adPropVariant 'Indicates an Automation PROPVARIANT
(DBTYPE_PROP_VA RIANT).
DataType = "text"
Case adSingle 'Indicates a single-precision floating-point
value (DBTYPE_R4).
DataType = "number"
Case adSmallInt 'Indicates a two-byte signed integer (DBTYPE_I2).
DataType = "number"
Case adTinyInt 'Indicates a one-byte signed integer (DBTYPE_I1).
DataType = "number"
Case adUnsignedBigIn t 'Indicates an eight-byte unsigned integer
(DBTYPE_UI8).
DataType = "number"
Case adUnsignedInt 'Indicates a four-byte unsigned integer
(DBTYPE_UI4).
DataType = "number"
Case adUnsignedSmall Int 'Indicates a two-byte unsigned integer
(DBTYPE_UI2).
DataType = "number"
Case adUnsignedTinyI nt 'Indicates a one-byte unsigned integer
(DBTYPE_UI1).
DataType = "number"
Case adUserDefined 'Indicates a user-defined variable
(DBTYPE_UDT).
DataType = "text"
Case adVarBinary 'Indicates a binary value.
DataType = "text"
Case adVarChar 'Indicates a string value.
DataType = "text"
Case adVariant 'Indicates an Automation Variant
(DBTYPE_VARIANT ).
DataType = "text"
Case adVarNumeric 'Indicates a numeric value.
DataType = "number"
Case adVarWChar 'Indicates a null-terminated Unicode character
string.
DataType = "text"
Case adWChar 'Indicates a null-terminated Unicode character string
(DBTYPE_WSTR).
DataType = "text"
End Select
End Function
here's the code for the clsProgressBar. this is modified version of a
class i got off of someone's web site here in the group. can't
remember who to give them credit.
Option Compare Database
Option Explicit
Private frm As Access.Form
Private mintSteps As Integer
Private msngIncrement As Single
Private mintMaxWidth As Integer
Private msngWidth As Single
Public Property Let Title(pstrTitle As String)
frm!lblTitle.Ca ption = pstrTitle
End Property
Public Property Let Steps(pintSteps As Integer)
mintSteps = pintSteps
msngIncrement = mintMaxWidth / mintSteps
End Property
Public Sub Increment()
Dim intNewWidth As Integer
msngWidth = msngWidth + msngIncrement
intNewWidth = msngWidth
If intNewWidth <= mintMaxWidth Then
frm!rectProgres sBar.Width = intNewWidth
frm!txtPercent = intNewWidth / mintMaxWidth
frm.Repaint
End If
End Sub
Private Sub Class_Initializ e()
Set frm = New Form_frmProgres s
mintMaxWidth = frm!rectProgres sBar.Width
frm!rectProgres sBar.Width = 1
frm.Visible = True
frm.SetFocus
End Sub
Private Sub Class_Terminate ()
Set frm = Nothing
End Sub
Comment