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.
Related
I have a code to create folder or open folder if exist which works completely fine.
Now my only problem is that there can be 3 users of this database and the 3 users has individual parent folder path. They all use and share all the folders in the parent folder and has the same parent folder name, only the path is different for the parent folder.
My existing code as follows:
Private Sub Command299_Click()
Const strParent = "C:\Users\xxx\xxx\Jobs\"
Dim strJobID As String
Dim strClient As String
Dim strFolder As String
Dim fso As Object
' Create FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")
' Get year from control - modify as needed
strClient = "(" & Me.[Client ID] & ") " & [Client Name]
' Path with year
strFolder = strParent & strClient
' Check whether folder exists
If fso.FolderExists(strFolder) = False Then
' If not, create it
fso.CreateFolder strFolder
End If
' Get student ID from control
strJobID = Me.[Job ID] & " " & [Job name]
' Full path
strFolder = strFolder & "\" & strJobID
' Check whether folder exists
If fso.FolderExists(strFolder) = False Then
' If not, create it
fso.CreateFolder strFolder
End If
' Open it
Shell "explorer.exe " & strFolder, vbNormalFocus
End Sub
As I said it does work completely fine on my computer where the const parent folder path is what is in the code, but how can I make this code work for different path?
My 1st idea was to give an "or" statement in the Const line
Const strParent = "C:\Users\xxx\xxx\Jobs\"
But it didn't want to work. Is there any way to give 3 constant path for the parent folder and if one of them exists, work from there?
Thank you for any help!
Lots of options:
If you have a file server, move the files there and use \\servername\share
If you don't have a file server, have one user share the folder and on all 3 computers, connect to the shared drive using the same letter then use that path for access.
if neither of those appeal to you, create a users table in your database with two fields, username and path. Use the Environ("USERNAME") to get the username (as above) and put the path they need in another column. lookup with
Path = DLookup("fieldUserPath", "tblUsers", "fieldUsername = '" & Environ("USERNAME") & "'")
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'm writing a VBA code to add files, which are into several folders, into a ZIP file.
This procedure should run automatically, by a scheduled job, and I try to add a parameter to force "yes to all".
In Microsoft support there are some constants but if I add to my code, I don't have the aspected result.
the code is the following
Public Sub ZipFolder(ZipFileName As Variant, _
FolderPath As Variant, _
Optional ByVal FileFilter As String, _
Optional ByVal Overwrite As Boolean = False)
Dim fso As Object, tf As Object
Dim strZIPHeader As String, sFile As String
On Error GoTo done
' create zip file header
strZIPHeader = Chr(80) & Chr(75) & Chr(5) & Chr(6) & String(18, Chr(0))
With CreateObject("Shell.Application")
sFile = Dir(FolderPath, vbNormal)
Do Until sFile = vbNullString
.Namespace(ZipFileName).CopyHere FolderPath & sFile, **"&H10&"**
sFile = Dir
Loop
End With
Set fso = Nothing
Set tf = Nothing
done:
If Err.Number <> 0 Then MsgBox Err.Description, vbApplicationModal + vbInformation
End Sub
The parameter &H10& doesn't work. I have tried with "&0X14&" as well but same result.
Any idea?
Thank you
You can study the article and full code here on exactly this subject:
Zip and unzip files and folders with VBA the Windows Explorer way
You'll see, that shall the file be overwritten, it is simply deleted before proceeding:
If FileSystemObject.FileExists(ZipFile) Then
If Overwrite = True Then
' Delete an existing file.
FileSystemObject.DeleteFile ZipFile, True
' At this point either the file is deleted or an error is raised.
Else
ZipBase = FileSystemObject.GetBaseName(ZipFile)
' Modify name of the zip file to be created to preserve an existing file:
' "Example.zip" -> "Example (2).zip", etc.
Version = Version + 1
Do
Version = Version + 1
ZipFile = FileSystemObject.BuildPath(ZipPath, ZipBase & Format(Version, " \(0\)") & ZipExtension)
Loop Until FileSystemObject.FileExists(ZipFile) = False Or Version > MaxZipVersion
If Version > MaxZipVersion Then
' Give up.
Err.Raise ErrorPathFile, "Zip Create", "File could not be created."
End If
End If
End If
I have a word document that uses mail merge feature and gets its information from the access db. When I use this code it does not open the word document with the current information. It opens the word document with the last saved information.
If I open the word document on its own, from the task bar, it asks if I want to run the SQL and I click yes and everything operates normally. I want to click a button from within access to accomplish this same task to open the contract.
Here is the code I used:
Private Sub Command205_Click()
Dim LWordDoc As String
Dim oApp As Object
'Path to the word document
LWordDoc = "C:\Users\.....k Up\01- Proposal\contract.docx"
If Dir(LWordDoc) = "" Then
MsgBox "Document not found."
Else
'Create an instance of MS Word
Set oApp = CreateObject(Class:="Word.Application")
oApp.Visible = True
'Open the Document
oApp.Documents.Open FileName:=LWordDoc
End If
End Sub
***I should add that I am not a coder and know nothing about VBA, I copied this from this website so any help you can offer would be greatly appreciated. If you can provide me with coding or enough guidance to get me on the way would be great. Thank you
This code will run in Access to open a Mail Merge document and update content and save.
Using the link I originally posted (http://www.minnesotaithub.com/2015/11/automatic-mail-merge-with-vba-and-access/), I made a couple of modifications and was able to get that code to work.
I needed to add: ReadOnly:=True, _ to prevent a sharing violation
and I changed the Table Name of the source data.
NOTE!! You will need to change sode marked with'###' as follows:
###-1 Change to specify the full path of your TEMPLATE!!!
###-2 Change the SQLSTATEMENT to specify your recordsource!!!
Paste this code into your form, make sure you have a Command Button Click Event that executes (Either rename 'Command205' in this code, or change your control name).
Option Compare Database
Option Explicit
Private Sub Command205_Click()
Dim strWordDoc As String
'Path to the word document of the Mail Merge
'###-1 CHANGE THE FOLLOWING LINE TO POINT TO YOUR DOCUMENT!!
strWordDoc = "C:\Users\.....k Up\01- Proposal\contract.docx"
' Call the code to merge the latest info
startMerge strWordDoc
End Sub
'----------------------------------------------------
' Auto Mail Merge With VBA and Access (Early Binding)
'----------------------------------------------------
' NOTE: To use this code, you must reference
' The Microsoft Word 14.0 (or current version)
' Object Library by clicking menu Tools > References
' Check the box for:
' Microsoft Word 14.0 Object Library in Word 2010
' Microsoft Word 15.0 Object Library in Word 2013
' Click OK
'----------------------------------------------------
Function startMerge(strDocPath As String)
Dim oWord As Word.Application
Dim oWdoc As Word.Document
Dim wdInputName As String
Dim wdOutputName As String
Dim outFileName As String
' Set Template Path
wdInputName = strDocPath ' was CurrentProject.Path & "\mail_merge.docx"
' Create unique save filename with minutes and seconds to prevent overwrite
outFileName = "MailMergeFile_" & Format(Now(), "yyyymmddmms")
' Output File Path w/outFileName
wdOutputName = CurrentProject.Path & "\" & outFileName
Set oWord = New Word.Application
Set oWdoc = oWord.Documents.Open(wdInputName)
' Start mail merge
'###-2 CHANGE THE SQLSTATEMENT AS NEEDED
With oWdoc.MailMerge
.MainDocumentType = wdFormLetters
.OpenDataSource _
Name:=CurrentProject.FullName, _
ReadOnly:=True, _
AddToRecentFiles:=False, _
LinkToSource:=True, _
Connection:="QUERY mailmerge", _
SQLStatement:="SELECT * FROM [tblEmployee]" ' Change the table name or your query
.Destination = wdSendToNewDocument
.Execute Pause:=False
End With
' Hide Word During Merge
oWord.Visible = False
' Save file as PDF
' Uncomment the line below and comment out
' the line below "Save file as Word Document"
'------------------------------------------------
'oWord.ActiveDocument.SaveAs2 wdOutputName & ".pdf", 17
' Save file as Word Document
' ###-3 IF YOU DON'T WANT TO SAVE AS A NEW NAME, COMMENT OUT NEXT LINE
oWord.ActiveDocument.SaveAs2 wdOutputName & ".docx", 16
' SHOW THE DOCUMENT
oWord.Visible = True
' Close the template file
If oWord.Documents(1).FullName = strDocPath Then
oWord.Documents(1).Close savechanges:=False
ElseIf oWord.Documents(2).FullName = strDocPath Then
oWord.Documents(2).Close savechanges:=False
Else
MsgBox "Well, this should never happen! Only expected two documents to be open"
End If
' Quit Word to Save Memory
'oWord.Quit savechanges:=False
' Clean up memory
'------------------------------------------------
Set oWord = Nothing
Set oWdoc = Nothing
End Function
Is there a way in Access to search for a certain text in object properties and so on? Just not only in the VBA source code.
I'm asking this because if I change for example the name of a field in a table I've to check a lot of object properties (Record Source, Control Source, Order By, ...). This can be done by trail-and-error or by checking all properties of each control of the forms, but that takes a lot of time.
One option is the Find and Replace tool (nice tool!), but it's a bit of overkill for me. I don't need a text replace (only 'find') and it's 37 dollar for a tool I'll only use a few times a year.
Other suggestions?
There is something I often use to find out where some function or query may be hidding somewhere unexpected (in a bound control's RowSource of within a sub-query for instance).
I use an undocumented feature to export all Access objects as raw text files.
Using a text editor that can search within files recursively under a folder(like the free Notepad++ for instance) I am then confident that I find all occurrences, however buried, of a particular string.
The Code for exporting all objects includes my IsBlank() function:
'====================================================================
' Name: DocDatabase
' Purpose: Documents the database to a series of text files
' From: http://www.datastrat.com/Code/DocDatabase.txt
' Author: Arvin Meyer
' Date: June 02, 1999
' Comment: Uses the undocumented [Application.SaveAsText] syntax
' To reload use the syntax [Application.LoadFromText]
' Modified to set a reference to DAO 8/22/2005
' Modified by Renaud Bompuis to export Queries as proper SQL
'====================================================================
Public Sub DocDatabase(Optional path As Variant = Null)
If IsBlank(path) Then
path = Application.CurrentProject.path & "\" & Application.CurrentProject.Name & " - exploded view\"
End If
On Error Resume Next
MkDir path
MkDir path & "\Forms\"
MkDir path & "\Queries\"
MkDir path & "\Queries(SQL)\"
MkDir path & "\Reports\"
MkDir path & "\Modules\"
MkDir path & "\Scripts\"
On Error GoTo Err_DocDatabase
Dim dbs As DAO.Database
Dim cnt As DAO.Container
Dim doc As DAO.Document
Dim i As Integer
Set dbs = CurrentDb() ' use CurrentDb() to refresh Collections
Set cnt = dbs.Containers("Forms")
For Each doc In cnt.Documents
Application.SaveAsText acForm, doc.Name, path & "\Forms\" & doc.Name & ".txt"
Next doc
Set cnt = dbs.Containers("Reports")
For Each doc In cnt.Documents
Application.SaveAsText acReport, doc.Name, path & "\Reports\" & doc.Name & ".txt"
Next doc
Set cnt = dbs.Containers("Scripts")
For Each doc In cnt.Documents
Application.SaveAsText acMacro, doc.Name, path & "\Scripts\" & doc.Name & ".txt"
Next doc
Set cnt = dbs.Containers("Modules")
For Each doc In cnt.Documents
Application.SaveAsText acModule, doc.Name, path & "\Modules\" & doc.Name & ".txt"
Next doc
Dim intfile As Long
Dim filename as String
For i = 0 To dbs.QueryDefs.count - 1
Application.SaveAsText acQuery, dbs.QueryDefs(i).Name, path & "\Queries\" & dbs.QueryDefs(i).Name & ".txt"
filename = path & "\Queries(SQL)\" & dbs.QueryDefs(i).Name & ".txt"
intfile = FreeFile()
Open filename For Output As #intfile
Print #intfile, dbs.QueryDefs(i).sql
Close #intfile
Next i
Set doc = Nothing
Set cnt = Nothing
Set dbs = Nothing
Exit_DocDatabase:
Debug.Print "Done."
Exit Sub
Err_DocDatabase:
Select Case Err
Case Else
MsgBox Err.Description
Resume Exit_DocDatabase
End Select
End Sub
To use it, just call DocDatabase from the Immediate window in the Access IDE, it will create a set of directories under and 'Exploded View' folder that will contain all the files.
Another option is to temporarily turn on the NAME AUTOCORRECT option. It's a badly implemented feature and can damage your database if left on for production deployment, but I very often use it when taking over an Access app created by somebody else in order convert it to use my naming conventions.
You basically turn it on, let it build the dependencies table, then make your changes. You can then walk the tree of dependencies to confirm that it got them all. When you're done, you turn it off.
However, it doesn't work for VBA code. But for changing field names and the like, it's pretty useful if used carefully.
I amended the code above to strip out temporary objects with "~" in the object name as follows:
Set cnt = dbs.Containers("Scripts")
For Each doc In cnt.Documents
If Not doc.Name Like "~*" Then
Application.SaveAsText acMacro, doc.Name, path & "\Scripts\" & doc.Name & ".txt"
End If
Next doc