I have an Access 2013 database separated into two files - data and code. In the code file, I have an autoexec routine to run the following function:
Function Reconnect()
On Error GoTo ReconnectErr
Dim db As Database, source As String, path As String
Dim dbsource As String, i As Integer, j As Integer
Set db = DBEngine.Workspaces(0).Databases(0)
For i = Len(db.Name) To 1 Step -1
If Mid(db.Name, i, 1) = Chr(92) Then
path = Mid(db.Name, 1, i)
Exit For
End If
Next
For i = 0 To db.TableDefs.Count - 1
If db.TableDefs(i).Connect <> " " Then
source = Mid(db.TableDefs(i).Connect, 11)
For j = Len(source) To 1 Step -1
If Mid(source, j, 1) = Chr(92) Then
dbsource = Mid(source, j + 1, Len(source))
source = Mid(source, 1, j)
If source <> path Then
db.TableDefs(i).Connect = ";Database=" + path + dbsource
db.TableDefs(i).RefreshLink
End If
Debug.Print dbsource, source
Exit For
End If
Next
End If
Next
GoTo ReconnectEnd
ReconnectErr:
MsgBox Err.Number & " " & Err.Description
ReconnectEnd:
End Function
The code works fine until I change the folder name (for instance, from MTDB to MTDB2) When I launch, I get the following error:
"C:\Users...\OLDPATH\MT-Data.accdb is not a valid path. Make sure that the path name is spelled correctly and that you are connected to the server on which the file resides."
Upon clicking OK, that same error occurs for each table object in the database. When the program loads, I get empty recordsets. I quit and relaunch and it works fine.
I suspect that there is a link reference somewhere before autoexec is called that carries the old path information and isn't updated at load time.
The code and data files will always be in the same folder.
Any thoughts on why I'm getting the error message when I change the name of the folder?
I figured this out - if you have directed Access to open the startup form using Options/Current Database/Display Form, it apparently gets processed first in the hierarchy. If you leave the Display Form blank and open it from the autoexec macro, it gets processed after the Reconnect() function gets called.
Related
I used the code provided by Siddharth Rout in the following threat.
Detect whether Excel workbook is already open
My goal was to check if a certain named workbook was open and depending on the result perform certain actions.
This was the result.
Function IsWorkBookOpen(FileName As String)
Dim ff As Long, ErrNo As Long
On Error Resume Next
ff = FreeFile()
Open FileName For Input Lock Read As #ff
Close ff
ErrNo = Err
On Error GoTo 0
Select Case ErrNo
Case 0: IsWorkBookOpen = False
Case 70: IsWorkBookOpen = True
Case Else: Error ErrNo
End Select
End Function
The following piece refers back to the function and depending on the result performs certain actions.
Dim xls As Object
Dim Answer As String
Dim Mynote As String
If IsWorkBookOpen(Environ("USERPROFILE") & "\Desktop\Report.xlsm") =
True Then
Mynote = "The Report is still open. Do you want to save the Report ?"
Answer = MsgBox(Mynote, vbQuestion + vbYesNo, "Warning Report open")
If Answer = vbYes Then
MsgBox "Please Save your Report under a new name and close it. then press update again"
Exit Sub
Else
Set xls = GetObject(Environ("USERPROFILE") & "\Desktop\Report.xlsm")
xls.Close True
End If
Else
End If
This used to work perfectly in the past but since today it suddenly gives me error 53.
While trying to resolve the issue I discovered the error only occurs when the named workbook is not on the desktop. Strangely enough it did not have this issue in the past. I specifically tested that because the file will not always be on the desktop.
I tried several backups tracking back 2 months and even those show the same error now.
While searching the internet for this issue i found this thread,
Check if excel workbook is open?
where they suggest to change the following pieces,
(ErrNo = Err) in to (Errno = Err.Number)
(ff = FreeFile_()) in to (ff = FreeFile)
I did both together and independitly. eventhough i dont really see the relation between the error and Freefile.
This did not change the error at all.
While I am currious to why this error suddenly occurs I really do need a solution or alternative.
what i need it tot do again is,
- Check if named workbook is open.
- when it is open a Msgbox with yes and no option should appear.
- On "No" it should close the named workbook and continue with whatever is below of what i posted.
- On yes it should pop a message box and stop.
Any help that can be provided will be highly appreciated.
You need to check if the file exists before checking if it is open;
Function FileExists(ByVal strFile As String, Optional bFindFolders As Boolean) As Boolean
'Purpose: Return True if the file exists, even if it is hidden.
'Arguments: strFile: File name to look for. Current directory searched if no path included.
' bFindFolders. If strFile is a folder, FileExists() returns False unless this argument is True.
'Note: Does not look inside subdirectories for the file.
'Author: Allen Browne. http://allenbrowne.com June, 2006.
Dim lngAttributes As Long
'Include read-only files, hidden files, system files.
lngAttributes = (vbReadOnly Or vbHidden Or vbSystem)
If bFindFolders Then
lngAttributes = (lngAttributes Or vbDirectory) 'Include folders as well.
Else
'Strip any trailing slash, so Dir does not look inside the folder.
Do While Right$(strFile, 1) = "\"
strFile = Left$(strFile, Len(strFile) - 1)
Loop
End If
'If Dir() returns something, the file exists.
On Error Resume Next
FileExists = (Len(Dir(strFile, lngAttributes)) > 0)
End Function
I'm trying to implement a certain feature in the Microsoft Access Database using VBA, so when a certain button is pressed, it will check first the availability of the folder in a server. If the folder doesn't exist, the corresponding folder will be created. However, the folders have permissions attached to them, which means only certain users can access it, and hence only certain users should create / access the folder. I have tried the following:
on error resume next
If Dir("Server/Data/Celes", vbDirectory) = "Celes" Then
Else
MkDir ("Server/Data/Celes")
End If
But I'm not sure if it's the best way to handle this problem. I use the "On Error Resume Next", so that if the error occurs due to the lack of permission to the folder (that already exists), it will ignore it. What are some better ways to handle this? Thank you.
I also have checked the following links:
https://social.msdn.microsoft.com/Forums/office/en-US/a79054cb-52cf-48fd-955b-aa38fd18dc1f/vba-verify-if-user-has-permission-to-directory-before-saveas-attempt?forum=exceldev
Check Folder Permissions Before Save VBA
but both of them concerns with saving the file, not creating folder.
After several days without success, finally I found the solution:
Private function canAccess(path as string) as boolean
Dim oShell As Object
Set oShell = CreateObject("WScript.Shell")
Dim result As Integer
Dim command As String
command = "icacls " & """" & pfad & """"
result = oShell.Run(command, 0, True)
'Check privilege; file can be accessed if error code is 0.
'Else, errors are encountered, and error code > 0.
If result <> 5 and result <> 6 Then
KannAufDateiZugreifen = True
Else
KannAufDateiZugreifen = False
End If
end function
private sub button_click()
if canAccess ("Server/Data/Celes") then
If Dir("Server/Data/Celes", vbDirectory) = "Celes" Then
Else
MkDir ("Server/Data/Celes")
end if
End If
end sub
The function "canAccess" will simulate the running of the Windows shell, and execute "icacls" to see if the file can be accessed or not. If the function returns true, it means the "icacls" command is successful, which means the folder can be accessed. Otherwise, the file / folder can not be accessed.
I'm pretty sure this can be improved, but for now, it works.
I use the below function that recursively creates the full path (if required) and returns a value indicating success or failure. It works also with UNCs.
Private Function CreateFolder(ByVal sPath As String) As Boolean
'by Patrick Honorez - www.idevlop.com
'checks for existence of a folder and create it at once, if required
'returns False if folder does not exist and could NOT be created, True otherwise
'sample usage: If CreateFolder("C:\toto\test\test") Then debug.print "OK"
'updated 20130422 to handle UNC paths correctly ("\\MyServer\MyShare\MyFolder")
Dim fs As Object
Dim FolderArray
Dim Folder As String, i As Integer, sShare As String
If Right(sPath, 1) = "\" Then sPath = Left(sPath, Len(sPath) - 1)
Set fs = CreateObject("Scripting.FileSystemObject")
'UNC path ? change 3 "\" into 3 "#"
If sPath Like "\\*\*" Then
sPath = Replace(sPath, "\", "#", 1, 3)
End If
'now split
FolderArray = Split(sPath, "\")
'then set back the # into \ in item 0 of array
FolderArray(0) = Replace(FolderArray(0), "#", "\", 1, 3)
On Error GoTo hell
'start from root to end, creating what needs to be
For i = 0 To UBound(FolderArray) Step 1
Folder = Folder & FolderArray(i) & "\"
If Not fs.FolderExists(Folder) Then
fs.CreateFolder (Folder)
End If
Next
CreateFolder = True
hell:
End Function
'Must set a Reference to the Microsoft Scripting Runtime
Dim fso As FileSystemObject
Dim fil As File
Set fso = New Scripting.FileSystemObject
If fso.FileExists("\\serverName\folderName\fileName.txt") Then
'code execution here
Else
MsgBox "File and/or Path cannot be found", vbCritical, "File Not Found"
End If
I want to fill a textbox with a file path so that I can then add the filepath as a hyperlink in a record.
I created a button and wrote this subroutine:
Private Sub Browsebutt_Click()
Dim fd As Object
Set fd = Application.FileDialog(3) 'msoFileDialogFilePicker
With fd
.Filters.Clear
.InitialFileName = CurrentProject.Path & "\"
.Title = "Select File"
.AllowMultiSelect = False
.ButtonName = "Select"
.Filters.Add "All Files (*.*)", "*.*"
'.InitialView = msoFileDialogViewList'
If .Show Then
Me.Offlink = .SelectedItems(1)
Else
Exit Sub
End If
End With
Everything looks fine but the issue is when I browse to something stored in my company NAS. The path looks like this:
Z:\Folder1\File
It doesn't work on click, if instead of this I use the drag and drop function directly into the access table (not in the form) I obtain something like this:
\192.168.0.155\archive\Folder1\File
and it actually works, when I click on the link it opens my file.
So I was wondering if there is a way to have the file picker to provide the path with full ip.
Answering this will require some steps, and might depend slightly on your setup:
You can't change the file picker behaviour a lot, so I'm going to change out the drive letter for the UNC path. Depending on how your drive is mapped, it will either return a server name (such as \\MyServer or \\www.AnUrl.tld), or an IP address
First, I'm going to use a couple of helper functions I found here and adapted to use late bindings and increase usability.
Helper 1: Input: a full path. Output: the drive letter from that path
Public Function ParseDriveLetter(ByVal path As String) As String
'Get drive letter from path
ParseDriveLetter = vbNullString
On Error GoTo err_ParseDriveLetter
Dim oFileSystem As Object ' Scripting.FileSystemObject
Set oFileSystem = CreateObject("Scripting.FileSystemObject")
Dim oFolder As Object 'Scripting.Folder
' Next line throws error if mapping not available
Set oFolder = oFileSystem.GetFolder(path)
If (oFolder Is Nothing) Then
Debug.Print "ParseDriveLetter: Folder '" & path & "' is invalid"
Else
ParseDriveLetter = oFileSystem.GetDriveName(oFolder.path)
End If
Set oFolder = Nothing
Set oFileSystem = Nothing
Exit Function
err_ParseDriveLetter:
Select Case Err.Number
Case 76:
' Path not found -- invalid drive letter or letter not mapped
Case Else
MsgBox "Error no. " & CStr(Err.Number) & ": " & Err.Description & vbNewLine & _
"Was caused by " & Err.Source, vbOKOnly Or vbExclamation, "Error in function ParseDriveLetter"
End Select
End Function
Helper 2: Input: a drive letter from a mapped network drive. Output: the location the drive is mapped to
Public Function GetMappedPathFromDrive(ByVal drive As String) As String
Dim oWshNetwork As Object 'New WshNetwork
Dim oDrives As Object 'New WshCollection
Set oWshNetwork = CreateObject("WScript.Network")
' The EnumNetworkDrives method returns a collection.
' This collection is an array that associates pairs of items ? network drive local names and their associated UNC names.
' Even-numbered items in the collection represent local names of logical drives.
' Odd-numbered items represent the associated UNC share names.
' The first item in the collection is at index zero (0)
Set oDrives = oWshNetwork.EnumNetworkDrives
Dim i As Integer
For i = 0 To oDrives.Count - 1 Step 2
' Drive is oDrives.Item(i), UNC is oDrives.Item(i + 1)
If (0 = StrComp(drive, oDrives.Item(i), vbTextCompare)) Then
' We have matched the drive letter. Copy the UNC path and finish
GetMappedPathFromDrive = oDrives.Item(i + 1)
Exit For
End If
Next
Set oDrives = Nothing
Set oWshNetwork = Nothing
End Function
And now, the implementation in your code:
Me.Offlink = Replace(.SelectedItems(1), ParseDriveLetter(.SelectedItems(1)), GetMappedPathFromDrive(ParseDriveLetter(.SelectedItems(1))))
Note that if this returns the server name instead of the IP address, you can use the post #June7 referred to to get the IP address.
I have designed a system that is used to track customer activity and log calls to a department. The front end and back end database are written in access. This system is due to go to the USA division of the company i work for.
The front end needs to automatically refresh the tables and if the backend database has moved (which it will when i send it to the US) the code will then look at a function to read the location of the new database. Sample of the read text file function code shown below:
Function ReadDbPassword()
'--
' Filetostring(FILEInput$ as variant) ' to make this a callable function
Dim FILEInput As Variant
'--
On Error GoTo FileToString_Error
FILEInput = "C:\Users\Public\databaseUser\PassCon"
Passmyfile = FreeFile
Open FILEInput For Input As Passmyfile
Passthedata4 = Input(LOF(Passmyfile), Passmyfile)
Close Passmyfile
On Error GoTo 0
Exit Function
FileToString_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
End Function
The text file contains a path like the one below:
P:\Projects\Database.accdb
I have found code that uses a similar idea to what i want and i have been looking at the code on the link below, however i do not fully understand how this code works in order to alter it to what I need to use the read text file.
http:/ /access.mvps.org/access/tables/tbl0009.htm
-------EDIT --------
I have tried to edit the following section to use the read text function
Function fGetMDBName(strIn As String) As String
'Calls GetOpenFileName dialog
Dim strFilter As String
strFilter = ahtAddFilterItem(strFilter, _
"Access Database(*.mdb;*.mda;*.mde;*.mdw) ", _
"*.mdb; *.mda; *.mde; *.mdw")
strFilter = ahtAddFilterItem(strFilter, _
"All Files (*.*)", _
"*.*")
fGetMDBName = ahtCommonFileOpenSave(Filter:=strFilter, _
OpenFile:=True, _
DialogTitle:=strIn, _
Flags:=ahtOFN_HIDEREADONLY)
End Function
By replacing all the code with
fGetMDBName = Passmyfile
You are mixing apples and oranges in what you are trying to do. Here are my suggestions:
Make sure your module has 'Option Explicit' then compile all your code. I see variables referenced but have no idea what TYPE they are.
Change your Function 'ReadDbPassword()' to return a string variable, then set it to return Passthedata4.
The second Function you listed (fGetMDBName) is opening a File Dialog box to allow you to select a file name. You do not need that since you already will have the file path/name from your first Function.
Then adapt the code you found that does the relink to use the path/name from your subroutine.
I am trying to create a button on my access form that allows for the user to view the corresponding page that goes with the data within the form (In this case, a part number is displayed on the form, and I want the button to open the Part Standard file to show the blueprint/diagram of said part)
I have tried using Adobe's page parameters #page=pagenum at the end of my filepath, but doing this doesn't work.
Here is the code I have (Basic, I know) but I'm trying to figure out where to go here. I have simple condensed down my filepath, for obvious reasons - Note: It's not a URL, but a file path if this matters.
Private Sub Command80_Click()
Dim loc As String 'location of file
'loc = Me.FileLoc
loc = "G:\*\FileName.pdf#page=1"
Debug.Print loc
'Debug.Print Me.FileLoc
'Debug.Print Me.FileName
Application.FollowHyperlink loc
End Sub
Is this possible to do this way? I will continue to read other users posts in hopes to find a solution, and I'll note here if I do find one.
Thanks!
Update
I've found a way to do this, just I have 1 small complication now. My database will be accessed by many users, possibly with different versions of Acrobat, or different locations. Here is my working code:
Private Sub Command2_Click()
pat1 = """C:\Program Files\Adobe\Reader 9.0\Reader\AcroRd32.exe"""
pat2 = "/A ""page=20"""
pat3 = """G:\*\FileName.pdf"""
Shell pat1 & " " & pat2 & " " & pat3, vbNormalFocus
End Sub
Now, here is my concern. This code opens AcroRd32.exe from a specific file path, if my users have this stored elsewhere or have a different version, this won't work. Does anyone have a suggestion as how to possibly get around this?
Thanks again! :)
The correct way to do this is probably to look up the location of the acrobat reader executable in the system registry. I find that's generally more trouble than it's worth, especially if I have some control over all of the places my program will be installed (within a single intranet, for example). Usually I end up using this function that I wrote:
'---------------------------------------------------------------------------------------
' Procedure : FirstValidPath
' Author : Mike
' Date : 5/23/2008
' Purpose : Returns the first valid path found in a list of potential paths.
' Usage : Useful for locating files or folders that may be in different locations
' on different users' computers.
' Notes - Directories must be passed with a trailing "\" otherwise the function
' will assume it is looking for a file with no extension.
' - Returns Null if no valid path is found.
' 5/6/11 : Accept Null parameters. If all parameters are Null, Null is returned.
'---------------------------------------------------------------------------------------
'
Function FirstValidPath(ParamArray Paths() As Variant) As Variant
Dim i As Integer
FirstValidPath = Null
If UBound(Paths) - LBound(Paths) >= 0 Then
For i = LBound(Paths) To UBound(Paths)
If Not IsNull(Paths(i)) Then
If Len(Dir(Paths(i))) > 0 Then
FirstValidPath = Paths(i)
Exit For
End If
End If
Next i
End If
End Function
The function takes a parameter array so you can pass it as many or as few paths as necessary:
PathToUse = FirstValidPath("C:\Program Files\Adobe\Reader 9.0\Reader\AcroRd32.exe", _
"C:\Program Files\Acrobat\Reader.exe", _
"C:\Program Files (x86)\Acrobat\Reader.exe", _
"C:\Program Files\Acrobat\12\Reader.exe")
pat1 = """" & PathToUse & """"
Registry keys are the better way to go, unlike file locations they have consistency between systems.
Below are three functions, two in support of one, and a macro which tests the functions.
GetARE() (Get Adobe Reader Executable) returns the proper path based on a version search in a pre-defined location passed as the argument. This removes the hassle of typing out many different key locations for each version and provides some amount of coverage should future versions be released and installed on a user's system.
I have installed previous versions of Reader to test whether or not the there is consistency in the InstallPath key location, up until quite outdated versions, there is. In fact, mwolfe02 and I both have our keys in the same location, though I am using version 11 and he, at the time of writing, was using 10. I was only able to test this on a x64 system, but you can easily modify the code below to search for both x64 and x86 keys. I expect a large corporation like Adobe to stick to their conventions, so this will likely work for quite some time without much modification even as new versions of Reader are released.
I wrote this quickly, expect inefficiency and inconsistency in naming conventions.
Truly the best approach to ensure the path is almost-always returned would be to simply run a registry search through VBA in a loop for version numbers using "*/Acrobat Reader/XX.YY/InstallPath/" and then including the executable based on a check for the appropriate candidate in the appropriate directory; however, this isn't exactly a very cost-effective solution. My tests have shown that there is quite a bit of consistency between versions as to where the Install Path can be found, and as to what the executable name may be, so I opted for something more efficient if less lasting.
RegKeyRead() and RegKeyExists() were taken from:
http://vba-corner.livejournal.com/3054.html
I have not modified their code. Take into consideration saying thanks to the author of that post, the code is not complex by any means but it did save me the hassle of writing it myself.
Function RegKeyRead(i_RegKey As String) As String
Dim myWS As Object
On Error Resume Next
'access Windows scripting
Set myWS = CreateObject("WScript.Shell")
'read key from registry
RegKeyRead = myWS.RegRead(i_RegKey)
End Function
Function RegKeyExists(i_RegKey As String) As Boolean
Dim myWS As Object
On Error GoTo ErrorHandler
'access Windows scripting
Set myWS = CreateObject("WScript.Shell")
'try to read the registry key
myWS.RegRead i_RegKey
'key was found
RegKeyExists = True
Exit Function
ErrorHandler:
'key was not found
RegKeyExists = False
End Function
Function GetARE(i_RegKey As String) As String
Dim InPath As String
Dim InKey As String
Dim Ind As Integer
Dim PriVer As String
Dim SubVer As String
Dim Exists As Boolean
Exists = False
PriVer = 1
SubVer = 0
For Ind = 1 To 1000
If SubVer > 9 Then
PriVer = PriVer + 1
SubVer = 0
End If
Exists = RegKeyExists(i_RegKey + "\" + PriVer + "." + SubVer + "\InstallPath\")
SubVer = SubVer + 1
If Exists = True Then
SubVer = SubVer - 1
InKey = i_RegKey + "\" + PriVer + "." + SubVer + "\InstallPath\"
InPath = RegKeyRead(InKey)
GetARE = InPath + "\AcroRd32.exe"
Exit For
End If
Next
End Function
Sub test()
Dim rando As String
rando = GetARIP("HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Adobe\Acrobat Reader")
MsgBox (rando)
End Sub
I remember that Acrobat reader used to include some ActiveX PDF reader object available for further use with Microsoft Office. Other companies have developed similar products, some of them (in their basic form) even available for free.
That could be a solution, couldn't it? You'd have then to check that your activeX PDF reader supports direct page access in its methods, and distribute it with your apps, or have it installed on your user's computers. It will avoid you all the overhead related to acrobat readers versions follow-up, specially when newer versions will be available on the market and you'll have to update your client interface.
Just to add to mwolfe02's answer, here is a function that tries to retrieve the executable for the file type given (it also uses the registry commands Levy referenced) :
Function GetShellFileCommand(FileType As String, Optional Command As String)
Const KEY_ROOT As String = "HKEY_CLASSES_ROOT\"
Dim sKey As String, sProgramClass As String
' All File Extensions should start with a "."
If Left(FileType, 1) <> "." Then FileType = "." & FileType
' Check if the File Extension Key exists and Read the default string value
sKey = KEY_ROOT & FileType & "\"
If RegKeyExists(sKey) Then
sProgramClass = RegKeyRead(sKey)
sKey = KEY_ROOT & sProgramClass & "\shell\"
If RegKeyExists(sKey) Then
' If no command was passed, check the "shell" default string value, for a default command
If Command = vbNullString Then Command = RegKeyRead(sKey)
' If no Default command was found, default to "Open"
If Command = vbNullString Then Command = "Open"
' Check for the command
If RegKeyExists(sKey & Command & "\command\") Then GetShellFileCommand = RegKeyRead(sKey & Command & "\command\")
End If
End If
End Function
so,
Debug.Print GetShellFileEx("PDF")
outputs:
"C:\Program Files (x86)\Adobe\Reader 11.0\Reader\AcroRd32.exe" "%1"
and you just have to replace the "%1" with the file you want to open and add any parameters you need.
Here is code the probably you can use..
Private Sub CommandButton3_Click()
Dim strFile As String
R = 0
If TextBox7 = "CL" Then
R = 2
' Path and filename of PDF file
strFile = "E:\Users\Test\Cupertino Current system.pdf"
ActiveWorkbook.FollowHyperlink strFile
End If
if R = 0 Then
MsgBox "Wrong Code"
ComboBox1 = ""
TextBox1 = Empty
'ComboBox1.SetFocus
End If
End Sub
Just need to the right path.. Hope this can help you