Get directory of excel file in VBA Access

Question

Background: Access database is established. A procedure is written in Access VBA. When I run the procedure it selects the path of 'excel file' and opens it, slpits the data into different tables. To improvise, a form is created with import
button on it. when I click on it, the procedure is executed.
Problem: How do I do the following steps by clicking on the import button in Access VBA: click_import_button >> Choose the excel file dailog box opens >> select the excel file >> Execute the procedure.
Following is my code(some part of it is deleted), with the path mentioned;
Public Sub trial()
Dim xlx As Object, xlw As Object, xls As Object, xlc As Object
Dim vPartDes As String, vPartWeight As Double
Dim vPartLength As Double, vPartWidth As Double
Dim vPartHeight As Double, vBZA As String
Dim vSAAname As String, vSAAnumber As String, vBMName As String, vBMnumber As String
Dim blnEXCEL As Boolean
Dim uid As Integer
Dim rsUID As DAO.Recordset
Dim vSNR As String, vNewSNR As String, VUID As String
Dim rs, rsNewSnr, qs, js, ks, hs As DAO.Recordset
'Dim wrkCurrent As DAO.Workspace
Dim mydb As DAO.Database
blnEXCEL = False
'Establish an EXCEL application object
On Error Resume Next
Set xlx = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set xlx = CreateObject("Excel.Application")
blnEXCEL = True
End If
Err.Clear
On Error GoTo 0
'Change True to False if you do not want the workbook to be visible when the code is running
xlx.Visible = False
Set xlw = xlx.Workbooks.Open("C:\Users\YSRINID\Desktop\Book1.xls", True) 'opens in read-only mode
'Actual name of the worksheet
Set xls = xlw.Worksheets("Sheet1")
Set xlc = xls.Range("F2") ' This is the first cell (reference) that contains data (non-header information)
Set mydb = CurrentDb()
'Set wrkCurrent = DBEngine.Workspaces(0)
'wrkCurrent.BeginTrans
' write data to the recordset
Do While Not IsEmpty(xlc.Value)
vBMnumber = xlc.Offset(0, -4)
vBMName = xlc.Offset(0, -3)
vSAAnumber = xlc.Offset(0, -2)
vSAAname = xlc.Offset(0, -1)
vSNR = xlc.Value
vNewSNR = xlc.Offset(0, 1).Value
vPartDes = xlc.Offset(0, 2).Value
vPartWeight = xlc.Offset(0, 3).Value
vPartLength = xlc.Offset(0, 4).Value
vPartWidth = xlc.Offset(0, 5).Value
vPartHeight = xlc.Offset(0, 6).Value
vBZA = xlc.Offset(0, 7).Value
Dim tsql, usql, vsql, wsql, xsql As String
'Search BMnumber and SAAnumber combination in Variant_SAA
wsql = " SELECT * FROM Variant_SAA where BMnumber like '" & vBMnumber & "' and SAAnumber like '" & vSAAnumber & "'"
Set ks = mydb.OpenRecordset(wsql)
If ks.EOF Then
mydb.Execute "INSERT INTO Variant_SAA(BMnumber,SAAnumber) values('" & vBMnumber & "', '" & vSAAnumber & "') "
'Search for SNR or NewSNR
tsql = "SELECT * FROM SNR_Log where SNR like '" & vSNR & "' or SNR like '" & vNewSNR & "'"
Set rs = mydb.OpenRecordset(tsql)
If rs.RecordCount > 0 Then
rs.MoveFirst
VUID = rs!uid
Else
VUID = -1
End If
If VUID > 0 Then
' Update information in Part_Source table
mydb.Execute "UPDATE [Part_Source] SET PartDes = '" & vPartDes & "', PartWeight = '" & vPartWeight & "' , PartLength ='" & vPartLength & _
"' , PartWidth= '" & vPartWidth & "', PartHeight= '" & vPartHeight & "' , BZA = '" & vBZA & "' WHERE UID like '" & VUID & "'"
Else
' Insert part data into Part_Source table
mydb.Execute "INSERT INTO Part_Source(PartDes, PartWeight, PartLength , PartWidth , PartHeight , BZA) values ('" & vPartDes & "', '" & _
vPartWeight & "', '" & vPartLength & "', '" & vPartWidth & "', '" & vPartHeight & "', '" & vBZA & "')"
' Read UID of last record
Set rsUID = mydb.OpenRecordset("select @@identity")
Debug.Print rsUID(0)
VUID = rsUID(0)
' take UID and insert into SNR_log with SNR
mydb.Execute "INSERT INTO SNR_log (UID, SNR) values ('" & VUID & "','" & vSNR & "')"
End If
'Search for SAA and UID combination in SAA_Part
xsql = " SELECT * FROM SAA_Part where SAAnumber like '" & vSAAnumber & "' and UID like '" & VUID & "' "
Set hs = mydb.OpenRecordset(xsql)
If hs.EOF Then
mydb.Execute "INSERT INTO SAA_Part(SAAnumber,UID) values ('" & vSAAnumber & "', '" & VUID & "')"
Else
Set xlc = xlc.Offset(1, 0)
End If
Loop
'If MsgBox("Save all changes?", vbQuestion + vbYesNo) = vbYes Then
'wrkCurrent.CommitTrans
'Else
'wrkCurrent.Rollback
'End If
'Set wrkCurrent = Nothing
'Close Recordsets
rs.Close
Set rs = Nothing
rsNewSnr.Close
Set rsNewSnr = Nothing
qs.Close
Set qs = Nothing
js.Close
Set js = Nothing
ks.Close
Set ks = Nothing
hs.Close
Set hs = Nothing
'Close Database
mydb.Close
Set mydb = Nothing
' Close the EXCEL file without saving the file, and clean up the EXCEL objects
Set xlc = Nothing
Set xls = Nothing
xlw.Close False
Set xlw = Nothing
Set xlx = Nothing
Exit Sub
If blnEXCEL = True Then xlx.Quit
End Sub
Thanks in advance!

