When I use the Export to html function with Report, Access generate multiple pages of html (each page has about 30 lines or so of data).
How can I force Access to generate ONE SINGLE html file for the whole report? Thanks.
I created a function that may be helpful for others. It takes the a file path and then follows the links until the document is done. You need to export the report to an html file and then use that path in this function. I use it for creating a message for Outlook.
This requires a reference to the Windows Script Host Object Model
Public Function fReadFile(strFile As String) As String
On Error GoTo ErrHandler
Dim FSO As FileSystemObject
Dim tsInput As TextStream
Dim strLine, strMessage As String
Dim strNextFile As String
Dim blnEnd As Boolean
Do While Not blnEnd
Set FSO = New FileSystemObject
Set tsInput = FSO.OpenTextFile(strFile, 1)
Do While Not tsInput.AtEndOfStream
strLine = tsInput.ReadLine
If InStr(1, strLine, ">First<", vbTextCompare) > 0 And InStr(1, strLine, ">Previous<", vbTextCompare) > 0 And InStr(1, strLine, ">Next<", vbTextCompare) > 0 And InStr(1, strLine, ">Last<", vbTextCompare) > 0 Then
Debug.Print strLine
strNextFile = Mid(strLine, InStr(1, strLine, ">Previous</A> Next<", vbTextCompare) - (InStr(1, strLine, ">Previous <A HREF=", vbTextCompare) + 23))
rem put the directory back in the file name
strNextFile = IIf(strNextFile <> "#", Mid(strFile, 1, (InStrRev(strFile, "\"))) & strNextFile, strFile)
blnEnd = (strNextFile = strFile)
Else
strMessage = strMessage & strLine
End If
Loop
tsInput.Close
Set FSO = Nothing
strFile = strNextFile
Loop
fReadFile = strMessage
Exit Function
ErrHandler:
Debug.Print Err.Description & " " & "fReadFile"
Resume Next
End Function
well it's kind of a funny workaround but you could export as an .rtf, then open in word and save as .htm. voila!
Can't be done. Paper size has to be set based on printer driver. Access does not allow User Defined paper size even though this option exists in Page Setup.
Related
I have a table that contains a paths of multi pdfs file...now I need a VBA code to merge all these files to a single pdf file.
Notice:-the number of pdfs files to be merged varies from time to time.
Sub Combine_PDFs_Demo()
Dim i As Integer 'counter for records
Dim x As Integer
Dim strNPDF As String
Dim bSuccess As Boolean
Dim DB As Database
Dim RS As Recordset
Set DB = CurrentDb
Set RS = DB.OpenRecordset("SELECT[paths] from scantemp ")
strNPDF = CurrentProject.Path & "\request_pic\" & (request_no) & ".pdf"
RS.MoveLast
DB.Recordsets.Refresh
i = RS.RecordCount
RS.MoveFirst
Dim strPDFs() As String
ReDim strPDFs(0 To i)
strPDFs(0) = RS![paths]
RS.MoveNext
For i = 1 To i - 1
strPDFs(i) = RS![paths]
bSuccess = MergePDFs(strPDFs, strNPDF)
Next i
If bSuccess = False Then MsgBox "Failed to combine all PDFs", vbCritical, "Failed to Merge PDFs"
DoCmd.SetWarnings False
DoCmd.RunSQL "delete from scantemp" 'delete all paths from table scantemp after converted it to pdf
DoCmd.SetWarnings True
RS.Close
Set RS = Nothing`enter code here`
public Function MergePDFs(arrFiles() As String, strSaveAs As String) As Boolean
Dim objCAcroPDDocDestination As Acrobat.CAcroPDDoc
Dim objCAcroPDDocSource As Acrobat.CAcroPDDoc
Dim i As Integer
Dim iFailed As Integer
On Error GoTo NoAcrobat:
'Initialize the Acrobat objects
Set objCAcroPDDocDestination = CreateObject("AcroExch.PDDoc")
Set objCAcroPDDocSource = CreateObject("AcroExch.PDDoc")
'Open Destination, all other documents will be added to this and saved with
'a new filename
objCAcroPDDocDestination.Open (arrFiles(LBound(arrFiles))) 'open the first file
'Open each subsequent PDF that you want to add to the original
'Open the source document that will be added to the destination
For i = LBound(arrFiles) + 1 To UBound(arrFiles)
objCAcroPDDocSource.Open (arrFiles(i))
If objCAcroPDDocDestination.InsertPages(objCAcroPDDocDestination.GetNumPages - 1, objCAcroPDDocSource, 0, objCAcroPDDocSource.GetNumPages, 0) Then
MergePDFs = True
Else
'failed to merge one of the PDFs
iFailed = iFailed + 1
End If
objCAcroPDDocSource.Close
Next i
objCAcroPDDocDestination.save 1, strSaveAs 'Save it as a new name
objCAcroPDDocDestination.Close
Set objCAcroPDDocSource = Nothing
Set objCAcroPDDocDestination = Nothing
NoAcrobat:
If iFailed <> 0 Then
MergePDFs = False
End If
On Error GoTo 0
End Function
This uses a list of PDF or PS files to create one PDF. Sorry it's in VB.net and I don't really have time to convert. But it illustrates the concept if you can wade through it. Basically you write the options and file names to a text file then use that file as an argument to Ghostscript.
Private Shared Sub ConvertToPDF(ByVal PSPathFileList As List(Of String), _
ByVal PDFPathName As String, _
ByVal WaitForExit As Boolean, ByVal DeletePS As Boolean)
'check that all files exist
PSPathFileList.ForEach(AddressOf CheckFiles)
'check old pdf file
If IO.File.Exists(PDFPathName) Then
Throw New ApplicationException( _
"PDF cannot be created. File already exists: " & PDFPathName)
End If
'convert engine
Dim myProcInfo As New ProcessStartInfo
myProcInfo.FileName = DanBSolutionsLocation & "Misc\GhostScript\GSWIN32C.EXE"
Debug.Print(myProcInfo.FileName)
'write file names to text file as the list can be very long
Dim tempPath As String = IO.Path.GetDirectoryName(PSPathFileList.Item(0))
Dim fiName2 As String = tempPath & IO.Path.GetFileNameWithoutExtension(PDFPathName) & ".txt"
Dim ft As New StreamWriter(fiName2)
ft.WriteLine("-sDEVICE=pdfwrite -q -dSAFER -dNOPAUSE -sOUTPUTFILE=""" & PDFPathName & """ -dBATCH ")
For i As Long = 0 To PSPathFileList.Count - 1
ft.WriteLine(Chr(34) & PSPathFileList.Item(i) & Chr(34))
Next
ft.Close()
'set args to text file
myProcInfo.Arguments = """#" & fiName2 & """"
'set up for output and errors
myProcInfo.UseShellExecute = False
myProcInfo.RedirectStandardOutput = True
myProcInfo.RedirectStandardError = True
Debug.Print(myProcInfo.Arguments)
'do the conversion
Dim myProc As Process = Process.Start(myProcInfo)
Debug.Print(myProc.StandardOutput.ReadToEnd)
Debug.Print(myProc.StandardError.ReadToEnd)
If WaitForExit Then
'wait for finish; (no more than 60 seconds)
myProc.WaitForExit(60000)
'delete PS
If DeletePS Then
PSPathFileList.ForEach(AddressOf DeleteFiles)
End If
End If
End Sub
Here's VBA code for a single PS to PDF. So between the VB.net above and this below hopefully you can salvage something useful.
Private Sub printToPdfDemo()
'verify printer setup
'be sure to install the PsPrinterInstall module
Call PSPrinterSetup
Dim svPsFileName As String
Dim svPDFName As String
'define names
svPsFileName = "C:\Temp\Input 1.ps"
svPDFName = "C:\Temp\Output 1.PDF"
'save current printer
Dim PrinterInUse As String
PrinterInUse = Application.ActivePrinter
'print to PS
'If Fso.FileExists(svPsFileName) Then Call Fso.DeleteFile(svPsFileName)
Worksheets(1).PrintOut ActivePrinter:=PSPrinterName, PrintToFile:=True, _
PrToFileName:=svPsFileName
'revert to saved printer name
Application.ActivePrinter = PrinterInUse
'convert
Call ConvertToPDF(svPsFileName, svPDFName)
End Sub
Sub ConvertToPDF(ByVal svPsFileName As String, ByVal svPDFName As String)
Dim fso As New FileSystemObject
'Dim Fso: Set Fso = CreateObject("Scripting.FileSystemObject")
Dim folGS As Folder
Dim lcCmd As String
'check inputs
If svPsFileName = "" Or svPDFName = "" Then
Call MsgBox("PS file name or PDF file name is blank in ""ConvertToPDF"" macro", vbExclamation, "Error! Missing Inputs")
Exit Sub
End If
'check file
If Not fso.FileExists(svPsFileName) Then
Call MsgBox(svPsFileName & " file is not found", vbExclamation, "Error! Missing File")
Exit Sub
End If
'check variable
If DanBSolutionsLocation = "" Then DanBSolutionsLocation = GetDanBSolutionsLocation
'delete old file
If fso.FileExists(svPDFName) Then Call fso.DeleteFile(svPDFName)
'get files
Set folGS = fso.GetFolder(DanBSolutionsLocation & "Misc\GhostScript\") 'S:\DanB Solutions\Misc\GhostScript\GSWIN32C.EXE
'GS command
lcCmd = folGS.ShortPath & "\GSWIN32C.EXE " & _
"-q -dNOPAUSE -I" & folGS.ShortPath & "\lib;./fonts " & _
"-sFONTPATH=./fonts -sFONTMAP=" & folGS.ShortPath & "\lib\FONTMAP.GS " & _
"-sDEVICE=pdfwrite -sOUTPUTFILE=" & """" & svPDFName & """" _
& " -dBATCH " & """" & svPsFileName & """"
'convert
Debug.Print lcCmd
Call ShellWait(lcCmd)
'delete PS
If fso.FileExists(svPDFName) Then fso.DeleteFile (svPsFileName)
End Sub
I want to be able to view the contents of my access database's laccdb file through VBA so I can use it to alert users (through a button) who else is in the database.
I specifically don't want to use a 3rd Party tool. I have tried using:
Set ts = fso.OpenTextFile(strFile, ForReading)
strContents = ts.ReadAll
This works fine if only 1 user is in the database. But for multiple users it gets confused by the presumably non-ASCII characters and goes into this kind of thing after one entry:
Does anyone have any suggestions? It's fine if I just open the file in Notepad++...
Code eventually used is as follows (I didn't need the title and have removed some code not being used):
Sub ShowUserRosterMultipleUsers()
Dim cn As New ADODB.Connection, rs As New ADODB.Recordset
cn.Provider = "Microsoft.ACE.OLEDB.12.0"
cn.Open "Data Source=" & CurrentDb.Name
Set rs = cn.OpenSchema(adSchemaProviderSpecific, , "{947bb102-5d43-11d1-bdbf-00c04fb92675}")
While Not rs.EOF
Debug.Print rs.Fields(0)
rs.MoveNext
Wend
End Sub
I found this which should help, it's not actually reading the ldb file, but it has the info that you need (Source: https://support.microsoft.com/en-us/kb/198755):
Sub ShowUserRosterMultipleUsers()
Dim cn As New ADODB.Connection
Dim cn2 As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim i, j As Long
cn.Provider = "Microsoft.Jet.OLEDB.4.0"
cn.Open "Data Source=c:\Northwind.mdb"
cn2.Open "Provider=Microsoft.Jet.OLEDB.4.0;" _
& "Data Source=c:\Northwind.mdb"
' The user roster is exposed as a provider-specific schema rowset
' in the Jet 4 OLE DB provider. You have to use a GUID to
' reference the schema, as provider-specific schemas are not
' listed in ADO's type library for schema rowsets
Set rs = cn.OpenSchema(adSchemaProviderSpecific, _
, "{947bb102-5d43-11d1-bdbf-00c04fb92675}")
'Output the list of all users in the current database.
Debug.Print rs.Fields(0).Name, "", rs.Fields(1).Name, _
"", rs.Fields(2).Name, rs.Fields(3).Name
While Not rs.EOF
Debug.Print rs.Fields(0), rs.Fields(1), _
rs.Fields(2), rs.Fields(3)
rs.MoveNext
Wend
End Sub
I put together some code to read through the lock file and output a message listing users currently using the system.
Trying to read the whole file in at once seems to result in VBA treating the string as Unicode in the same way notepad does so I read in character by character and filter out non printing characters.
Sub TestOpenLaccdb()
Dim stm As TextStream, fso As FileSystemObject, strLine As String, strChar As String, strArr() As String, nArr As Long, nArrMax As Long, nArrMin As Long
Dim strFilename As String, strMessage As String
strFilename = CurrentProject.FullName
strFilename = Left(strFilename, InStrRev(strFilename, ".")) & "laccdb"
Set fso = New FileSystemObject
Set stm = fso.OpenTextFile(strFilename, ForReading, False, TristateFalse) 'open the file as a textstream using the filesystem object (add ref to Microsoft Scripting Runtime)
While Not stm.AtEndOfStream 'Read through the file one character at a time
strChar = stm.Read(1)
If Asc(strChar) > 13 And Asc(strChar) < 127 Then 'Filter out the nulls and other non printing characters
strLine = strLine & strChar
End If
Wend
strMessage = "Users Logged In: " & vbCrLf
'Debug.Print strLine
strArr = Split(strLine, "Admin", , vbTextCompare) 'Because everyone logs in as admin user split using the string "Admin"
nArrMax = UBound(strArr)
nArrMin = LBound(strArr)
For nArr = nArrMin To nArrMax 'Loop through all machine numbers in lock file
strArr(nArr) = Trim(strArr(nArr)) 'Strip leading and trailing spaces
If Len(strArr(nArr)) > 1 Then 'skip blank value at end
'Because I log when a user opens the database with username and machine name I can look it up in the event log
strMessage = strMessage & DLast("EventDescription", "tblEventLog", "[EventDescription] like ""*" & strArr(nArr) & "*""") & vbCrLf
End If
Next
MsgBox strMessage 'let the user know who is logged in
stm.Close
Set stm = Nothing
Set fso = Nothing
End Sub
Overall Goal:
Pull all files from folder > format files in staging table > copy staging table to master table > kill staging table > rinse and repeat until all files have been taken from folder, formatted and put into the master table.
Issue:
I have apparently not taken into account that some of the files sent to me will have blank worksheets (rather they may have a value that says "No Data" in cell A1). When my macro hits the "No Data" or blank sheet I get a Null error (94).
What I've tried:
strF1Data = Nz(!ref_val)
strF1Data = Nz(!ref_val,"")
Suspicions:
I think I can update the SQL UPDATE line to allow Nulls, but I feel like a more efficient solution would be to skip if null. However I have tried modifying the Do Until statement and had no luck...
Possibly Worth Mentioning:
The files have multiple worksheets. I learned this the hard way in finding this error on a random worksheet between several other worksheets that did have data.
Code: (to help save some space, I'm only giving the call files bit and formatting piece, I don't think the other pieces will be of any use. However if you would like them then let me know.)
The overall macro (see next code sections for piece with error):
Sub Pull_File_into_Staging_Table()
'Process:
'1 - Loop through all files saved to specified folder making an internal list of the files
'2 - Paste one files content to staging table at a time
'3 - Format the information in the staging table
'4 - Copy formatted staging table to 1Compare Table (master table)
Dim strFile As String 'Filename
Dim strFileList() As String 'File Array
Dim intFile As Integer 'File Number
Dim filename As String
Dim path As String
DoCmd.SetWarnings False
path = "C:\Users\USER\Desktop\Test\"
Dim rs As DAO.Recordset ' Moved from below
Dim db As DAO.Database
Set db = CurrentDb
'Loop through the folder & build file list
strFile = Dir(path & "*.xls")
While strFile <> ""
'add files to the list
intFile = intFile + 1
ReDim Preserve strFileList(1 To intFile)
strFileList(intFile) = strFile
strFile = Dir()
Wend
'see if any files were found
If intFile = 0 Then
MsgBox "No files found"
Exit Sub
End If
'cycle through the list of files
For intFile = 1 To UBound(strFileList)
filename = path & strFileList(intFile)
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel8, "Stage", filename, False
Call Format_Staging_Table
Call Copy_from_Stage_to_Master
Call Clear_Staging_Table
Next intFile
DoCmd.SetWarnings True
End Sub
The piece with the issue:
Sub Format_Staging_Table()
Dim strFile As String 'Filename
Dim strFileList() As String 'File Array
Dim intFile As Integer 'File Number
Dim filename As String
Dim path As String
DoCmd.SetWarnings False
path = "C:\Users\USER\Desktop\Test\"
Dim rs As DAO.Recordset ' Moved from below
Dim db As DAO.Database
Set db = CurrentDb
CurrentDb.Execute ("ALTER TABLE Stage ADD COLUMN UPC Text, SR_Profit_Center Text, SR_Super_Label Text, SAP_Profit_Center Text, SAP_Super_Label Text;")
CurrentDb.TableDefs("Stage").Fields("F1").Name = "ref_val"
Dim ref_val As String
Set rs = db.OpenRecordset("SELECT TOP 1 ref_val FROM Stage;", dbOpenDynaset)
ref_val = rs.Fields(0).Value
rs.Close
db.Execute "DELETE FROM [Stage] WHERE ref_val = '" & ref_val & "';"
Const YOUR_TABLE_NAME As String = "Stage"
Dim SQL_UPDATE_DATA As String
SQL_UPDATE_DATA = "SELECT *, ';' & '" & ref_val & "' FROM [" & YOUR_TABLE_NAME & "] WHERE SR_Profit_Center Is Null"
Dim strF1Data As String
Dim varData As Variant
Set rs = CurrentDb.OpenRecordset(SQL_UPDATE_DATA)
With rs
Do Until .EOF
strF1Data = !ref_val
varData = Split(strF1Data, ";")
If UBound(varData) = 4 Then
.Edit
!ref_val = ref_val
!UPC = varData(0)
!SR_Profit_Center = varData(1)
!SR_Super_Label = varData(2)
!SAP_Profit_Center = varData(3)
!SAP_Super_Label = varData(4)
.Update
End If
.MoveNext
Loop
.Close
End With
Set rs = Nothing
End Sub
Also I'm aware of the extra variable pieces, I will clean it up once I get it working.
File Examples:
Working File:
CE16041901
00791558441123;US1K100017;CGR;US1K100001;UNKNOW
00791558442328;US1K100017;CGR;US1K100001;UNKNOW
00791558440720;US1K100017;CGR;US1K100001;UNKNOW
00791558444629;US1K100017;CGR;US1K100001;UNKNOW
00791558440522;US1K100017;CGR;US1K100001;UNKNOW
00791558443325;US1K100017;CGR;US1K100001;UNKNOW
Not Working File:
CE16042001
00791558334128;US1K100017;CGR;US1K100001;UNKNOW
00791558159523;US1K100017;CGR;US1K100001;UNKNOW
00602547736604;US1A100018;UR;US1A100018;US-RU
I appreciate any help. I ran with this as far as I could, but I am still very much a novice when it comes to access and vb. If you need more information or clarification please let me know and I'll do my best to provide/explain.
No need to touch the staging table functions. Simply conditionally populate the strFileList array depending if Excel workbooks' first sheet contains No Data or empty cell. Recall Access VBA has complete access to all Excel objects via COM interface or Excel VBA reference and so can iteratively open workbooks. Hence, adjust your While/Wend loop accordingly:
Sub Pull_File_into_Staging_Table()
'...same code...
Dim objXL As Object
Dim wb As Object
Set objXL = CreateObject("Excel.Application")
strfile = Dir(Path & "*.xls")
While strfile <> ""
Set wb = objXL.Workbooks.Open(Path & strfile)
If wb.Sheets(1).Range("A1") <> "No Data" AND wb.Sheets(1).Range("A1") <> "" Then
'add files to the list
intFile = intFile + 1
ReDim Preserve strFileList(1 To intFile)
strFileList(intFile) = strfile
End If
strfile = Dir()
wb.Close False
Set wb = Nothing
Wend
'...
I have a large amount of csv files that I need in .xls format. Is it possible to run a batch conversion with a macro or best done with another language?
I have used this code http://www.ozgrid.com/forum/showthread.php?t=71409&p=369573#post369573 to reference my directory but I'm not sure of the command to open each file and save them. Here's what I have:
Sub batchconvertcsvxls()
Dim wb As Workbook
Dim CSVCount As Integer
Dim myVar As String
myVar = FileList("C:\Documents and Settings\alistairw\My Documents\csvxlstest")
For i = LBound(myVar) To UBound(myVar)
With wb
Application.Workbooks.OpenText 'How do I reference the myvar string ?
wb.SaveAs '....
End With
Next
End Sub
Function FileList(fldr As String, Optional fltr As String = "*.*") As Variant
Dim sTemp As String, sHldr As String
If Right$(fldr, 1) <> "\" Then fldr = fldr & "\"
sTemp = Dir(fldr & fltr)
If sTemp = "" Then
FileList = Split("No files found", "|") 'ensures an array is returned
Exit Function
End If
Do
sHldr = Dir
If sHldr = "" Then Exit Do
sTemp = sTemp & "|" & sHldr
Loop
FileList = Split(sTemp, "|")
End Function
Edit: The files are .txt files formatted as csv
By combining the code given by Scott Holtzman and 'ExcelFreak', the conversion works quite well. The final code looks something like this:
Sub CSV_to_XLS()
Dim wb As Workbook
Dim strFile As String, strDir As String
strDir = "U:\path\"
strFile = Dir(strDir & "*.csv")
Do While strFile <> ""
Set wb = Workbooks.Open(Filename:=strDir & strFile, Local:=True)
wb.SaveAs Replace(wb.FullName, ".csv", ".xls"), 50 'UPDATE:
wb.Close True
Set wb = Nothing
strFile = Dir
Loop
End Sub
Opening the converted .xls file throws a warning everytime:
"The file you are trying to open, 'filename', is in a different format than specified by the file extension. Verify that the file is not corrupted and is from a trusted source before opening the file. Do you want to open the file now?"
Clicking Yes then opens the .xls file.
Is there a way to get rid of this warning message? Excel throws a warning everytime the .xls file is opened.
In a lot less lines of code, this should get you what you want. However, I will say this may not be the fastest way to get it done, because you are opening, saving, and closing the workbook every time. I will look for a faster way, but I forget the method off the top of my head.
Sub batchconvertcsvxls()
Dim wb As Workbook
Dim strFile As String, strDir As String
strDir = "C:\"
strFile = Dir(strDir & "*.csv")
Do While strFile <> ""
Set wb = Workbooks.Open(strDir & strFile)
With wb
.SaveAs Replace(wb.FullName, ".csv", ".xls"), 50 'UPDATE:
.Close True
End With
Set wb = Nothing
Loop
End Sub
** UPDATE **
you need the proper fileformat enumeration for a .xls file. I think its 50, but you can check here Excel File Type Enumeration, if it's not.
The Code of Scott Holtzman nearly did it for me. I had to make two changes to get it to work:
He forgot to add the line that makes our loop continue with the next file. The last line before the Loop should read
strFile = Dir
The Workbooks.Open method did not read my CSV files as expected (the whole line ended up to be text in the first cell). When I added the parameter Local:=True it worked:
Set wb = Workbooks.Open(Filename:=strDir & strFile, Local:=True)
This works properly at least on Excel 2013. Using FileFormat:=xlExcel8 parameter instead of the filetype tag 50 creates files that open without security nags.
Sub CSV_to_XLS()
Dim wb As Workbook
Dim strFile As String, strDir As String
strDir = "C:\temp\"
strFile = Dir(strDir & "*.csv")
Do While strFile <> ""
Set wb = Workbooks.Open(Filename:=strDir & strFile, Local:=True)
wb.SaveAs Replace(wb.FullName, ".csv", ".xls"), FileFormat:=xlExcel8
wb.Close True
Set wb = Nothing
strFile = Dir
Loop
End Sub
This was a good question and I have found in the internet several answers. Just making very small changes (I couldn't edit any of the codes already published) I could make things work a bit better:
Sub CSV_to_XLSX()
Dim wb As Workbook
Dim strFile As String, strDir As String
strDir = "C:\Users\acer\OneDrive\Doctorado\Study 1\data\Retest Bkp\Day 1\Sart\"
strFile = Dir(strDir & "*.csv")
Do While strFile <> ""
Set wb = Workbooks.Open(Filename:=strDir & strFile, Local:=True)
With wb
.SaveAs Replace(wb.FullName, ".csv", ".xlsx"), 51
.Close True
End With
Set wb = Nothing
strFile = Dir
Loop
End Sub
I have a front end and back end of an Access database. The front end references linked tables and I need to do a relative link instead of an explicit one i.e. "../database" is referenced instead of "address/database"
Is it possible to do this, or must I specify the absolute path?
Tables linked to files (such as mdb, accdb, dbf, etc.) require absolute paths in their connection strings.
However there is a workaround: during the database startup you can use vba to redefine the the links to match the directory of the current database instance.
(The code below has not been tested / debugged)
Private Sub RelinkTables()
Dim oldConnection As String
Dim newConnection As String
Dim currentPath As String
currentPath = CurrentProject.Path
Dim tblDef As TableDef
For Each tblDef In CurrentDb.TableDefs
oldConnection = tblDef.Connect
' Depending on the type of linked table
' some string manipulation which defines
' newConnection = someFunction(oldConnection,currentPath)
tblDef.Connect = newConnection
tblDef.RefreshLink
Next tblDef
End Sub
I have tried some of the answers above, especially the answer of Martin Thompson which I got some errors with, and thus modified it as follows:
Public Function reLinkTables() As Boolean
On Error GoTo ErrorRoutine
Dim sMyConnectString As String
Dim tdf As TableDef
Dim db_name As String
' The Main Answer is by Martin Thompson
' Modified by Dr. Mohammad Elnesr
'We will link all linked tables to an accdb Access file located in the same folder as this file.
'Replace the DATA file name in the following statement with the name of your DATA file:
sMyConnectString = ";DATABASE=" & CurrentProject.Path & "\"
For Each tdf In CurrentDb.TableDefs
If Len(tdf.Connect) > 0 Then
'It's a linked table, so re-link:
'First, get the database name
db_name = GetFileName(tdf.Connect)
' Then link the table to the current path
tdf.Connect = sMyConnectString & db_name
tdf.RefreshLink
End If
Next tdf
ExitRoutine:
MsgBox "All tables were relinked successfully"
Exit Function
ErrorRoutine:
MsgBox "Error in gbLinkTables: " & Err.Number & ": " & Err.Description
Resume ExitRoutine
End Function
Function GetFileName(FullPath As String) As String
Dim splitList As Variant
splitList = VBA.Split(FullPath, "\")
GetFileName = splitList(UBound(splitList, 1))
End Function
After fininshing this, Goto Access Ribon>Create>Macro From the dropdown select "RunCode", then in the function name type "reLinkTables" which we typed here. Then save the macro with the name "AutoExec". Every time you open the database, all the linked tables will be relinked to the original path. This is very useful if you put your databases in a portable media.
As far as I know, your TableDef's Connect property requires an absolute path. If I'm wrong on that point, I hope someone will tell how to create a linked table using a relative path.
Take a look at Armen Stein's free utility to manage your table links: J Street Access Relinker
Here is a simple routine that worked for me:
Public Function gbLinkTables() As Boolean
On Error GoTo ErrorRoutine
Dim sMyConnectString As String
Dim tdf As TableDef
'We will link all linked tables to an accdb Access file located in the same folder as this file.
'Replace the DATA file name in the following statement with the name of your DATA file:
sMyConnectString = ";database=" & CurrentProject.Path & "\Loan-Tracking-Data.accdb"
For Each tdf In CurrentDb.TableDefs
If Len(tdf.Connect) > 0 Then
'It's a linked table, so re-link:
tdf.Connect = sMyConnectString
tdf.RefreshLink
End If
Next tdf
ExitRoutine:
Exit Function
ErrorRoutine:
MsgBox "Error in gbLinkTables: " & Err.Number & ": " & Err.Description
Resume ExitRoutine
End Function
The following code has been tested in the Form_Load event of the form listed in the "Display Form" option for the database; that is the form that loads whenever the database is opened. This code could also be called from the AutoExec macro for the database:
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
you can make a "calculated" field.. works for me in Office Access 2016
"F:\Komponenten\Datenbank\Bilder\" & [Kategorie] & "\Pinout\" & [Bezeichnung] & ".jpg"
maybe there are better solutions, see images
calculated path
result