I recently posted trying to figure out how to copy/paste some files via VBA using the Windows copy file notification. I have found out that my script works, but it is copying the files from the location I want to copy them to, and pasting them in the location I want to copy from (exactly opposite). Can anyone explain to me why? Here is my code:
Private Sub Main()
'***************************************************************************
' Personal details
'***************************************************************************
'Ask if the user wants to continue
If MsgBox("Do you wish to continue (Outlook will close)?", vbYesNo + vbQuestion) = vbNo Then
ThisWorkbook.Close
End
End If
'Close Outlook so it doesn't interfere with the file copy
strComputer = "."
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colProcessList = objWMIService.ExecQuery("Select * from Win32_Process Where Name = 'Outlook.exe'")
For Each objProcess In colProcessList
Set objOutlook = CreateObject("Outlook.Application")
objOutlook.Quit
Next
If Len(Dir("\\[NetDrive]\[EmpNum]$\")) <> 0 Then
If Len(Dir("C:\Users\[EmpNum]\Documents\Outlook Files\")) <> 0 Then
'Taken from multiple examples
'http://www.mrexcel.com/forum/excel-questions/238407-progress-bar-copying-file.html
Dim FromPath As Variant
Dim ToPath As Variant
FromPath = "C:\Users\[EmpNum]\Documents\Outlook Files\" '<< Change for implicit reference
ToPath = "\\[NetDrive]\[EmpNum]$\Personal Folder Backup" '<< Change for implicit reference
Application.Wait (Now + TimeValue("0:00:05")) 'Delay to allow Outlook to close
Set objShell = CreateObject("Shell.Application")
'//The source Folder to CopyFrom:
Set objFolder = objShell.Namespace(FromPath)
'//The source Folder to CopyTo:
objFolder.CopyHere ToPath, &H10&
Set objShell = Nothing
Set objFolder = Nothing
MsgBox "You can find the files and subfolders from " & FromPath & " in " & ToPath
Else
MsgBox "Personal folder location not found. Please check your personal folder."
End If
Else
MsgBox "Network location not available. Check your shared drives for connection."
End If
Application.Quit
End Sub
I have removed and/or changed a couple personal details, but other than that this is my code exactly.
I'm not sure why this worked this time and it didn't before. But I modified my code to read what I have below, and now it suddenly works correctly:
Private Sub Main()
'***************************************************************************
' Personal Information
'***************************************************************************
'Ask if the user wants to continue
If MsgBox("Do you wish to continue (Outlook will close)?", vbYesNo + vbQuestion) = vbNo Then
ThisWorkbook.Close
End
End If
'Close Outlook so it doesn't interfere with the file copy
strComputer = "."
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colProcessList = objWMIService.ExecQuery("Select * from Win32_Process Where Name = 'Outlook.exe'")
For Each objProcess In colProcessList
Set objOutlook = CreateObject("Outlook.Application")
objOutlook.Quit
Next
If Len(Dir("\\[NetDrive]\[EmpNum]$\")) <> 0 Then
If Len(Dir("C:\Users\[EmpNum]\Documents\Outlook Files\")) <> 0 Then
'Taken from multiple examples
'http://www.mrexcel.com/forum/excel-questions/238407-progress-bar-copying-file.html
Dim FromPath As Variant
Dim ToPath As Variant
FromPath = "C:\Users\[EmpNum]\Documents\Outlook Files\" '<< Change for implicit reference
ToPath = "\\[NetDrive]\[EmpNum]$\Personal Folder Backup\" '<< Change for implicit reference
Application.Wait (Now + TimeValue("0:00:05")) 'Delay to allow Outlook to close
Set objShell = CreateObject("Shell.Application")
' '//The source Folder to CopyFrom:
' Set objFolder = objShell.Namespace(FromPath)
'
' '//The source Folder to CopyTo:
' objFolder.CopyHere ToPath, &H10&
'
' Set objShell = Nothing
' Set objFolder = Nothing
Set objFolder = objShell.Namespace(ToPath)
If (Not objFolder Is Nothing) Then
objFolder.CopyHere (FromPath)
End If
Set objFolder = Nothing
Set objShell = Nothing
MsgBox "You can find the files and subfolders from " & FromPath & " in " & ToPath
Else
MsgBox "Personal folder location not found. Please check your personal folder."
End If
Else
MsgBox "Network location not available. Check your shared drives for connection."
End If
Application.Quit
End Sub
I guess the only difference is the &H10& isn't there anymore.
Related
This Run a Script code to save attachments stops saving attachments because the rule turns off.
Public Sub SaveAttachmentsToDisk(MItem As Outlook.MailItem)
Dim oAttachment As Outlook.Attachment
Dim sSaveFolder As String
sSaveFolder = "C:\Users\andra.aeras\Documents\Test\"
For Each oAttachment In MItem.Attachments
If Right(oAttachment.FileName, 4) = "xlsx" Then
oAttachment.SaveAsFile sSaveFolder & oAttachment.DisplayName
End If
Next
End Sub
Is there a way to "enable" the rules or improve this code to run properly or run without using rules?
Try it like this.
Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox As String, _
ExtString As String, DestFolder As String)
Dim ns As Namespace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim MyDocPath As String
Dim I As Integer
Dim wsh As Object
Dim fs As Object
On Error GoTo ThisMacro_err
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders(OutlookFolderInInbox)
I = 0
' Check subfolder for messages and exit of none found
If SubFolder.Items.Count = 0 Then
MsgBox "There are no messages in this folder : " & OutlookFolderInInbox, _
vbInformation, "Nothing Found"
Set SubFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
Exit Sub
End If
'Create DestFolder if DestFolder = ""
If DestFolder = "" Then
Set wsh = CreateObject("WScript.Shell")
Set fs = CreateObject("Scripting.FileSystemObject")
MyDocPath = wsh.SpecialFolders.Item("mydocuments")
DestFolder = MyDocPath & "\" & Format(Now, "dd-mmm-yyyy hh-mm-ss")
If Not fs.FolderExists(DestFolder) Then
fs.CreateFolder DestFolder
End If
End If
If Right(DestFolder, 1) <> "\" Then
DestFolder = DestFolder & "\"
End If
' Check each message for attachments and extensions
For Each Item In SubFolder.Items
For Each Atmt In Item.Attachments
If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
FileName = DestFolder & Item.SenderName & " " & Atmt.FileName
Atmt.SaveAsFile FileName
I = I + 1
End If
Next Atmt
Next Item
' Show this message when Finished
If I > 0 Then
MsgBox "You can find the files here : " _
& DestFolder, vbInformation, "Finished!"
Else
MsgBox "No attached files in your mail.", vbInformation, "Finished!"
End If
' Clear memory
ThisMacro_exit:
Set SubFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
Set fs = Nothing
Set wsh = Nothing
Exit Sub
' Error information
ThisMacro_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: SaveEmailAttachmentsToFolder" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume ThisMacro_exit
End Sub
Sub Test()
'Arg 1 = Folder name of folder inside your Inbox
'Arg 2 = File extension, "" is every file
'Arg 3 = Save folder, "C:\Users\Ron\test" or ""
' If you use "" it will create a date/time stamped folder for you in your "Documents" folder
' Note: If you use this "C:\Users\Ron\test" the folder must exist.
SaveEmailAttachmentsToFolder "MyFolder", "xls", ""
End Sub
Steps to follow:
1) Go to the VBA editor, Alt -F11
2) Tools>References in the Menu bar
3) Place a Checkmark before Microsoft Outlook ? Object Library
? is the Outlook version number
4) Insert>Module
5) Paste the code (two macros) in this module
6) Alt q to close the editor
7) Save the file
I need to save the attachment of last email that has a specific subject (the most recent one) to a local folder, to do this I have created a folder in my Outlook and a rule to send every email with that specific subject to this folder. I have found a code that does what I needed except that it saves every single attachment in the email folder rather than saving only the most recent one. This is the code: how could i modify it so that it does what i need?
Sub Test()
'Arg 1 = Folder name of folder inside your Inbox
'Arg 2 = File extension, "" is every file
'Arg 3 = Save folder, "C:\Users\Ron\test" or ""
' If you use "" it will create a date/time stamped folder for you in your "Documents" folder
' Note: If you use this "C:\Users\Ron\test" the folder must exist.
SaveEmailAttachmentsToFolder "Dependencia Financiera", "xls", "W:\dependencia financiera\test dependencia\"
End Sub
Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox As String, _
ExtString As String, DestFolder As String)
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim MyDocPath As String
Dim i As Integer
Dim wsh As Object
Dim fs As Object
On Error GoTo ThisMacro_err
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders(OutlookFolderInInbox)
i = 0
' Check subfolder for messages and exit of none found
If SubFolder.Items.Count = 0 Then
MsgBox "There are no messages in this folder : " & OutlookFolderInInbox, _
vbInformation, "Nothing Found"
Set SubFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
Exit Sub
End If
'Create DestFolder if DestFolder = ""
' If DestFolder = "" Then
' Set wsh = CreateObject("WScript.Shell")
' Set fs = CreateObject("Scripting.FileSystemObject")
' MyDocPath = wsh.SpecialFolders.Item("mydocuments")
' DestFolder = MyDocPath & "\" & Format(Now, "dd-mmm-yyyy hh-mm-ss")
' If Not fs.FolderExists(DestFolder) Then
'fs.CreateFolder DestFolder
' End If
'End If
'If Right(DestFolder, 1) <> "\" Then
'DestFolder = DestFolder & "\"
'End If
' Check each message for attachments and extensions
'JUST BEED TGE FIRST EMAIL
'Debug.Print Item(1).SentOn
For Each Item In SubFolder.Items
For Each Atmt In Item.Attachments
If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
FileName = DestFolder & Atmt.FileName
Atmt.SaveAsFile FileName
'I = I + 1
End If
Next Atmt
Next Item
' Show this message when Finished
' If I > 0 Then
' MsgBox "You can find the files here : " _
& DestFolder, vbInformation, "Finished!"
' Else
' MsgBox "No attached files in your mail.", vbInformation, "Finished!"
' End If
' Clear memory
ThisMacro_exit:
Set SubFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
Set fs = Nothing
Set wsh = Nothing
Exit Sub
' Error information
ThisMacro_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: SaveEmailAttachmentsToFolder" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume ThisMacro_exit
End Sub
You could try this
Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox As String, _
ExtString As String, DestFolder As String)
Dim ns As Namespace
Dim Inbox As Folder
Dim SubFolder As Folder
Dim subFolderItems As Items
Dim Atmt As attachment
Dim FileName As String
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders(OutlookFolderInInbox)
Set subFolderItems = SubFolder.Items
If subFolderItems.count > 0 Then
subFolderItems.Sort "[ReceivedTime]", True
For Each Atmt In subFolderItems(1).Attachments
If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
FileName = DestFolder & Atmt.FileName
Atmt.SaveAsFile FileName
End If
Next Atmt
End If
' Clear memory
ThisMacro_exit:
Set SubFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
Set subFolderItems = Nothing
End Sub
Consider ItemAdd. The most recent item is already known. How do I trigger a macro to run after a new mail is received in Outlook?
I have the following code that auto prints my pdf when an email is received. Every now and then i get a file access error and it holds up all emails from being checked. Most times it happens multiple times when it happens.
I have tried a couple things but still get that error every now and then.
Sub LSPrint(Item As Outlook.MailItem)
On Error GoTo OError
'detect Temp
Dim oFS As FileSystemObject
Dim sTempFolder As String
Set oFS = CreateObject("Scripting.FileSystemObject")
'Temporary Folder Path
sTempFolder = oFS.GetSpecialFolder(TemporaryFolder)
'creates a special temp folder
cTmpFld = sTempFolder & "\OETMP" & Format(Now, "yyyymmddhhmmss")
MkDir (cTmpFld)
'save & print
Dim oAtt As Attachment
For Each oAtt In Item.Attachments
FileName = oAtt.FileName
fullfile = cTmpFld & "\" & FileName
'save attachment
oAtt.SaveAsFile (fullfile)
'prints attachment
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace(0)
Set objFolderItem = objFolder.ParseName(fullfile)
objFolderItem.InvokeVerbEx ("print")
Next oAtt
'Cleanup
If Not oFS Is Nothing Then Set oFS = Nothing
If Not objFolder Is Nothing Then Set objFolder = Nothing
If Not objFolderItem Is Nothing Then Set objFolderItem = Nothing
If Not objShell Is Nothing Then Set objShell = Nothing
OError:
If Err <> 0 Then
MsgBox Err.Number & " - " & Err.Description
Err.Clear
End If
Exit Sub
End Sub
Likely the file has not finished saving.
Sub LSPrint(Item As Outlook.MailItem)
' Remove this line to determine the line with the error
' On Error GoTo OError
dim i as long
'detect Temp
Dim oFS As FileSystemObject
Dim sTempFolder As String
Set oFS = CreateObject("Scripting.FileSystemObject")
'Temporary Folder Path
sTempFolder = oFS.GetSpecialFolder(TemporaryFolder)
'creates a special temp folder
cTmpFld = sTempFolder & "\OETMP" & Format(Now, "yyyymmddhhmmss")
MkDir (cTmpFld)
'save & print
Dim oAtt As Attachment
For Each oAtt In Item.Attachments
FileName = oAtt.FileName
fullfile = cTmpFld & "\" & FileName
'save attachment
oAtt.SaveAsFile (fullfile)
'prints attachment
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace(0)
On Error GoTo OErrorDelay
' Assuming it is the line with the error
Set objFolderItem = objFolder.ParseName(fullfile)
on error goto 0
objFolderItem.InvokeVerbEx ("print")
Next oAtt
'Cleanup
Set oFS = Nothing
Set objFolder = Nothing
Set objFolderItem = Nothing
Set objShell = Nothing
exit sub
OError:
MsgBox Err.Number & " - " & Err.Description
Err.Clear
Exit Sub
OErrorDelay:
' Assuming the error is due to the file not yet being available
' Some method to delay the print request
' This will use the minimum delay, if it works
i = i + 1
' some "reasonable" number
if i > 100000 then goto OError
resume
End Sub
I've a VBA script as below.
Sub AutoOpen()
ActiveDocument.Variables("LastOpen").Value = Now()
End Sub
Sub AutoClose()
Dim objFSO, objFolder, objTextFile, objFile
Dim strDirectory, strFile, strText
strDirectory = "d:\work"
strFile = "\work.csv"
' Create the File System Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
' Check that the strDirectory folder exists
If objFSO.FolderExists(strDirectory) Then
Set objFolder = objFSO.GetFolder(strDirectory)
Else
Set objFolder = objFSO.CreateFolder(strDirectory)
Debug.Print "Just created " & strDirectory
End If
If objFSO.FileExists(strDirectory & strFile) Then
Set objFolder = objFSO.GetFolder(strDirectory)
Else
Set objFile = objFSO.CreateTextFile(strDirectory & strFile)
Debug.Print "Just created " & strDirectory & strFile
End If
Set objFile = Nothing
Set objFolder = Nothing
' OpenTextFile Method needs a Const value
' ForAppending = 8 ForReading = 1, ForWriting = 2
Const ForAppending = 8
Set objTextFile = objFSO.OpenTextFile(strDirectory & strFile, ForAppending, True)
'Build the string to write
strText = """" & ActiveDocument.FullName & """" & "," & ActiveDocument.Variables("LastOpen").Value & "," & Now()
' Writes strText every time you run this VBScript
objTextFile.WriteLine (strText)
objTextFile.Close
End Sub
here the macro is running fine, but the problem is when i open and close my word document, though there are no changes done, it asks me if i would like to save the changes like below.
please let me know how can i avoid this save dialogue box, if there are no changes made in document.
here if i open a blank document and close it, even then this is getting triggered.
As mentioned in comments, the creation of the variable in AutoOpen is causing this behavior.
Include a Save statement in AutoOpen:
Sub AutoOpen()
ActiveDocument.Variables("LastOpen").Value = Now()
ThisDocument.Save
End Sub
to avoid the Save prompt.
I have followed the instructions at http://www.rondebruin.nl/win/s1/outlook/saveatt.htm to save attachments from emails in a specific folder to another folder. When I run this code I get the error:
An unexpected error has occurred.
Please note and report the following information.
Macro Name: SaveEmailAttachmentsToFolder
Error Number: -2147221233
Error Description: The attempted operation failed. An object could
not be found.
New to macros, so don't know where the error may be. Any advice?
The code is below:
Sub Test()
SaveEmailAttachmentsToFolder "MyFolder", "xls", ""
End Sub
Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox As String, _
ExtString As String, DestFolder As String)
Dim ns As Namespace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim MyDocPath As String
Dim I As Integer
Dim wsh As Object
Dim fs As Object
On Error GoTo ThisMacro_err
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders(OutlookFolderInInbox)
I = 0
' Check subfolder for messages and exit of none found
If SubFolder.Items.Count = 0 Then
MsgBox "There are no messages in this folder : " & OutlookFolderInInbox, _
vbInformation, "Nothing Found"
Set SubFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
Exit Sub
End If
'Create DestFolder if DestFolder = ""
If DestFolder = "" Then
Set wsh = CreateObject("WScript.Shell")
Set fs = CreateObject("Scripting.FileSystemObject")
MyDocPath = wsh.SpecialFolders.Item("mydocuments")
DestFolder = MyDocPath & "\" & Format(Now, "dd-mmm-yyyy hh-mm-ss")
If Not fs.FolderExists(DestFolder) Then
fs.CreateFolder DestFolder
End If
End If
If Right(DestFolder, 1) <> "\" Then
DestFolder = DestFolder & "\"
End If
' Check each message for attachments and extensions
For Each Item In SubFolder.Items
For Each Atmt In Item.Attachments
If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
FileName = DestFolder & Item.SenderName & " " & Atmt.FileName
Atmt.SaveAsFile FileName
I = I + 1
End If
Next Atmt
Next Item
' Show this message when Finished
If I > 0 Then
MsgBox "You can find the files here : " _
& DestFolder, vbInformation, "Finished!"
Else
MsgBox "No attached files in your mail.", vbInformation, "Finished!"
End If
' Clear memory
ThisMacro_exit:
Set SubFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
Set fs = Nothing
Set wsh = Nothing
Exit Sub
' Error information
ThisMacro_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: SaveEmailAttachmentsToFolder" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume ThisMacro_exit
End Sub
Community wiki. Answer is in a comment. Anyone finding this topic in a search will see there is an answer and is more likely to look in for a hopefully useful answer.
"The problem was that the folder I specified wasn't actually created within the Inbox, it was at the same level as the Inbox and so it couldn't find the folder. Simple things..." chinvpl