I'm looking for some advice on Microsoft Access VBA - Basically, I have been asked to create a button on a form, upon this button being clicked it will display a box asking for a folder name (I can manually type in, then click 'Ok') which will then create a subfolder in a public folder within Outlook/Exchange 2013.
Any information / advice on this would be fantastic. I have tried some examples on the Internet but my VBA knowledge doesn't allow me to amend the code for my needs.
No doubt this code can be tidied up. It will create a folder called 'New One' within the Inbox.
You'll need to update the code to point to the correct folder and ask for the new name.
Sub CreateFolder()
Dim oOutlook As Object 'Outlook.Application
Dim nNameSpace As Object 'Outlook.Namespace
Dim oFolder As Object
Dim sFolder As String
sFolder = "Mailbox - Bill Gates\Inbox"
Set oOutlook = CreateObject("Outlook.Application")
Set nNameSpace = oOutlook.GetNameSpace("MAPI")
Set oFolder = GetFolderPath(sFolder)
oFolder.Folders.Add "New One" 'Add the 'New One' folder to the Inbox.
End Sub
'----------------------------------------------------------------------------------
' Procedure : GetFolderPath
' Author : Diane Poremsky
' Date : 09/06/2015
' Original : http://www.slipstick.com/developer/working-vba-nondefault-outlook-folders/
' Purpose :
'-----------------------------------------------------------------------------------
Function GetFolderPath(ByVal FolderPath As String) As Object 'Outlook.Folder
Dim oOutlook As Object 'Outlook.Application
Dim nNameSpace As Object 'Outlook.Namespace
Dim oFolder As Object 'Outlook.Folder
Dim FoldersArray As Variant
Dim i As Integer
On Error GoTo GetFolderPath_Error
Set oOutlook = CreateObject("Outlook.Application")
If Left(FolderPath, 2) = "\\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If
FoldersArray = Split(FolderPath, "\")
Set oFolder = oOutlook.Session.Folders.Item(FoldersArray(0))
If Not oFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As Object
Set SubFolders = oFolder.Folders
Set oFolder = SubFolders.Item(FoldersArray(i))
If oFolder Is Nothing Then
Set GetFolderPath = Nothing
End If
Next
End If
Set GetFolderPath = oFolder
Exit Function
GetFolderPath_Error:
Set GetFolderPath = Nothing
Exit Function
End Function
Use the Shell command in VBA. You can execute DOS commands to make folders.
https://msdn.microsoft.com/en-us/library/office/gg278437%28v=office.15%29.aspx
Related
Thank you for taking the time to read this.
I am trying to use the LIKE operator to open workbooks. Previously I went with this code which works really well
Report_Name = "\XYZ.xls"
Workbooks.open Filename:= ThisWorkbook.Path & Report_Name
My main goal is to essentially open a report and sometimes the names differ i.e healthdoc or healthassess
I tried utilizing the LIKE operator to pick up on the name of the workbook however I cannot find a way to code it.
Any direction or help is appreciated. Thank you!
I was trying to use this syntax
Dim Report_Name as Workbook
if Report_Name LIKE "*Health*" then
xyz
else
xyz
However I could only get LIKE operator working only with strings
Use FSO to loop through files and check their names:
Option Explicit
Sub Example()
Dim WB As Workbook
Dim FSO As New FileSystemObject
Dim oFolder As Object
Dim oFile As Object
Set FSO = CreateObject("Scripting.filesystemobject")
Set oFolder = FSO.GetFolder("C:\Users\cameron\Documents")
For Each oFile In oFolder.Files
If oFile.Name Like "*Your Partial File Name*" Then
Set WB = Workbooks.Open(oFile.Path)
'Do whatever you want with your workbook.
WB.Close '(Optional True/False for save changes)
End If
Next oFile
End Sub
Here are 2 sub that I can suggest. Since I don't understand from your question if you want to loop, open and modify the files in a folder, or you want simply to check the files names in a folder, I made 2 sub. One "LoopFilesNamesInFolder" will loop to check the file names without opening the files, and second one "LoopAndOpenFilesInFolder" allows you to open and make changes if you want to the files. You can use any of them based on your needs. Let me know if it helps you
Public Sub LoopFilesNamesInFolder()
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim MyFileName As String
myPath = ThisWorkbook.Path & "\"
'The file name that you are looking for
MyFileName = "*Health*"
myExtension = "*.xls*"
'Current File in loop
myFile = Dir(myPath & myExtension)
Do While myFile <> vbNullString
If myFile Like MyFileName Then
'You can also use something like
'If LCase(myFile) Like LCase(MyFileName) Then
'If you want to make it not case sensitive
'Your code
Else
'Your code
End If
'Get next file name
myFile = Dir
Loop
End Sub
Public Sub LoopAndOpenFilesInFolder()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim MyFileName As String
'if you want to Optimize code keep the following 3 instructions
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
myPath = ThisWorkbook.Path & "\"
'The file name that you are looking for
MyFileName = "*Health*"
myExtension = "*.xls*"
'Current File in loop
myFile = Dir(myPath & myExtension)
Do While myFile <> vbNullString
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'You can add a DoEvents here to give time to Excel to open the workbook before moving fwd
DoEvents
'Do Whatever you want to do
If wb.Name Like MyFileName Then
'You can also use something like
'If LCase(wb.Name) Like LCase(MyFileName) Then
'If you want to make it not case sensitive
'Your Code
Else
'Your Code
End If
'If you want to save your changes, replace the False by True to Save and Close Workbook
wb.Close SaveChanges:=False
'You can add a DoEvents here as well to give time to your Excel to close before moving to next one
DoEvents
'Get next file name
myFile = Dir
Loop
'Reset Settings
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
I'm using Access 2013. I have a list of images in a table. I then need to search through a set of folders (including sub folders), locate the images and copy them to a new directory. The table that contains the image names does not reference the file path.
What is the best way to achieve this? Is it possible to loop through the table and perform the search, or would I have break it down and manually locate each file and update a flag to say it exists, then go back and copy them?
Not sure how to do this but would appreciate any ideas.
Thanks.
For some import programs I had to manipulate files, create copies etc. and I created some functions to help process, you might find some use in them:
To create folder from VBA:
Public Function folderCreate(filePath As String) As Boolean
'define variables
Dim fsoFold As Object
'set file system object
Set fsoFold = CreateObject("Scripting.FileSystemObject")
If Not fsoFold.folderExists(filePath) Then
'check if folder exists
fsoFold.CreateFolder (filePath)
End If
folderCreate = True
Set fsoFold = Nothing
End Function
To check if folder exists:
Public Function folderExists(folderPath As String) As Boolean
'define variables
Dim fso As Object
'set file system object
Set fso = CreateObject("Scripting.FileSystemObject")
'check if file exists
If fso.folderExists(folderPath) Then
folderExists = True
Else
folderExists = False
End If
Set fso = Nothing
End Function
To check if file exists:
Public Function fileExists(filePath As String) As Boolean
'define variables
Dim fso As Object
'set file system object
Set fso = CreateObject("Scripting.FileSystemObject")
'check if file exists
If fso.fileExists(filePath) Then
fileExists = True
Else
fileExists = False
End If
Set fso = Nothing
End Function
Similar to this, use movefile to move it to new location.
fso.movefile strFullPath, strFullBackUp
EDIT: Following sub will go through given folder and list all JPG images - this code is just example how to find files, folders and how to recursively go through them.
Public Sub listImages(folderPath As String)
'define variables
Dim fso As Object
Dim objFolder As Object
Dim objFolders As Object
Dim objF As Object
Dim objFile As Object
Dim objFiles As Object
Dim strFileName As String
Dim strFilePath As String
Dim myList As String
'set file system object
Set fso = CreateObject("Scripting.FileSystemObject")
'set folder object
Set objFolder = fso.GetFolder(folderPath)
'set files
Set objFiles = objFolder.files
Set objFolders = objFolder.subfolders
'list all images in folder
For Each objFile In objFiles
If Right(objFile.Name, 4) = ".jpg" Then
strFileName = objFile.Name
strFilePath = objFile.Path
myList = myList & strFileName & " - " & strFilePath & vbNewLine
End If
Next
'go through all subflders
For Each objF In objFolders
'call same procedure for each subfolder
Call listImages(objF.Path)
Next
Debug.Print myList
Set objFolder = Nothing
set objFolders = Nothing
Set objFile = Nothing
set objF = Nothing
Set fso = Nothing
End Sub
I am attempting to create a button on one of my forms in Access that will move a file from one folder to another. The filepath of the item is stored in the database. My current approach is using VB and is displayed here.
Private Sub Command21_Click()
Dim d As Database
Dim r As Recordset
Dim path As Field
Dim fromPath As String
Dim toPath As String
Set d = CurrentDb()
Set r = d.OpenRecordset("Documents")
Set path = r.Fields("Action Items Location")
While Not r.EOF
fromPath = path
Set toPath = My.Computer.FileSystem.GetParentPath(fromPath) 'Error line
toPath = toPath & "\to folder"
My.Computer.FileSystem.MoveFile fromPath, toPath
Wend
End Sub
I keep getting an error saying object required on the line marked Error line. How do I fix this error, or am I even going about it the correct way?
Thanks for the replies, though after a bit more research, and the suggestion of #Basdwarf, I was able to find a solution. Here's the finished code
Private Sub Command21_Click()
Dim d As Database
Dim r As Recordset
Dim path As Field
Dim fromPath As String
Dim toPath As String
Dim fileName As String
Dim filesystem As Object
Set filesystem = CreateObject("Scripting.FilesystemObject")
Set d = CurrentDb()
Set r = d.OpenRecordset("Documents")
Set path = r.Fields("Action Items Location")
fromPath = path
fileName = filesystem.GetFileName(path)
toPath = filesystem.GetParentFolderName(filesystem.GetParentFolderName(fromPath)) & "\to folder" & "\" & fileName
MsgBox (fromPath)
MsgBox (toPath)
FileCopy fromPath, toPath
Kill fromPath
End Sub
GetParentPath is not an available method in the VBA.Filesystem class in Access.
Go into Code, View, Object Browser, search Filesystem for available methods.
You can use GetFileInfo to find the files directory.
I have created a data base that comes in an installer that runs as an epos system.
On installing it on other computers, I get a large number of errors all saying that something is missing. the file runs perfectly on my computer, but the errors stop anything from working on other computers....
the errors are as follows. each has its own popup box.
broken reference to excel.exe version 1.7 or missing.
acwztool.accde missing
npctrl.dll v4.1 missing
contactpicker.dll v1.0 missing
cddbcontolwinamp.dll v1.0 missing
cddbmusicidwinamp.dll v1.0 missing
colleagueimport.dll v1.0 missing
srstsh64.dll missing
I feel like this may because I altered the module vba library referencing so that I could run a vba code that uses excel, unfortunatly i have forgotten which librarys i have added
if it helps, the code that I added which required new references is below
Public Sub SalesImage_Click()
Dim rst As ADODB.Recordset
' Excel object variables
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlChart As Excel.Chart
Dim i As Integer
On Error GoTo HandleErr
' excel aplication created
Set xlApp = New Excel.Application
' workbook created
Set xlBook = xlApp.Workbooks.Add
' set so only one worksheet exists
xlApp.DisplayAlerts = False
For i = xlBook.Worksheets.Count To 2 Step -1
xlBook.Worksheets(i).Delete
Next i
xlApp.DisplayAlerts = True
' reference the first worksheet
Set xlSheet = xlBook.ActiveSheet
' naming the worksheet
xlSheet.name = conSheetName
' recordset creation
Set rst = New ADODB.Recordset
rst.Open _
Source:=conQuery, _
ActiveConnection:=CurrentProject.Connection
With xlSheet
' the field names are imported into excel and bolded
With .Cells(1, 1)
.Value = rst.Fields(0).name
.Font.Bold = True
End With
With .Cells(1, 2)
.Value = rst.Fields(1).name
.Font.Bold = True
End With
' Copy all the data from the recordset into the spreadsheet.
.Range("A2").CopyFromRecordset rst
' Format the data the numbering system has been extended to encompas up to 9,999,999 sales to cover all posibilities of sales since the last stock take
.Columns(1).AutoFit
With .Columns(2)
.NumberFormat = "#,###,###"
.AutoFit
End With
End With
' Create the chart.
Set xlChart = xlApp.Charts.Add
With xlChart
.ChartType = xl3DBarClustered
.SetSourceData xlSheet.Cells(1, 1).CurrentRegion
.PlotBy = xlColumns
.Location _
Where:=xlLocationAsObject, _
name:=conSheetName
End With
'the reference must be regotten as it is lost
With xlBook.ActiveChart
.HasTitle = True
.HasLegend = False
With .ChartTitle
.Characters.Text = conSheetName & " Chart"
.Font.Size = 16
.Shadow = True
.Border.LineStyle = xlSolid
End With
With .ChartGroups(1)
.GapWidth = 20
.VaryByCategories = True
End With
.Axes(xlCategory).TickLabels.Font.Size = 8
.Axes(xlCategoryScale).TickLabels.Font.Size = 8
End With
With xlBook.ActiveChart
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Product"
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Sales"
End With
'format the size and possition of the chart
With xlBook.ActiveChart
.Parent.Width = 800
.Parent.Height = 550
.Parent.Left = 0
.Parent.Top = 0
End With
'this displays the chart in excel. excel must be closed by the user to return to the till system
xlApp.Visible = True
ExitHere:
On Error Resume Next
'this cleans the excel file
rst.Close
Set rst = Nothing
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
Exit Sub
HandleErr:
MsgBox Err & ": " & Err.Description, , "There has been an error!"
Resume ExitHere
End Sub
Deployment should be less troublesome if you remove your project's Excel reference and use late binding for Excel objects.
A downside is you lose the benefit of Intellisense during development with late binding. However it's very easy to switch between early binding during development and late binding for production. Simply change the value of a compiler constant.
In the module's Declarations section ...
#Const DevStatus = "PROD" 'PROD or DEV
Then within the body of a procedure ...
#If DevStatus = "DEV" Then
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Set xlApp = New Excel.Application
#Else ' assume PROD (actually anything other than DEV)
Dim xlApp As Object
Dim xlBook As Object
Dim xlSheet As Object
Set xlApp = CreateObject("Excel.Application")
#End If
With late binding your code will need to use the values of Excel constants rather than the constants names. Or you can define the named constants in the #Else block for production use then continue to use them by name in your code.
I don't know what all those other reference are. Suggest you take a copy of your project, remove all those references and see what happens when you run Debug->Compile from the VB Editor's main menu. Leave any unneeded references unchecked. And try late binding for the rest. I use only 3 references in production versions of Access applications: VBA; Access; and DAO.
Is it possible to loop through for all shortcuts (.lnk) in a given location and return the .TargetPath. If a shortcuts target matches a criteria an action can then be peformed on the shortcut?
To delete all shortcuts I would use the following:
Public Sub deleteAllShortcuts()
Dim shortCutPath As String
' compName = Computer Name, recordDirShort = directory where the shortcut lnks are
shortCutPath = compName & recordDirShort
shortCutPath = shortCutPath & "*.lnk"
On Error Resume Next
Kill shortCutPath
On Error GoTo 0
End Sub
I cant figure out how I would loop through all shortcuts in the directory using the above loop.
Any help on the above would be greatly appreciated
Cheers
Noel
Hopefully this may be good to someone.
To delete shortcuts by the shorcut target I used the following:
Public Sub deleteShortcutByTarget(targetFolderName As String)
Dim strDocPath As String
Dim strTarget As String
Dim obj As Object
Dim shortcut As Object
Dim objFso As Object
Dim objFolder As Object
Dim objFile As Object
Set obj = CreateObject("WScript.Shell")
Set objFso = CreateObject("Scripting.FileSystemObject")
strDocPath = compName & recordDirShort
Set objFolder = objFso.GetFolder(strDocPath)
Set objFile = objFolder.Files
For Each objFile In objFolder.Files
If objFso.GetExtensionName(objFile.Path) = "lnk" Then
Set shortcut = obj.CreateShortcut(objFile.Path)
strTarget = shortcut.TargetPath
shortcut.Save
If strTarget = strDocPath & targetFolderName Then
Kill objFile.Path
End If
End If
Next
Set obj = Nothing
Set objFile = Nothing
Set objFso = Nothing
Set objFolder = Nothing
Set shortcut = Nothing
End Sub
Within Access you could use the Dir() function. It would be something like this:
Dim strLink As String
strLink = Dir(shortCutPath & "*.lnk")
Do Until Len(strLink)=0
Kill strLink
strLink = Dir()
Loop
Dir() doesn't play well with network paths in all cases, though, so you might want to use the File System Object, instead. It's much more versatile and works better with networks. I use it only occasionally, so don't have the code at my fingertips, but have a look at it -- you might have no trouble figuring it out as the object model is pretty clearly designed.