Answer 1

You can't just call your procedure since it opens a fixed workbook. (Moreover, it is missing an End If).
Here is the On Click event procedure for a command button cmdImport:
Private Sub cmdImport_Click()
    Dim strFile As String
    Dim xlx As Object, xlw As Object, xls As Object, xlc As Object
    Dim vPartDes As String, vPartWeight As Double
    Dim vPartLength As Double, vPartWidth As Double
    Dim vPartHeight As Double, vBZA As String
    Dim vSAAname As String, vSAAnumber As String, vBMName As String, vBMnumber As String
    Dim blnEXCEL As Boolean
    Dim uid As Integer
    Dim rsUID As DAO.Recordset
    Dim vSNR As String, vNewSNR As String, VUID As String
    Dim rs, rsNewSnr, qs, js, ks, hs As DAO.Recordset
    'Dim wrkCurrent As DAO.Workspace
    Dim mydb As DAO.Database
    With Application.FileDialog(1) ' msoFileDialogOpen
        .Filters.Clear
        .Filters.Add "Excel workbooks (*.xls*)", "*.xls*"
        If .Show Then
            strFile = .SelectedItems(1)
        Else
            MsgBox "No workbook specified!", vbExclamation
            Exit Sub
        End If
    End With
    blnEXCEL = False
    'Establish an EXCEL application object
    On Error Resume Next
    Set xlx = GetObject(, "Excel.Application")
    If Err.Number <> 0 Then
        Set xlx = CreateObject("Excel.Application")
        blnEXCEL = True
    End If
    Err.Clear
    On Error GoTo 0
    'Change True to False if you do not want the workbook to be visible when the code is running
    xlx.Visible = False
    Set xlw = xlx.Workbooks.Open(strFile, True) 'opens in read-only mode
    'Actual name of the worksheet
    Set xls = xlw.Worksheets("Sheet1")
    Set xlc = xls.Range("F2") ' This is the first cell (reference) that contains data (non-header information)
    Set mydb = CurrentDb
    'Set wrkCurrent = DBEngine.Workspaces(0)
    'wrkCurrent.BeginTrans
    ' write data to the recordset
    Do While Not IsEmpty(xlc.Value)
        vBMnumber = xlc.Offset(0, -4)
        vBMName = xlc.Offset(0, -3)
        vSAAnumber = xlc.Offset(0, -2)
        vSAAname = xlc.Offset(0, -1)
        vSNR = xlc.Value
        vNewSNR = xlc.Offset(0, 1).Value
        vPartDes = xlc.Offset(0, 2).Value
        vPartWeight = xlc.Offset(0, 3).Value
        vPartLength = xlc.Offset(0, 4).Value
        vPartWidth = xlc.Offset(0, 5).Value
        vPartHeight = xlc.Offset(0, 6).Value
        vBZA = xlc.Offset(0, 7).Value
        Dim tsql, usql, vsql, wsql, xsql As String
        'Search BMnumber and SAAnumber combination in Variant_SAA
        wsql = " SELECT * FROM Variant_SAA where BMnumber like '" & vBMnumber & "' and SAAnumber like '" & vSAAnumber & "'"
        Set ks = mydb.OpenRecordset(wsql)
        If ks.EOF Then
            mydb.Execute "INSERT INTO Variant_SAA(BMnumber,SAAnumber) values('" & vBMnumber & "', '" & vSAAnumber & "') "
            'Search for SNR or NewSNR
            tsql = "SELECT * FROM SNR_Log where SNR like '" & vSNR & "' or SNR like '" & vNewSNR & "'"
            Set rs = mydb.OpenRecordset(tsql)
            If rs.RecordCount > 0 Then
                rs.MoveFirst
                VUID = rs!uid
            Else
                VUID = -1
            End If
            If VUID > 0 Then
                ' Update information in Part_Source table
                mydb.Execute "UPDATE [Part_Source] SET PartDes = '" & vPartDes & "', PartWeight = '" & vPartWeight & "' , PartLength ='"
