I have the below code which works up until I try to move the file once I have extracted the attachment.
The error says the file is still open. I confirmed that when I try to move it manually.
Filename = Dir(RFQFolder)
Set outApp = GetObject(, "Outlook.Application")
'Open .msg file in Outlook 2007+
Set outEmail = outApp.Session.OpenSharedItem(RFQFolder & Filename)
For Each outAttachment In outEmail.Attachments
If outAttachment.Filename Like "*.xls*" Then
ROUploadFile1 = RFQFolder & outAttachment.Filename
outAttachment.SaveAsFile RFQFolder & outAttachment.Filename
End If
Next
outEmail.Close olDiscard
Set outEmail = Nothing
Set outApp = Nothing
Set outAttachment = Nothing
Set oFS = CreateObject("Scripting.Filesystemobject")
oFS.moveFile Source:=RFQFolder & "\" & Filename, Destination:=Newpath & "\" & Filename
Set oFS = Nothing
If moving the file is the problem, why not save it directly where you need it?
Filename = Dir(RFQFolder)
Set outApp = GetObject(, "Outlook.Application")
'Open .msg file in Outlook 2007+
Set outEmail = outApp.Session.OpenSharedItem(RFQFolder & Filename)
For Each outAttachment In outEmail.Attachments
If outAttachment.Filename Like "*.xls*" Then
ROUploadFile1 = RFQFolder & outAttachment.Filename
outAttachment.SaveAsFile Newpath & "\" & Filename 'Changed the save path
End If
Set outAttachment = Nothing
Next
outEmail.Close olDiscard
Set outEmail = Nothing
Set outApp = Nothing
You are accessing the Attachments collection (outEmail.Attachments) - you need to either
Store the reference in a dedicated variable and release it by setting to Nothing
Avoid using "for each" loops - they keep reference to all colleciton items.
The easiest - move all that code into a separate sub: this way all internal (to that sub) variables will be released by VBA when the sub exits. You can call MoveFile outside of that sub.
Related
I am trying to save attachments from an email. I get the error message
Outlook cannot perform this action on this type of attachment
Using Debug.Print outAttachment, it is trying to extract a Picture (Device Independent Bitmap).
I only need the Excel and pdf extracted, but I don't mind extracting the picture if it means the code works.
Public Sub Extract_Attachments_From_Outlook_Msg_Files()
Dim outApp As Object
Dim outEmail As Object
Dim outAttachment As Object
Dim msgFiles As String, sourceFolder As String, saveInFolder As String
Dim fileName As String
Dim FilePath As String
Application.DisplayAlerts = False
msgFiles = Sheets("Instructions").Range("H1") & Sheets("Instructions").Range("H2") & ".msg" 'folder location and filespec of .msg files"
Debug.Print msgFiles
saveInFolder = Sheets("Instructions").Range("H1") 'folder where extracted attachments are saved
Debug.Print saveInFolder
If Right(saveInFolder, 1) <> "\" Then saveInFolder = saveInFolder & "\"
sourceFolder = Left(msgFiles, InStrRev(msgFiles, "\"))
Debug.Print sourceFolder
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
If outApp Is Nothing Then
MsgBox "Outlook is not open"
Exit Sub
End If
On Error GoTo 0
fileName = Dir(msgFiles)
While fileName <> vbNullString
Set outEmail = outApp.Session.OpenSharedItem(sourceFolder & fileName)
For Each outAttachment In outEmail.Attachments
outAttachment.SaveAsFile saveInFolder & outAttachment.fileName
Next
fileName = Dir
Wend
End Sub
This is an RTF-formatted message with embedded OLE objects, right?
Outlook Object Model does not allow to do much with attachments of that type (Attachment.Type == olOLE).
If using Redemption is an option (I am its author), its RDOAttachment.SaveAsFile method is smart enough to extract BMP, EMF, PDF, Excel, etc. file data from the storage. Something like the following (off the top of my head) should do the job:
set Session = CreateObject("Redemption.RDOSession")
set outEmail= Session.GetMessageFromMsgFile(sourceFolder & fileName)
For Each outAttachment In outEmail.Attachments
outAttachment.SaveAsFile saveInFolder & outAttachment.fileName
Next
I used:
If att.Type <> olOLE Then
to just skip that object so that I could continue to extract all other attachments.
My macro prints invoices automatically but when multiple attachments are named the same, it prints only the first one multiple times.
Sub LSPrint(Item As Outlook.MailItem)
On Error Resume Next
Dim oFS As FileSystemObject
Dim sTempFolder As String
Set oFS = New FileSystemObject
sTempFolder = oFS.GetSpecialFolder(TemporaryFolder)
cTmpFld = sTempFolder & "\OETMP" & Format(Now, "yyyymmddhhmmss")
MkDir (cTmpFld)
Dim oAtt As Attachment
For Each oAtt In Item.Attachments
FileName = oAtt.FileName
FullFile = cTmpFld & "\" & FileName
oAtt.SaveAsFile (FullFile)
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace(0)
Set objFolderItem = objFolder.ParseName(FullFile)
objFolderItem.InvokeVerbEx ("print")
Next oAtt
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
How do I print multiple attachments if they are named the same?
Possibly renaming the files and then printing those.
As you stated, created a naming convention to force unique file names among the attachments. This is done here with variable i
Dim oAtt As Attachment
Dim i as Long: i = 1
For Each oAtt In Item.Attachments
FileName = oAtt.FileName
FullFile = cTmpFld & "\" & FileName & i '<-- add unique identifier
oAtt.SaveAsFile (FullFile)
'.... More stuff
i = i + 1 '<-- increment to next unique identifier
Next oAtt
Try changing the following line
FileName = oAtt.FileName
To
FileName = oAtt.FileName & Format(Now, " yyyymmddhhmmssms")
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.
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.