Get database path

[claytonjgordon]

Is there a command that will provide you with the path of your database? I want to use the transfer spreedsheet command which requires that I provide the path of the file I'm transferring. The problem is that there are multiple front ends and the table is located on each front end. After the users enter the information it needs to apend the records onto a different back end table shared by all users.

This sounds like something that would be pretty easy, sort of like a Environ("username") command but I was unable to locate it in Help, the FAQ, or through various key word searches.


Dominus Nihil
(Master of Nothing)

 

[PHV]

Have a look at:
CurrentProject.Path
CurrentProject.FullName
CodeProject.Path
CodeProject.FullName
CurrentDb.Name

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ181-2886

 

[claytonjgordon]

I was able to get the transfer spreadsheet to work importanting an Excel spreadsheet to the SQL table off a button click from a form with hidden txtworkbook text field and 1stworkbooks list box fields, using the following code:

Private Sub cmdPickFile_Click()
On Error GoTo cmdPickFile_Click_Error
Dim strDefaultLocation As String
strDefaultLocation = Get_ExcelLocation(Left(strDefaultLocation, InStrRev(strDefaultLocation, "\")))
If Len(strDefaultLocation) <> 0 Then
  Me.txtWorkbook = strDefaultLocation
  Me.lstWorkbooks.RowSource = Get_WorksheetNames(strDefaultLocation)
  DoCmd.TransferSpreadsheet acImport, , "dbo_CCCCETBELLD", Me!txtWorkbook, True
  MsgBox ("Audit Exceptions have been imported to the CCC exeption table (CCCCETBELLD)")
  DoCmd.OpenQuery ("delete CCCCETBELLD Qry")
  Else
  MsgBox ("Import Failed"), vbCritical
 End If

cmdPickFile_Click_Exit:
Exit Sub

cmdPickFile_Click_Error:
Select Case Err.Number
  Case 94 'Invalid Use of Null
    strDefaultLocation = "C:\"
    Resume Next
  Case Else
    Debug.Print Now, "cmdPickFile_Click", Err.Number, Err.Description
End Select
End Sub

and these modules

Option Compare Database

Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
"GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

Private Type OPENFILENAME
  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

Public Function Get_ExcelLocation(Optional DefaultDirectory As String = "C:\") As String
On Error Resume Next
Dim OpenFile As OPENFILENAME
Dim lReturn As Long
Dim sFilter As String

sFilter = "Excel files (*.xls)" & Chr(0) & "*.xls"
With OpenFile
  .lStructSize = Len(OpenFile)
  .hwndOwner = Application.hWndAccessApp
  .lpstrFilter = sFilter
  .nFilterIndex = 1
  .lpstrFile = String(257, 0)
  .nMaxFile = Len(OpenFile.lpstrFile) - 1
  .lpstrFileTitle = OpenFile.lpstrFile
  .nMaxFileTitle = OpenFile.nMaxFile
  .lpstrInitialDir = DefaultDirectory
  .lpstrTitle = "Select the Expeditor workbook"
  .flags = 0
End With
lReturn = GetOpenFileName(OpenFile)
If lReturn = 0 Then
  Err.Raise 8005, "Get_ExcelLocation", "No file was selected"
Else
  Get_ExcelLocation = Replace(OpenFile.lpstrFile, Chr(0), "")
End If
End Function

Public Function Get_WorksheetNames(FilePathName As String) As String
'Returns a delimited string you can use as the RowSource for an unbound ListBox set for ValueList
On Error GoTo Get_WorksheetNames_Error
Dim objWorkbook As Object, objWorksheet As Object
Set objWorkbook = GetObject(FilePathName)
For Each objWorksheet In objWorkbook.WOrksheets
  Get_WorksheetNames = objWorksheet.Name & ";"
Next objWorksheet
'Stop

Get_WorksheetNames_Exit:
Set objWorkbook = Nothing
Get_WorksheetNames = Left(Get_WorksheetNames, Len(Get_WorksheetNames) - 1)
Exit Function

Get_WorksheetNames_Error:
Debug.Print Now, "Get_WorksheetNames", Err.Number, Err.Description
GoTo Get_WorksheetNames_Exit
End Function

but I can't seem to tweek it so that it will work with an access table instead of a excel file (using the transferdatabase command instead of the transfer spreadsheet command).


This is probably my best attempt

Private Sub cmdPickFile_Click()
On Error GoTo cmdPickFile_Click_Error
Dim strDefaultLocation As String
strDefaultLocation = Application.CurrentProject.Path
If Len(strDefaultLocation) <> 0 Then
  Me.txtWorkbook = strDefaultLocation
  Me.lstWorkbooks.RowSource = Get_WorksheetNames(strDefaultLocation)
  DoCmd.TransferDatabase acImport, "Microsoft Access", strDefaultLocation, acTable, "CCCCETBELLD", "dbo_CCCCETBELLD", False
  MsgBox ("Audit Exceptions have been imported to the CCC exeption table (CCCCETBELLD)")
  DoCmd.Close (acForm), "ManualExceptionForm"
  DoCmd.OpenQuery "delete CCCCETBELLD Qry"
  Else
  MsgBox ("Import Failed"), vbCritical
 End If

cmdPickFile_Click_Exit:
Exit Sub

cmdPickFile_Click_Error:
Select Case Err.Number
  Case 94 'Invalid Use of Null
    strDefaultLocation = "C:\"
    Resume Next
  Case Else
    Debug.Print Now, "cmdPickFile_Click", Err.Number, Err.Description
End Select
End Sub

Can anyone point out for me what I'm doing wrong and/or what I need to change for this to work?


Dominus Nihil
(Master of Nothing)

 

[claytonjgordon]

I also tried

strDefaultLocation = Application.CurrentProject.Path & "\CCC SQL.mdb"

Dominus Nihil
(Master of Nothing)

 

[JerryKlmns]

Dominus

If I read it correctly, your users have a local table in their FE mdb, but all share a linked table in the BE mdb.
If this is correct then use an append query like

INSERT INTO BE_Table
SELECT FE_Table.*
FROM FE_Table
WHERE ......

You only have to define the WHERE clause, which shall retrieve the records to be send (appended) to the linked table.

 

[claytonjgordon]

Ahhh, of course!!!!

I didn't even think of that.

Thank you very much.


Dominus Nihil
(Master of Nothing)