& vPartLength & _
                             "' , PartWidth= '" & vPartWidth & "', PartHeight= '" & vPartHeight
& "' , BZA = '" & vBZA & "' WHERE UID like '" & VUID & "'"
            Else
                ' Insert part data into Part_Source table
                mydb.Execute "INSERT INTO Part_Source(PartDes, PartWeight, PartLength , PartWidth , PartHeight , BZA) values ('" & vPartDes & "', '" &
                             vPartWeight & "', '" & vPartLength & "', '" & vPartWidth
& "', '" & vPartHeight & "', '" & vBZA & "')"
                ' Read UID of last record
                Set rsUID = mydb.OpenRecordset("select @@identity")
                Debug.Print rsUID(0)
                VUID = rsUID(0)
                ' take UID and insert into SNR_log with SNR
                mydb.Execute "INSERT INTO SNR_log (UID, SNR) values ('" & VUID & "','" & vSNR & "')"
            End If
        End If
        'Search for SAA and UID combination in SAA_Part
        xsql = " SELECT * FROM SAA_Part where SAAnumber like '" & vSAAnumber & "' and UID like '" & VUID & "' "
        Set hs = mydb.OpenRecordset(xsql)
        If hs.EOF Then
            mydb.Execute "INSERT INTO SAA_Part(SAAnumber,UID) values ('" & vSAAnumber & "', '" & VUID & "')"
        Else
            Set xlc = xlc.Offset(1, 0)
        End If
    Loop
    'If MsgBox("Save all changes?", vbQuestion + vbYesNo) = vbYes Then
    'wrkCurrent.CommitTrans
    'Else
    'wrkCurrent.Rollback
    'End If
    'Set wrkCurrent = Nothing
    'Close Recordsets
    rs.Close
    Set rs = Nothing
    rsNewSnr.Close
    Set rsNewSnr = Nothing
    qs.Close
    Set qs = Nothing
    js.Close
    Set js = Nothing
    ks.Close
    Set ks = Nothing
    hs.Close
    Set hs = Nothing
    'Close Database
    mydb.Close
    Set mydb = Nothing
    ' Close the EXCEL file without saving the file, and clean up the EXCEL objects
    Set xlc = Nothing
    Set xls = Nothing
    xlw.Close False
    Set xlw = Nothing
    Set xlx = Nothing
    If blnEXCEL = True Then xlx.Quit
End Sub
Regards, Hans Vogelaar (http://www.eileenslounge.com)