VBA Module in Excel Spreadsheet pulling info from Access Database (1 Viewer)

kesmith

New member
Local time
Today, 18:29
Joined
Jul 20, 2011
Messages
6
The following is a VBA module in an Excel spreadsheet. It works fine when the database is ".mdb" but not when it's ".accdb". I tried the simple thing of changing the ofn.lpstrFilter line to .accdb vice .mdb but that didn't work, other than to make the .accdb file visible in the open file window. It errors out at the "set dbs = " line.
Any suggestions greatly appreciated. - TIA - Ken
-----------------

Option Explicit
'the open filename api
Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As gFILE) As Long
' the gFILE type needed by the open filename api
Type gFILE
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String

End Type
Function FileToOpen() '(Optional StartLookIn) As String
On Error GoTo Err_Skip
'Purpose: Calls the open file api to let the user select the file to open
'returns: string value which contains the path to the file selected. "" = no file seleted
Dim ofn As gFILE
Dim path As String
Dim filename As String
Dim a As String

StartOver:
ofn.lStructSize = Len(ofn)
ofn.lpstrFilter = "Databases(*.mdb)" + Chr$(0) + "*.mdb" + Chr$(0)
ofn.lpstrFile = Space$(254)
ofn.nMaxFile = 255
ofn.lpstrFileTitle = Space$(254)
ofn.nMaxFileTitle = 255
ofn.lpstrInitialDir = "C:\Program Files\ISIS"

ofn.lpstrTitle = "Please find and select the Database from which you wish to import"
ofn.flags = 0
a = GetOpenFileName(ofn)
If (a) Then
path = Trim(ofn.lpstrFile)
filename = Trim(ofn.lpstrFileTitle)
If Dir(path) <> "" Then FileToOpen = -1
FileToOpen = Trim(ofn.lpstrFile)
End If
'*****************begin data dump
Dim dbs As Database
Dim rstWing As Recordset
Dim intCount, intCnt, intRow, intCol, intDeviceRows, intFirstEntry As Integer
Dim strRow, strSName, strSIDDevice As String
Set dbs = DBEngine(0).OpenDatabase(path)
Set rstWing = dbs.OpenRecordset("SELECT * FROM qryUtlRpt ORDER BY SNAME, Ordr")

'-------------Goto first record
rstWing.MoveFirst
'-------------Store Wing Name
strSName = rstWing!SName
intCnt = 12
Do While rstWing.EOF = False

'put first sname in skip function until name changes
'Copy Wing Header
Rows("4:8").Select
Range("A8").Activate
Selection.Copy
strRow = intCnt & ":" & intCnt
Rows(strRow).Select
ActiveSheet.Paste
'------------Enter Wing Info
'Header info
Worksheets("tblExcelTemplate").Cells(intCnt, 2).Value = rstWing.Fields("SNAME") '1=1row 6=Fcolumn
Worksheets("tblExcelTemplate").Cells(intCnt + 1, 2).Value = rstWing.Fields("SLOC") '3=3row 6=Fcolumn

'___________________DEVICE ENTRY________________________________________________________________________________
'------establish row to enter Device Info
intDeviceRows = intCnt + 5
strSIDDevice = rstWing!SIDDevice
ANOTHERDEVICE:
Rows("9:11").Select
Range("A11").Activate
Selection.Copy

strRow = intDeviceRows & ":" & intDeviceRows + 2
Rows(strRow).Select
ActiveSheet.Paste
'**********ENTER HRS -21 cells X 2
Do While strSIDDevice = rstWing!SIDDevice
Worksheets("tblExcelTemplate").Cells(intDeviceRows, 1).Value = rstWing.Fields("Aircraft")
Worksheets("tblExcelTemplate").Cells(intDeviceRows, 2).Value = rstWing.Fields("Type")
Worksheets("tblExcelTemplate").Cells(intDeviceRows, 3).Value = rstWing.Fields("SUM")
Worksheets("tblExcelTemplate").Cells(intDeviceRows, 4).Value = rstWing.Fields("AVAIL")
Worksheets("tblExcelTemplate").Cells(intDeviceRows, 5).Value = rstWing.Fields("SCHD")
Worksheets("tblExcelTemplate").Cells(intDeviceRows, 6).Value = rstWing.Fields("FRS")
Worksheets("tblExcelTemplate").Cells(intDeviceRows, 7).Value = rstWing.Fields("FLE")
Worksheets("tblExcelTemplate").Cells(intDeviceRows, 8).Value = rstWing.Fields("RES")
Worksheets("tblExcelTemplate").Cells(intDeviceRows, 9).Value = rstWing.Fields("Other")
Worksheets("tblExcelTemplate").Cells(intDeviceRows, 10).Value = rstWing.Fields("UTIL TOTAL")
Worksheets("tblExcelTemplate").Cells(intDeviceRows, 11).Value = rstWing.Fields("UTIL %")
Worksheets("tblExcelTemplate").Cells(intDeviceRows, 12).Value = rstWing.Fields("MAINT HRS")
Worksheets("tblExcelTemplate").Cells(intDeviceRows, 13).Value = rstWing.Fields("SUPP HRS")
Worksheets("tblExcelTemplate").Cells(intDeviceRows, 14).Value = rstWing.Fields("MOD HRS")
Worksheets("tblExcelTemplate").Cells(intDeviceRows, 15).Value = rstWing.Fields("LOST HRS")
Worksheets("tblExcelTemplate").Cells(intDeviceRows, 16).Value = rstWing.Fields("NO SHOW")
Worksheets("tblExcelTemplate").Cells(intDeviceRows, 17).Value = rstWing.Fields("CNCL HRS")
Worksheets("tblExcelTemplate").Cells(intDeviceRows, 18).Value = rstWing.Fields("NOT SCHED")
Worksheets("tblExcelTemplate").Cells(intDeviceRows, 19).Value = rstWing.Fields("SET UP INSTR")
Worksheets("tblExcelTemplate").Cells(intDeviceRows, 20).Value = rstWing.Fields("TOTAL HRS")
Worksheets("tblExcelTemplate").Cells(intDeviceRows, 21).Value = rstWing.Fields("PMCQ1")
intDeviceRows = intDeviceRows + 1
rstWing.MoveNext
If rstWing.EOF = True Then
Rows("4:11").Select
Range("A11").Activate
Selection.Delete Shift:=xlUp
Exit Function
'Exit Sub
End If

Loop
'Did
If strSName = rstWing!SName Then
strSIDDevice = rstWing!SIDDevice
'intDeviceRows = intDeviceRows + 1 'Adds blank row
Worksheets("tblExcelTemplate").Cells(intDeviceRows, 1).Value = "REMARKS"
intDeviceRows = intDeviceRows + 2
GoTo ANOTHERDEVICE
End If
'___________________DEVICE ENTRY COMPLETE_______________________________________________________________________
Worksheets("tblExcelTemplate").Cells(intDeviceRows, 1).Value = "REMARKS"
strSName = rstWing!SName
intCnt = intDeviceRows + 2
Loop
Err_Skip:
End Function
 

Users who are viewing this thread

Top Bottom