I have created a VBA access application to find a PDF file in a folder by doing one sweep to get all the sub-folders in the root folder. Then another sweep to collect and compare all the file names to the one that is selected. We are then using the following code to open the file when it is found:
Private Sub Command132_Click()
On Error GoTo Err_Command132_Click
Dim rootFolder As String
Dim subFolder As String
Dim fileSpec As String
Dim filename As String
Dim foundfile As String
Dim filepath As String
Dim subfolders() As String
Dim co As String
Dim intSubFolderCount As Integer
rootFolder = "T:\Scanned Work Orders (Archives)\"
subFolder = Dir(rootFolder & "*.*", vbDirectory)
'*** Get subfolders in array ***
While subFolder <> ""
If subFolder <> "." And subFolder <> ".." Then
ReDim Preserve subfolders(intSubFolderCount)
subfolders(intSubFolderCount) = subFolder
intSubFolderCount = intSubFolderCount + 1
Debug.Print subFolder
End If
subFolder = Dir()
Wend
'*** Loop over array and find files ***
For intSubFolderCount = 0 To UBound(subfolders)
fileSpec = Trim(Me.Combo_History) & "*.pdf"
co = subfolders(intSubFolderCount)
filename = Dir(rootFolder & subfolders(intSubFolderCount) & "\" & fileSpec)
Do While filename <> ""
filepath = rootFolder & subfolders(intSubFolderCount)
foundfile = filepath & "\" & filename
Application.FollowHyperlink foundfile
GoTo Exit_Command132_Click
Exit Do
Loop
Next intSubFolderCount
MsgBox "No Scanned work order found for " & Me.Combo_History & "!"
Exit_Command132_Click:
Exit Sub
Err_Command132_Click:
Select Case Err.Number
Case 52
MsgBox "No Scanned work order found for " & Me.Combo_History & "!"
Case Else
MsgBox Err.Number & "-" & Err.Description
End Select
End Sub
But on some of the computers in my office they get this error message:
"Some Files can contain viruses or otherwise be harmful to your computer.
It is important to be certain that this file is from a trustworthy source.
Would you like to open this file?"
Is it possible to suppress this? We are running windows 7 professional.
This is a windows feature. Microsoft have KB on removing it here.
https://support.microsoft.com/en-us/kb/925757
It is possible to use VBA to change the registry settings, but follow the KB instructions first to ensure it solves your issue.
Related
I am looking for a way to copy multiple files from a single folder and copy this grouping of files to multiple folders using FileDialog in Access vba. Below is what I have so far - the problem with this code is that I can only copy multiple files from a single folder to another single folder. Can anyone help with this:
Public Function CopyFilesToFolders()
On Error GoTo Err_Copy
Dim sourcefiles As String
Dim destination As String
Dim source As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a folder that contains the desired files to copy."
If .Show = -1 Then source = .SelectedItems(1)
If Len(source) = 0 Then Exit Function
.AllowMultiSelect = True
.Title = "Select a folder location to copy the files."
If .Show = -1 Then destination = .SelectedItems(1)
If Len(destination) = 0 Then Exit Function
End With
sourcefiles = Dir$(source & "\*.*")
Do While Len(sourcefiles) > 0
FileCopy (source & "\" & sourcefiles), (destination & "\" & sourcefiles)
sourcefiles = Dir$
Loop
Exit_Copy:
Exit Function
Err_Copy:
CopyFilesToFolders = True
MsgBox Error$
Resume Exit_Copy
MsgBox "Task Complete!"
End Function
Thank you,
Al
So you want the function to automatically detect all the subfolders and copy the selected files to them? You can use FileSystemObject to detect all the subfolders, then copy the files to them. See this modified function:
Public Function CopyFilesToFolders()
On Error GoTo Exit_Copy
Dim sourcefiles As String
Dim destination As String
Dim source As String
Dim FileSystem As Object
Set FileSystem = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a folder that contains the desired files to copy."
If .Show = -1 Then source = .SelectedItems(1)
If Len(source) = 0 Then Exit Function
.AllowMultiSelect = True
.Title = "Select a folder location to copy the files."
If .Show = -1 Then destination = .SelectedItems(1)
If Len(destination) = 0 Then Exit Function
End With
sourcefiles = Dir$(source & "\*.*")
Dim SubFolder
Do While Len(sourcefiles) > 0
For Each SubFolder In FileSystem.GetFolder(destination).SubFolders
FileCopy (source & "\" & sourcefiles), (SubFolder.path & "\" & sourcefiles)
Next
sourcefiles = Dir$
Loop
Exit_Copy:
Exit Function
End Function
Sorry, for changing the topic a bit, but I think int would be a lot easier to do this in Excel, rather than in Access. See the example below.
Sub sbCopyingAFile()
'Declare Variables
Dim FSO
Dim sFile As String
Dim sSFolder As String
Dim sDFolder As String
'This is Your File Name which you want to Copy
sFile = "Sample.xls"
'Change to match the source folder path
sSFolder = "C:\Temp\"
'Change to match the destination folder path
sDFolder = "D:\Job\"
'Create Object
Set FSO = CreateObject("Scripting.FileSystemObject")
'Checking If File Is Located in the Source Folder
If Not FSO.FileExists(sSFolder & sFile) Then
MsgBox "Specified File Not Found", vbInformation, "Not Found"
'Copying If the Same File is Not Located in the Destination Folder
ElseIf Not FSO.FileExists(sDFolder & sFile) Then
FSO.CopyFile (sSFolder & sFile), sDFolder, True
MsgBox "Specified File Copied Successfully", vbInformation, "Done!"
Else
MsgBox "Specified File Already Exists In The Destination Folder", vbExclamation, "File Already Exists"
End If
End Sub
Now, if you want to dynamically list the files in a folder, each file path in an individual cell, and then specify exactly which files to copy from one folder to another, that is definitely doable. First, try the sample code above, and give me feedback for future enhancements.
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
Situation:
I am iterating through an Outlook-Mailbox and downloading all attachments into specific folders. Then I am iterating through the folders and import the CSV-Files into Access.
Problem:
I have the Outlook.MailItem.receiveTime property and the sender's name, which I have got from the File Title. I want to add those two pieces of information to each row of each CSV-File.
Question:
Is there a possibility to add those two columns on import or do I have to open each file and iterate through the content to add them?
Little side question:
Would it be possible to import the files directly from Outlook, meaning, without heaving to save them?
Software and languages I use:
-Access 2013
-Outlook 2013
-VBA
-SQL
Little side Information: I am triggering all of this from an Access Form.
You can loop through all CSV files and import each to a table.
Private Sub Command0_Click()
Const strPath As String = "C:\your_path_here\" 'Directory Path
Dim strFile As String 'Filename
Dim strFileList() As String 'File Array
Dim intFile As Integer 'File Number
'Loop through the folder & build file list
strFile = Dir(strPath & "*.csv")
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 & import to Access
'creating a new table called MyTable
For intFile = 1 To UBound(strFileList)
DoCmd.TransferText acImportDelimi, , _
"Test", strPath & strFileList(intFile)
'Check out the TransferSpreadsheet options in the Access
'Visual Basic Help file for a full description & list of
'optional settings
Next
MsgBox UBound(strFileList) & " Files were Imported"
End Sub
If you want to download attachment from Outlook, try this.
Private Sub GetAttachments()
Dim ns As Namespace
Dim Inbox As Outlook.MAPIFolder
Dim Item As Object
Dim Atmt As Outlook.Attachment
Dim FileName As String
Set ns = GetNamespace("MAPI")
Set Inbox = ns.Folders("MailboxName").Folders("Inbox")
If Inbox.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If
For Each Item In Inbox.Items
For Each Atmt In Item.Attachments
If Atmt.Type = 1 And InStr(Atmt, "xlsx") > 0 Then
FileName = "C:\attachments\" & Atmt.FileName
Atmt.SaveAsFile FileName
End If
Next Atmt
Next Item
End Sub
Set a reference to MS Outlook and remember, the "MailboxName" is your email address.
I'm trying to set up an automatic process that scans a particular network folder for new CSV files and then appends the data to a table in Access.
A new CSV is placed in the folder everyday and they all have the same naming convention - ClosingPrice_ddmmyy with the date part changing on every file.
What's the most straight forward way to set up such a process?
All suggestions welcome!
Thanks for the reply, Rahul.
I found the following code on another forum that does most of what I want. It imports all the CSVs from within the source folder and adds them to a table within Access. However, in future I just want to add new CSVs that are added to the folder and not all the CSVs every time. Any ideas on how I can change the code to do this?
Thanks,
Sub Import_CSV()
'Modified from WillR - www.willr.info (December 2004)
Const strPath As String = "C:\ImportFolder\" 'Directory Path
Dim strFile As String 'Filename
Dim strFileList() As String 'File Array
Dim intFile As Integer 'File Number
'Loop through the folder & build file list
strFile = Dir(strPath & "*.csv")
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 & import to Access
'creating a new table called MyTable
For intFile = 1 To UBound(strFileList)
DoCmd.TransferText acImportDelimi, ImportSpec, _
"Raw Data", strPath & strFileList(intFile), -1
'Check out the TransferSpreadsheet options in the Access
'Visual Basic Help file for a full description & list of
'optional settings
Next
MsgBox UBound(strFileList) & " Files were Imported"
End Sub
Can anyone give me the code to create a backup/copy of the Database when opening? it I know how to use autoexec macro i just need the code. The database name is Datenbank and the back to have the time of back in its name
That command could be:
FileCopy CurrentDb.Name, Replace(CurrentDb.Name, ".accdb", Format(Now(), " yyyymmdd hhnnss") & ".accdb")
but you can't do that for the database file itself from inside the application.
Your best option would be to create a shortcut that runs a script that copies the file first, then opens it.
Addendum
I located a function that will create a zipped backup of the current project:
Option Compare Database
Option Explicit
' API call for sleep function.
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Function ZipCurrentProject() As Long
Dim ShellApplication As Object
Dim CurrentProjectFile As String
Dim ZipPath As String
Dim ZipName As String
Dim ZipFile As String
Dim FileNumber As Integer
' File and folder names.
CurrentProjectFile = CurrentProject.Path & "\" & CurrentProject.Name
' The path must exist.
ZipPath = CurrentProject.Path & "\#dbase_bk" & Format(Now, " yyyy-mm-dd hh.nn.ss") & "\"
ZipName = "CCOLearningHub.zip"
ZipFile = ZipPath & ZipName
' Create sub folder if missing.
If Dir(ZipPath, vbDirectory) = "" Then
MkDir ZipPath
End If
' Create empty zip folder.
FileNumber = FreeFile
Open ZipFile For Output As #FileNumber
Print #FileNumber, Chr(80) & Chr(75) & Chr(5) & Chr(6) & String(18, vbNullChar)
Close #FileNumber
Set ShellApplication = CreateObject("Shell.Application")
' Copy the project file into the zip file.
With ShellApplication
Debug.Print Timer, "zipping started ..."
.Namespace(CVar(ZipFile)).CopyHere CVar(CurrentProjectFile)
' Ignore error while looking up the zipped file before is has been added.
On Error Resume Next
' Wait for the file to created.
Do Until .Namespace(CVar(ZipFile)).Items.Count = 1
' Wait a little ...
'DoEvents
Sleep 100
Debug.Print " .";
Loop
Debug.Print
' Resume normal error handling.
On Error GoTo 0
Debug.Print Timer, "zipping finished."
End With
Set ShellApplication = Nothing
ZipCurrentProject = Err.Number
End Function