I'm using the code below to link my bank-end database to the front-end. It works fine without having a password on the back-end DB. How do I use the same code with a password protected back-end file. NOTE: The following code is obtained from [Stackoverflow question][1]
[1]: https://stackoverflow.com/questions/3315306/how-can-a-relative-path-specify-a-linked-table-in-access-2007
Private Sub Form_Load()
Dim strOldConnect As String
Dim strNewConnect As String
Dim intSlashLoc As Integer
Dim intEqualLoc As Integer
Dim strConnect As String
Dim strFile As String
Dim strCurrentPath As String
strCurrentPath = CurrentProject.path
Dim tblDef As TableDef
Dim tblPrp As Property
For Each tblDef In CurrentDb.TableDefs
Debug.Print tblDef.Name
If tblDef.Connect & "." <> "." Then
strOldConnect = tblDef.Connect
intEqualLoc = InStr(1, strOldConnect, "=", vbTextCompare)
strConnect = Left(strOldConnect, intEqualLoc)
intSlashLoc = InStrRev(strOldConnect, "\", -1, vbTextCompare)
strFile = Right(strOldConnect, Len(strOldConnect) - intSlashLoc)
strNewConnect = strConnect & strCurrentPath & "\" & strFile
tblDef.Connect = strNewConnect
tblDef.RefreshLink
End If
Next tblDef
End Sub
The whole connection string for Access Microsoft ACE OLEDB 12.0 is:
Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\myFolder\myAccessFile.accdb; Jet OLEDB:Database Password=MyDbPassword;
See this link for reference https://www.connectionstrings.com/access/
In your case this would to the trick:
tblDef.Connect = "PWD=" & MyPassword & ";DATABASE=" & YourDatabasePath
I found a workaround myself and would like to share it, thank you.
Public Function DBconnect()
Dim Password As String
Dim FileName As String
Dim CurrentConnection As String
Dim AccessConnect As String
Dim NewConnection As String
Dim CurrentPath As String
Dim CurrentLocationEnd As Integer
AccessConnect = "MS Access;PWD=password;DATABASE="
Password = "password"
CurrentPath = CurrentProject.Path
Dim tblDef As TableDef
Dim tblPrp As Property
For Each tblDef In CurrentDb.TableDefs
Debug.Print tblDef.Name
If tblDef.Connect & "." <> "." Then
CurrentConnection = tblDef.Connect
CurrentLocationEnd = InStrRev(CurrentConnection, "\", -1, vbTextCompare)
FileName = Right(CurrentConnection, Len(CurrentConnection) - CurrentLocationEnd)
NewConnection = AccessConnect & CurrentPath & "\" & FileName
tblDef.Connect = NewConnection
tblDef.RefreshLink
End If
Next tblDef
End Function
Related
I am trying to import exported objects from another database. The file extension is vba. I have created a loop to go through all the objects. My loop does go through all the files properly. The loop does import a module as Module 1 for the first file. I want to rename the module from module 1 to the previous module name.
I am working with MS Access office 365.
Sub LoopThroughFiles2()
Dim strFile As String
Dim strNewFile As String
Dim strPath As String
Dim strNewPath As String
Dim strDBName As String
Dim strModName As String
strDBName = Application.CurrentProject.Name
strPath = ("C:\Users\Parents\Google Drive\Access Files\File7\")
strFile = Dir(strPath & "*")
Do While Len(strFile) > 0
Debug.Print strFile
Debug.Print strPath
strNewFile = Replace(strFile, ".vba", ".txt", 1, , vbTextCompare)
Debug.Print strNewFile
Name strPath & strFile As strPath & strNewFile
strNewPath = strPath & strFile
strModName = Replace(strNewFile, ".txt", "")
Debug.Print strModName
VBE.ActiveVBProject.VBComponents.Import strNewPath
VBProj.VBComponents("Module 1").Name = strModName 'error 424
DoCmd.Rename strModName, acModule, "Module1" 'error 7874
Loop
End Sub
You can't change the name directly, but you can change a property instead, like this:
VBE.ActiveVBProject.VBComponents("Module 1").Properties("Name").Value = strModName
I have the below code working for me provided the "Model_data.xlsm" file is stored in my hard drive. Is it possible if Access can get the data from "model_data.xlsm" stored in Sharepoint?
Private Sub Update_manu_data_Click()
Dim strXls As String
strXls = CurrentProject.Path & Chr(92) & "Model_data.xlsm"
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "Manufacturing_data", _
strXls, True, "Combined!"
End Sub
Finally I did find a workaround for this issue.
I Created a private function in access to download the Excel file from SP and then used the Transferspread sheet function to retrieve the data into access table.
Below is the code i used to download the Excel file in SP using access Vba
Private Sub Command2_Click()
Dim Ex As Object
Dim Acc As Object
Dim strXls As String
Set Ex = CreateObject("Excel.Application")
Set Acc = Ex.Workbooks.Open("https://Sharepoint File link")
Ex.Visible = False
Acc.SaveAs "C:\Users\.......\test.xlsx"
Acc.Close
Ex.Quit
strXls = CurrentProject.Path & Chr(92) & "C:\Users\.......\test.xlsx"
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "Tablename", _
strXls, True, "Sheet(1)!"
End Sub
Sub ConnectToExcel()
Dim strSharePointPath As String
Dim strExcelPath As String
Dim strConnectionString As String
Dim cnn As ADODB.Connection
Dim rs As ADODB.Recordset
' Set the SharePoint path and Excel file name
strSharePointPath = "http://yoursharepointurl.com/YourSharePointFolder/"
strExcelPath = "YourExcelFile.xlsx"
' Build the connection string
strConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"WSS;IMEX=0;RetrieveIds=Yes;" & _
"DATABASE=" & strSharePointPath & ";" & _
"LIST=" & strExcelPath & ";"
' Open the connection
Set cnn = New ADODB.Connection
cnn.Open strConnectionString
' Open a recordset
Set rs = New ADODB.Recordset
rs.Open "SELECT * FROM [Sheet1$]", cnn
' Loop through the recordset and display the data
Do While Not rs.EOF
Debug.Print rs.Fields(0).Value
rs.MoveNext
Loop
' Clean up
rs.Close
Set rs = Nothing
cnn.Close
Set cnn = Nothing
End Sub
Private Sub Command38_Click()
Dim f As Object
Dim db As DAO.Database
Dim qdf As DAO.QueryDef
Dim strUpdate As String
Dim strFile As String
Dim strFolder As String
Dim varItem As Variant
Dim P As String
Dim DeleteEverything As String
DoCmd.SetWarnings False
DeleteEverything = "DELETE * FROM [ucppltr]"
DoCmd.RunSQL DeleteEverything
Set f = Application.FileDialog(3)
f.AllowMultiSelect = True
f.InitialFileName = "S:\Formware\outfile\ucppt12\Storage"
f.Filters.Clear
f.Filters.Add " Armored TXT Files", "*.asc"
If f.Show Then
For Each varItem In f.SelectedItems
strFile = Dir(varItem)
strFolder = Left(varItem, Len(varItem) - Len(strFile))
P = strFolder & strFile
DoCmd.TransferText acImportDelim, "UCPP Import Specification", "ucppltr", P, False
Next
End If
strUpdate = "PARAMETERS fileName Text;" & vbCrLf & _
"UPDATE ucppltr" & vbCrLf & _
"Set [File Name] = fileName"
Debug.Print strUpdate
Set db = CurrentDb
Set qdf = db.CreateQueryDef("", strUpdate)
qdf.Parameters("fileName") = strFile
qdf.Execute dbFailOnError
Set qdf = Nothing
Set db = Nothing
Set f = Nothing
MsgBox DCount("*", "ucppltr") & " Records were imported"
End Sub
As you can see from the code on import I want to store the file name and while it does work it doesn't work exactly how I need it to. When we do work for this client it is 5 files ate a time once a week so I would like it to save all 5 file names however it only saves the last one it imports. My question, is there a way to save each file name to each one ( I doubt that) or can I save all 5 file names to all the records I import instead of just the last file name?
I always have the option of only allowing a single import and making them import and append the table 5 times I just wanted to check to see if there is a more efficent way before doing so.
Thanks in advance for any help in this matter!
There is a problem in your logic. Inside the loop, strFile holds the current file name. So after your loop is finished, only the current (=last) file name is passed on to the query.
I made some changes, so the filenames are now stored in the new variable strFileList, delimited by a ";". Please check, if this is a feasible solution.
Private Sub Command38_Click()
Dim f As Object
Dim db As DAO.Database
Dim qdf As DAO.QueryDef
Dim strUpdate As String
Dim strFile As String
Dim strFolder As String
Dim varItem As Variant
Dim P As String
Dim DeleteEverything As String
' Variable to hold file list
Dim strFileList As String
DoCmd.SetWarnings False
DeleteEverything = "DELETE * FROM [ucppltr]"
DoCmd.RunSQL DeleteEverything
Set f = Application.FileDialog(3)
f.AllowMultiSelect = True
f.InitialFileName = "S:\Formware\outfile\ucppt12\Storage"
f.Filters.Clear
f.Filters.Add " Armored TXT Files", "*.asc"
If f.Show Then
For Each varItem In f.SelectedItems
strFile = Dir(varItem)
strFolder = Left(varItem, Len(varItem) - Len(strFile))
P = strFolder & strFile
DoCmd.TransferText acImportDelim, "UCPP Import Specification", "ucppltr", P, False
'Add file name to file list
strFileList = strFileList & strFile & ";"
Next
End If
strUpdate = "PARAMETERS fileName Text;" & vbCrLf & _
"UPDATE ucppltr" & vbCrLf & _
"Set [File Name] = fileName"
Debug.Print strUpdate
Set db = CurrentDb
Set qdf = db.CreateQueryDef("", strUpdate)
'Pass file list to query
qdf.Parameters("fileName") = strFileList
qdf.Execute dbFailOnError
Set qdf = Nothing
Set db = Nothing
Set f = Nothing
MsgBox DCount("*", "ucppltr") & " Records were imported"
End Sub
I want to write all the records in a query to an e-mail.
This writes the first record in the query.
MyBodyText = MailList("AccountName") & " - " & MailList("ExpirationDate")
I know I need some kind of loop.
MailList is defined as follows
Set MailList = db.OpenRecordset("qryDateEmail")
Option Compare Database
Option Explicit
Public Function ExpirationDate()
Dim strSQL
Dim db As DAO.Database
Dim MailList As DAO.Recordset
Dim MyOutlook As Outlook.Application
Dim MyMail As Outlook.MailItem
Dim Subjectline As String
Dim BodyFile As String
Dim fso As FileSystemObject
Dim MyBody As TextStream
Dim MyBodyText As String
Dim MyDecision As String
Dim strReportName As String
Dim strEnroll As String
Dim strWho As String
Dim strEmail As String
Set fso = New FileSystemObject
Set MyOutlook = New Outlook.Application
Set db = CurrentDb()
Set MailList = db.OpenRecordset("qryDateEmail")
Subjectline$ = "Expiration Date" & " " & Date
Set MyMail = MyOutlook.CreateItem(olMailItem)
Do While Not MailList.EOF
MyBodyText = MailList("AccountName") & " - " & MailList("ExpirationDate")
MailList.MoveNext
Loop
MyMail.To = "" & ""
MyMail.CC = CurrentUser() & ""
MyMail.Subject = Subjectline$
MyMail.Body = MyBodyText
MyMail.Display
strEmail = Now()
strWho = CurrentUser()
Set MyMail = Nothing
Set MyOutlook = Nothing
End Function
You could loop through the recordset, adding those values from each row to your body text.
Untested air code:
With MailList
Do While Not .EOF
MyBodyText = MyBodyText & !AccountName & _
" - " & !ExpirationDate & vbCrLf
.MoveNext
Loop
End With
Now I see you've added similar code to your question. The problem is that code overwrites the value of MyBodyText each time through the loop. Append to MyBodyText each time instead of replacing the text ...
MyBodyText = MyBodyText & "new text"
instead of ...
MyBodyText = "new text"
I've got two Access databases that share linked tables. They are deployed together in a directory and accessed via code in a Word form.
How can I make sure that the links are preserved when the two databases are copied (together) to a different folder? Since I'm not "opening" the database, per se (it's being accessed via ADO), I don't know how to write code to refresh the links.
Update 14APR2009
I found that the previous answer I gave here was erroneous, so I updated it with new code.
How to proceed
Copy the code below to a VBA module.
From code or from the Immediate window in the VBA IDE, simply type:
RefreshLinksToPath Application.CurrentProject.Path
This will now relink all the linked tables to use the directory where your application is located.
It only needs to be done once or whenever you relink or add new tables.
I recommend doing this from code every time you start your application.
You can then move your databases around without problems.
Code
'------------------------------------------------------------'
' Reconnect all linked tables using the given path. '
' This only needs to be done once after the physical backend '
' has been moved to another location to correctly link to '
' the moved tables again. '
' If the OnlyForTablesMatching parameter is given, then '
' each table name is tested against the LIKE operator for a '
' possible match to this parameter. '
' Only matching tables would be changed. '
' For instance: '
' RefreshLinksToPath(CurrentProject.Path, "local*") '
' Would force all tables whose ane starts with 'local' to be '
' relinked to the current application directory. '
'------------------------------------------------------------'
Public Function RefreshLinksToPath(strNewPath As String, _
Optional OnlyForTablesMatching As String = "*") As Boolean
Dim collTbls As New Collection
Dim i As Integer
Dim strDBPath As String
Dim strTbl As String
Dim strMsg As String
Dim strDBName As String
Dim strcon As String
Dim dbCurr As DAO.Database
Dim dbLink As DAO.Database
Dim tdf As TableDef
Set dbCurr = CurrentDb
On Local Error GoTo fRefreshLinks_Err
'First get all linked tables in a collection'
dbCurr.TableDefs.Refresh
For Each tdf In dbCurr.TableDefs
With tdf
If ((.Attributes And TableDefAttributeEnum.dbAttachedTable) = TableDefAttributeEnum.dbAttachedTable) _
And (.Name Like OnlyForTablesMatching) Then
collTbls.Add Item:=.Name & .Connect, key:=.Name
End If
End With
Next
Set tdf = Nothing
' Now link all of them'
For i = collTbls.count To 1 Step -1
strcon = collTbls(i)
' Get the original name of the linked table '
strDBPath = Right(strcon, Len(strcon) - (InStr(1, strcon, "DATABASE=") + 8))
' Get table name from connection string '
strTbl = Left$(strcon, InStr(1, strcon, ";") - 1)
' Get the name of the linked database '
strDBName = Right(strDBPath, Len(strDBPath) - InStrRev(strDBPath, "\"))
' Reconstruct the full database path with the given path '
strDBPath = strNewPath & "\" & strDBName
' Reconnect '
Set tdf = dbCurr.TableDefs(strTbl)
With tdf
.Connect = ";Database=" & strDBPath
.RefreshLink
collTbls.Remove (.Name)
End With
Next
RefreshLinksToPath = True
fRefreshLinks_End:
Set collTbls = Nothing
Set tdf = Nothing
Set dbLink = Nothing
Set dbCurr = Nothing
Exit Function
fRefreshLinks_Err:
RefreshLinksToPath = False
Select Case Err
Case 3059:
Case Else:
strMsg = "Error Information..." & vbCrLf & vbCrLf
strMsg = strMsg & "Function: fRefreshLinks" & vbCrLf
strMsg = strMsg & "Description: " & Err.Description & vbCrLf
strMsg = strMsg & "Error #: " & Format$(Err.Number) & vbCrLf
MsgBox strMsg
Resume fRefreshLinks_End
End Select
End Function
This code is adapted from this source: http://www.mvps.org/access/tables/tbl0009.htm.
I removed all dependency on other functions to make it self-contained, that's why it's a bit longer than it should.
Renaud's answer no longer works in Access 2010 with Excel or CSV files.
I have made a few modifications:
Adapted to the current pattern for the connection string
Handled the database path differently for Excel files (includes filename) and CSV files (does not include filename)
Here is the code:
Public Function RefreshLinksToPath(strNewPath As String, _
Optional OnlyForTablesMatching As String = "*") As Boolean
Dim collTbls As New Collection
Dim i As Integer
Dim strDBPath As String
Dim strTbl As String
Dim strMsg As String
Dim strDBName As String
Dim strcon As String
Dim dbCurr As DAO.Database
Dim dbLink As DAO.Database
Dim tdf As TableDef
Set dbCurr = CurrentDb
On Local Error GoTo fRefreshLinks_Err
'First get all linked tables in a collection'
dbCurr.TableDefs.Refresh
For Each tdf In dbCurr.TableDefs
With tdf
If ((.Attributes And TableDefAttributeEnum.dbAttachedTable) = _
TableDefAttributeEnum.dbAttachedTable) _
And (.Name Like OnlyForTablesMatching) Then
Debug.Print "Name: " & .Name
Debug.Print "Connect: " & .Connect
collTbls.Add Item:=.Name & ";" & .Connect, Key:=.Name
End If
End With
Next
Set tdf = Nothing
' Now link all of them'
For i = collTbls.Count To 1 Step -1
strConnRaw = collTbls(i)
' Get table name from the full connection string
strTbl = Left$(strConnRaw, InStr(1, strConnRaw, ";") - 1)
' Get original database path
strDBPath = Right(strConnRaw, Len(strConnRaw) - (InStr(1, strConnRaw, "DATABASE=") + 8))
' Get the name of the linked database
strDBName = Right(strDBPath, Len(strDBPath) - InStrRev(strDBPath, "\"))
' Get remainder of connection string
strConn = Mid(strConnRaw, InStr(1, strConnRaw, ";") + 1, InStr(1, strConnRaw, "DATABASE=") _
- InStr(1, strConnRaw, ";") - 1)
' Reconstruct the full database path with the given path
' CSV-Files are not linked with their name!
If Left(strConn, 4) = "Text" Then
strDBPath = strNewPath
Else
strDBPath = strNewPath & "\" & strDBName
End If
' Reconnect '
Set tdf = dbCurr.TableDefs(strTbl)
With tdf
.Connect = strConn & "Database=" & strDBPath
.RefreshLink
collTbls.Remove (.Name)
End With
Next
RefreshLinksToPath = True
fRefreshLinks_End:
Set collTbls = Nothing
Set tdf = Nothing
Set dbLink = Nothing
Set dbCurr = Nothing
Exit Function
fRefreshLinks_Err:
RefreshLinksToPath = False
Select Case Err
Case 3059:
Case Else:
strMsg = "Error Information..." & vbCrLf & vbCrLf
strMsg = strMsg & "Function: fRefreshLinks" & vbCrLf
strMsg = strMsg & "Description: " & Err.Description & vbCrLf
strMsg = strMsg & "Error #: " & Format$(Err.Number) & vbCrLf
MsgBox strMsg
Resume fRefreshLinks_End
End Select
End Function
Are you referring to updating the links within your Word form, or the linked table links between your Access databases?
For the former, the best way that I know is to keep your connection string(s) at the Module level within your Word document/VBA project and make them const strings. Then when setting the connection string for your ADO Connection objects, pass it the relative connection string const.
For the latter, I would be tempted to use a relative path in the connection string to data within each Access database to the other. For example,
Dim connectionString as String
connectionString = ";DATABASE=" & CurrentProject.Path & "\[Database Name Here].mdb"
if as you say, the databases are copied together to a different folder (I'm assuming into the same folder).
I am unfortunately still on Access 2007. I started with one of the code blocks above which was not working for me. Having less access vba power I simplified it to only the first loop which gets the table paths and updates it in place. The next guy running into this can comment or update.
Option Compare Database
'------------------------------------------------------------'
' Reconnect all linked tables using the given path. '
' This only needs to be done once after the physical backend '
' has been moved to another location to correctly link to '
' the moved tables again. '
' If the OnlyForTablesMatching parameter is given, then '
' each table name is tested against the LIKE operator for a '
' possible match to this parameter. '
' Only matching tables would be changed. '
' For instance: '
' RefreshLinksToPath(CurrentProject.Path, "local*") '
' Would force all tables whose ane starts with 'local' to be '
' relinked to the current application directory. '
'
' Immediate window type
' RefreshLinksToPath Application.CurrentProject.Path
'------------------------------------------------------------'
Public Function RefreshLinksToPath(strNewPath As String, _
Optional OnlyForTablesMatching As String = "*") As Boolean
Dim strDBPath As String
'Dim strTbl As String
'Dim strMsg As String
Dim strDBName As String
Dim dbCurr As DAO.Database
Dim dbLink As DAO.Database
Dim tdf As TableDef
Set dbCurr = CurrentDb
Dim strConn As String
Dim strNewDbConn1 As String
Dim strNewDbConn2 As String
Dim strNewDbConn As String
' On Local Error GoTo fRefreshLinks_Err
'First get all linked tables in a collection'
dbCurr.TableDefs.Refresh
For Each tdf In dbCurr.TableDefs
With tdf
If ((.Attributes And TableDefAttributeEnum.dbAttachedTable) = TableDefAttributeEnum.dbAttachedTable) _
And (.Name Like OnlyForTablesMatching) Then
strConn = tdf.Connect
strDBPath = Right(strConn, Len(strConn) - (InStr(1, strConn, "DATABASE=") + 8))
strDBName = Right(strDBPath, Len(strDBPath) - InStrRev(strDBPath, "\"))
Debug.Print ("===========================")
Debug.Print (" connect is " + strConn)
Debug.Print (" DB PAth is " + strDBPath)
Debug.Print (" DB Name is " + strDBName)
strDBNewPath = strNewPath & "\" & strDBName
Debug.Print (" DB NewPath is " + strDBNewPath)
strNewDbConn1 = Left(strConn, (InStr(1, strConn, "DATABASE=") - 1))
strNewDbConn2 = "DATABASE=" & strDBNewPath
strNewDbConn = strNewDbConn1 & strNewDbConn2
Debug.Print (" DB strNewDbConn is " + strNewDbConn)
'Change the connect path
tdf.Connect = strNewDbConn
tdf.RefreshLink
End If
End With
Next
End Function