I have a sorting script executed in all comming mails.
The account is shared by 5 computers and all of them have the script running.
For some reason the script works fine several times but there is a moment that it stops working, i set a debug point in the script and aparentlly the script is not being executed. The rule dont show any error.
Sub sortingP8(Item As Outlook.MailItem)
Dim olkAtt As Outlook.Attachment
'Check each attachment
Dim totalSize As Double
Dim containsZip As Boolean
Dim wrongExt As Boolean
totalSize = 0
containsZip = False
wrongExt = False
somethingWrong = False
Set ns = Application.GetNamespace("MAPI")
Set nonIngFolder = ns.Folders("Pqweeeq#asdasd.es").Folders("Non-ingestible Items")
Set ingFolder = ns.Folders("Pqweeeq#asdasd.es").Folders("Ingestible Items")
Set zipFolder = ns.Folders("Pqweeeq#asdasd.es").Folders("ZIP files")
For Each olkAtt In Item.Attachments
Dim extension As String
extension = Right(LCase(olkAtt.FileName), 4)
'If the attachment's file name ends with .zip
totalSize = totalSize + olkAtt.Size
If extension <> ".ppt" And extension <> ".doc" And extension <> ".pdf" And extension <> ".jpg" And extension <> ".zip" Then
wrongExt = True
End If
If extension = ".zip" Then
containsZip = True
End If
Next
If (wrongExt = True Or totalSize > 10000000) Then
Item.Move nonIngFolder
somethingWrong = True
End If
If (containsZip = True And somethingWrong = False) Then
Item.Move zipFolder
somethingWrong = True
End If
If (somethingWrong = False) Then
Item.Move ingFolder
End If
Set olkAtt = Nothing
End Sub
Any idea how this is happening in every computer?
Did you have a chance to check out the Trust Center settings in Outlook? Is Outlook macro allowed to run?
Try to run the VBA sub against the incoming email message manually and debug the code in the step-by-step manner going through each line of code and see what happens there.
Finally, you may find the Getting Started with VBA in Outlook 2010 article helpful.
If the computer is left alone, the session disconnect timeout could be the culprit.
Related
I am coding a small VBA to show all attachments of an email in a list box.
The user can select attachments that should be removed from the email and stored on a target folder.
I am also adding a HTML file to the email that contains a list of all removed files (including a link to each file to the target folder).
I have a problem with images, because they can be
Attached as a normal file to the email
Embedded to the email body (like a company logo in the signature)
I want to show in my list box only those images, that are attached as files to the email.
Embedded mails should be ignored.
Sub SaveAttachment()
Dim myAttachments As Outlook.Attachments
Dim olMailItem As Outlook.MailItem
Dim lngAttachmentCount As Long
Dim Attachment_Filename As String
Select Case True
Case TypeOf Application.ActiveWindow Is Outlook.Inspector
Set olMailItem = Application.ActiveInspector.CurrentItem
Case Else
With Application.ActiveExplorer.Selection
If .Count Then Set olMailItem = .Item(1)
End With
If olMailItem Is Nothing Then Exit Sub
End Select
Set myAttachments = olMailItem.Attachments
If myAttachments.Count > 0 Then
For lngAttachmentCount = myAttachments.Count To 1 Step -1
'-------------------------------------------------------------------------
' Add the attachment to the list of attachments (form)
'-------------------------------------------------------------------------
Attachment_Filename = myAttachments(lngAttachmentCount).FileName
With UserForm1.lstAttachments
.AddItem (Attachment_Filename)
.List(lngAttachmentListPos, 1) = Attachment_Type_Text
.List(lngAttachmentListPos, 2) = FormatSize(myAttachments(lngAttachmentCount).Size) & " KB"
End With
Next lngAttachmentCount
End If
End Sub
I added only the relevant parts of the code, so I hope I have not forgotten anything.
At the moment I show all attachments (also embedded images).
How would I find out if an attachment is embedded?
I found a possible solution here:
Distinguish visible and invisible attachments with Outlook VBA
The source code provided is not working, it seems like the two URLs in line 2 and 3 no longer exist.
I'm not sure if this is a solution that is valid in all cases, but it works in my environment. That means "test it properly".
Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"
Function IsEmbedded(Att As Attachment) As Boolean
Dim PropAccessor As PropertyAccessor
Set PropAccessor = Att.PropertyAccessor
IsEmbedded = (PropAccessor.GetProperty(PR_ATTACH_CONTENT_ID) <> "")
End Function
Call it with
If IsEmbedded(myAttachments(lngAttachmentCount)) Then
...
End If
The cryptic url-looking constant is not a url, but a property identifier. You can find a list of them here: https://interoperability.blob.core.windows.net/files/MS-OXPROPS/%5bMS-OXPROPS%5d.pdf
That property is set to the url of the attachment if embedded. If not embedded, then it is empty.
In the Outlook object model it's very important to marshal your objects correctly. Leaving a PropertyAccessor hanging about is not good, so I would suggest a minor modification to the accepted answer as follows:
Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"
Function IsEmbedded(Att As Attachment) As Boolean
Dim PropAccessor As PropertyAccessor = Nothing
Try
PropAccessor = Att.PropertyAccessor
Return (PropAccessor.GetProperty(PR_ATTACH_CONTENT_ID) <> "")
Catch
Return False
Finally
If PropAccessor IsNot Nothing
Marshal.ReleaseCOMObject(PropAccessor)
End If
End Catch
End Function
With the help of the answer and comment from #DinahMoeHumm we went with this solution which seems to work:
Function outlook_att_IsEmbedded(Att As outlook.Attachment) As Boolean
Dim PropAccessor As outlook.PropertyAccessor
On Error GoTo outlook_att_IsEmbedded_error
outlook_att_IsEmbedded = False
Set PropAccessor = Att.PropertyAccessor
If PropAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x3712001E") <> "" Or _
PropAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x3713001E") <> "" Then
If PropAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x37140003") = 4 Then
outlook_att_IsEmbedded = True
End If
End If
outlook_att_IsEmbedded_exit:
Set PropAccessor = Nothing
Exit Function
outlook_att_IsEmbedded_error:
outlook_att_IsEmbedded = False
Resume outlook_att_IsEmbedded_exit
End Function
I don't know what the different probtags mean. Or what the 4 is. It seems like you could find a list of them here: https://interoperability.blob.core.windows.net/files/MS-OXPROPS/%5bMS-OXPROPS%5d.pdf (but I didn't)
The following code loops through a folder, creates email with attachment and saves to draft.
Public Sub saveFileTodownload()
Set draftItems = Outlook.Session.Folders("My Email").Folders("Drafts").Items
strFile = Dir("d:\ga\localsdk\")
Do While Len(strFile)
Debug.Print strFile
Set mail = draftItems.Add("IPM.NOTE")
mail.Subject = "1downloadme" & Count
mail.Attachments.Add ("d:\ga\localsdk\" & strFile)
mail.Save
strFile = Dir
Loop
End Sub
I need to wait until the attachment has completely uploaded then call Save.
Is there any way to wait until the attachment has uploaded.
Note: If I debug it and wait a minute after the Attachment.Add line, the attachment has uploaded and Save works.
MailItem.Attachments.Add is synchronous; by the time the call returns, the attachment is added to the message. What makes you believe this is not so?
user93865
I tested your code and it works for me(No error message). However, it will be gets stuck if there are lots of attachments upload.
You could try this code :
Public Sub saveFileTodownload()
Dim store As Outlook.store
Dim space As Outlook.NameSpace
Dim folder As Outlook.folder
Set space = Outlook.Application.GetNamespace("MAPI")
Set store = space.DefaultStore
Set folder = store.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderDrafts)
Set Item = folder.Items.Add("IPM.NOTE")
Item.Subject = "1downloadme"
Item.Body = "one"
Dim r As Long
r = 0
Do While r < 100
Item.Attachments.Add ("C:\Users\temp\Desktop\notes\abd.docx")
r = r + 1
Loop
'Item.Display
Item.Save
Item.Close
End Sub
I'm trying to delete those folders that are empty with a triple loop.
The order is:
1. Enter into the Main Folder.
2. Check the first encountered folder
3. Check the first subFolder of the main folder.
4. If that subFolder contains another folder, enter in this subSubFolder
5. If it is the last folder and doesn't contain anything, the program deletes it.
5.1 If the folder contains something (a file, excel, pdf, doesn't matter) just go to the next subSubFolder.
6. And goes on until there's no empty folders.
Basically the code must leave untouched the folders that contains a File.
But i don't know why the code doesn't continue and just stop without deleting the empty ones.
This is the Folder Structure:
Folder Path
And this is the code i'm using.:
Sub recursiveDeleting()
Dim sFldr As Object
Dim ssFldr As Object
Dim sssFldr As Object
Dim fs
Set fs = CreateObject("Scripting.FileSystemObject")
sFound = False
ssFound = False
sssFound = False
flPath = ActiveWorkbook.Path & "\"
YearPath = flPath & "2017\"
FARFIpath = YearPath & "\FAR_FI\"
For Each sFldr In CreateObject("Scripting.FileSystemobject").GetFolder(FARFIpath).SubFolders
For Each ssFldr In CreateObject("Scripting.FileSystemobject").GetFolder(sFldr).SubFolders
For Each sssFldr In CreateObject("Scripting.FileSystemobject").GetFolder(ssFldr).SubFolders
If Dir(sssFldr & "\*.*") = "" Then
RmDir (sssFldr)
Else
sssFound = True
End If
If sssFound = True Then
Exit For
End If
Next sssFldr
If fs.FolderExists(ssFldr) = "" Then
RmDir (ssFldr)
Else
ssFound = True
End If
If ssFound = True Then
Exit For
End If
Next ssFldr
If Dir(sFldr, vbDirectory) = "" Then
RmDir (sFldr)
sFound = True
End If
If sFound = True Then
Exit For
End If
Next sFldr
End Sub
Thanks for your time and have a good day!
Try below code, tested working (it will delete the root folder as well if it's empty afterwards. It can be mind blogging if you are to trace back the recursive code.
Sample - only a blank text file in highlighted folder (all others has no files).
Option Explicit
Private oFSO As Object
Sub DeleteEmptyFolder()
Dim oRootFDR As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oRootFDR = oFSO.GetFolder("C:\Test\mount") '<--- Change to your root folder
If DeleteEmptyFolderOnly(oRootFDR) Then
oRootFDR.Delete
End If
Set oRootFDR = Nothing
Set oFSO = Nothing
End Sub
Private Function DeleteEmptyFolderOnly(ByRef oFDR As Object) As Boolean
Dim bDeleteFolder As Boolean, oSubFDR As Object
bDeleteFolder = False
' Recurse into SubFolders
For Each oSubFDR In oFDR.SubFolders
If DeleteEmptyFolderOnly(oSubFDR) Then
Debug.Print "Delete", oSubFDR.Path ' Comment for production use
oSubFDR.Delete
End If
Next
' Mark ok to delete when no files and subfolders
If oFDR.Files.Count = 0 And oFDR.SubFolders.Count = 0 Then
bDeleteFolder = True
End If
DeleteEmptyFolderOnly = bDeleteFolder
End Function
After the code executed, Folders remained are:
And the immediate window shows the folders that are deleted:
I was trying to implement a script to move a specific mail to a new folder - no tough stuff.
It is scripted in Outlook 2013 and implemented as a rule on incoming mails. The code:
Public Sub MoveToFolder(Item As Outlook.MailItem)
'' ... variable definitions ...
Set oloUtlook = CreateObject("Outlook.Application")
Set ns = oloUtlook.GetNamespace("MAPI")
Set itm = ns.GetDefaultFolder(olFolderInbox)
Set foldd = ns.Folders.GetFirst.Folders
For x = 1 To foldd.Count
If foldd.Item(x).Name = "Inbox" Then
Set fold = foldd.Item(x).Folders
For i = 1 To fold.Count
If fold.Item(i).Name = "Reports" Then
If fold.Item(i).Folders.GetFirst.Name <> Format(Date, "yyyy-mm") Then
fold.Item(i).Folders.Add (Format(Date, "yyyy-mm"))
End If
Set newfold = fold.Item(i).Folders.GetFirst
MsgBox newfold.Name
Item.Copy (newFold)
''Item.Move (newfold)
End If
Next i
End If
Next x
End Sub
The message comes to folder Inbox, I'd like to move it to:
Reports -> 2013-XX depending on the current month.
MessageBox shows the correct folder name. but the message is copied to folder "Inbox" as a duplicate.
What am I doing wrong? Cheers.
I'm not sure why your method isn't working. When I run it in 2010, it gets the right folder. I'm not sure why you think the current date folder will always be the first folder, but I've never used GetFirst, so maybe I just don't understand it. Here's a more straightforward way to test and create a folder and it may work for you.
Public Sub MoveToFldr(Item As MailItem)
Dim oFldr As Folder
Dim fReports As Folder
Set fReports = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("Reports")
On Error Resume Next
Set oFldr = fReports.Folders(Format(Date, "yyyy-mm"))
On Error GoTo 0
If oFldr Is Nothing Then
Set oFldr = fReports.Folders.Add(Format(Date, "yyyy-mm"))
End If
Item.Move oFldr
End Sub
I have a vbs script which captures file information and then exports it to a csv file. I need to run the script on main drives such as C:\, E:\, I:\ and more, but each time I run for the main directory I get "Permission Denied" when I try to run it for a subfolder example C:\Program Files it works fine. I have tested this on different desktop machines and servers with full admin accounts and still get it.
What could be the issue with this code. test.vbs
Option Explicit
Dim objFS, objFld
Dim objArgs
Dim strFolder, strDestFile, blnRecursiveSearch
Dim strLines()
Dim i
Dim strCsv
i = 0
' 'Get the commandline parameters
' Set objArgs = WScript.Arguments
' strFolder = objArgs(0)
' strDestFile = objArgs(1)
' blnRecursiveSearch = objArgs(2)
'###################################
'MAKE SURE THESE VALUES ARE CORRECT
'###################################
strFolder = "C:\"
strDestFile = "C:\Output.csv"
blnRecursiveSearch = True
'Create the FileSystemObject
Set objFS=CreateObject("Scripting.FileSystemObject")
'Get the directory you are working in
Set objFld = objFS.GetFolder(strFolder)
'Now get the file details
GetFileDetails objFld, blnRecursiveSearch
'Write the csv file
Set strCsv = objFS.CreateTextFile(strDestFile, True)
strCsv.Write Join(strLines, vbCrLf)
'Close and cleanup objects
strCsv.Close
Set strCsv = Nothing
Set objFld = Nothing
Set strFolder = Nothing
Set objArgs = Nothing
Private Sub GetFileDetails(fold, blnRecursive)
Dim fld, fil
dim strLine(5)
If blnRecursive Then
'Work through all the folders and subfolders
For Each fld In fold.SubFolders
GetFileDetails fld, True
Next
End If
'Now work on the files
For Each fil in fold.Files
strLine(0) = fil.Path
strLine(1) = fil.Type
strLine(2) = fil.Size
strLine(3) = fil.DateCreated
strLine(4) = fil.DateLastModified
strLine(5) = fil.DateLastAccessed
Redim Preserve strLines(i)
strLines(i) = Join(strLine, ",")
i = i + 1
Next
end sub
Please advise and modify code if you know where the issue is.
If it's a permissions problem I would strongly recommend Process Monitor from Sysinternals to diagnose it. You should be able to watch the cscript process (or whatever is executing your script) and find out what kind of permission problem you're having.