By using this site, you agree to our updated Privacy Policy and our Terms of Use. Manage your Cookies Settings.
444,155 Members | 2,518 Online
Bytes IT Community
+ Ask a Question
Need help? Post your question and get tips & solutions from a community of 444,155 IT Pros & Developers. It's quick & easy.

Export from .ADP to .MDB (solution)

P: n/a
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.Workspaces(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.CreateDatabase("C:\" & strFileName,
dbLangGeneral)
strFileName = dbsNew.Name

'Get recordset and create table in new db
Set rst = Me.sfrReport.Form.Recordset.Clone
strSQL = "create table tblResults(" & vbCrLf
For Each fld In rst.Fields
strSQL = strSQL & vbTab & Replace(fld.Name, "$", "") & " " &
DataType(fld.Type) & ", " & vbCrLf
Next fld
strSQL = Left(strSQL, Len(strSQL) - 4) & ")"
dbsNew.Execute strSQL

'Import records into tblResults
oProgressBar.Steps = rst.RecordCount
oProgressBar.Title = "Importing " & rst.RecordCount & "
records..."
Set rstResults = dbsNew.OpenRecordset("tblResults")
Do Until rst.EOF
rstResults.AddNew
For Each fld In rst.Fields
rstResults.Fields(Replace(fld.Name, "$", "")) =
rst.Fields(fld.Name)
Next fld
rstResults.Update
rst.MoveNext
oProgressBar.Increment
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_HCHAPTER).
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_DBTIMESTAMP).
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_FILETIME).
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_IDISPATCH).
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_IUNKNOWN).
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_VARIANT).
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 adUnsignedBigInt 'Indicates an eight-byte unsigned integer
(DBTYPE_UI8).
DataType = "number"
Case adUnsignedInt 'Indicates a four-byte unsigned integer
(DBTYPE_UI4).
DataType = "number"
Case adUnsignedSmallInt 'Indicates a two-byte unsigned integer
(DBTYPE_UI2).
DataType = "number"
Case adUnsignedTinyInt '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.Caption = 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!rectProgressBar.Width = intNewWidth
frm!txtPercent = intNewWidth / mintMaxWidth
frm.Repaint
End If
End Sub

Private Sub Class_Initialize()
Set frm = New Form_frmProgress
mintMaxWidth = frm!rectProgressBar.Width
frm!rectProgressBar.Width = 1
frm.Visible = True
frm.SetFocus
End Sub

Private Sub Class_Terminate()
Set frm = Nothing
End Sub
Nov 12 '05 #1
Share this Question
Share on Google+
1 Reply


P: n/a
Hi Ted,

Thanks for that, I was vaguely watching your thread before. The Datatype
routine will be particularly helpful.

Andrew
"Ted Theodoropoulos" <te********@yahoo.com> wrote in message
news:f5**************************@posting.google.c om...
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.Workspaces(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.CreateDatabase("C:\" & strFileName,
dbLangGeneral)
strFileName = dbsNew.Name

'Get recordset and create table in new db
Set rst = Me.sfrReport.Form.Recordset.Clone
strSQL = "create table tblResults(" & vbCrLf
For Each fld In rst.Fields
strSQL = strSQL & vbTab & Replace(fld.Name, "$", "") & " " &
DataType(fld.Type) & ", " & vbCrLf
Next fld
strSQL = Left(strSQL, Len(strSQL) - 4) & ")"
dbsNew.Execute strSQL

'Import records into tblResults
oProgressBar.Steps = rst.RecordCount
oProgressBar.Title = "Importing " & rst.RecordCount & "
records..."
Set rstResults = dbsNew.OpenRecordset("tblResults")
Do Until rst.EOF
rstResults.AddNew
For Each fld In rst.Fields
rstResults.Fields(Replace(fld.Name, "$", "")) =
rst.Fields(fld.Name)
Next fld
rstResults.Update
rst.MoveNext
oProgressBar.Increment
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_HCHAPTER).
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_DBTIMESTAMP).
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_FILETIME).
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_IDISPATCH).
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_IUNKNOWN).
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_VARIANT).
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 adUnsignedBigInt 'Indicates an eight-byte unsigned integer
(DBTYPE_UI8).
DataType = "number"
Case adUnsignedInt 'Indicates a four-byte unsigned integer
(DBTYPE_UI4).
DataType = "number"
Case adUnsignedSmallInt 'Indicates a two-byte unsigned integer
(DBTYPE_UI2).
DataType = "number"
Case adUnsignedTinyInt '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.Caption = 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!rectProgressBar.Width = intNewWidth
frm!txtPercent = intNewWidth / mintMaxWidth
frm.Repaint
End If
End Sub

Private Sub Class_Initialize()
Set frm = New Form_frmProgress
mintMaxWidth = frm!rectProgressBar.Width
frm!rectProgressBar.Width = 1
frm.Visible = True
frm.SetFocus
End Sub

Private Sub Class_Terminate()
Set frm = Nothing
End Sub

Nov 12 '05 #2

This discussion thread is closed

Replies have been disabled for this discussion.