our team has a shared mailbox in which we receive hundred of mails daily and we have to drag them manually from inbox into its separate sub-inboxes. So is there any rule or macro to drag them automatically.
VBS sample
Set objOutlook = GetObject (, "Outlook.Application")
Set objNamespace = objOutlook.GetNameSpace ("MAPI")
Set objFolderRoot = objNamespace.Folders ("Y2013")
Set objFolderSource = objFolderRoot.Folders ("Inbox")
Set objFolderDistance = objFolderRoot.Folders ("test")
MsgBox "Total emails is Inbox folder: " & objFolderSource.Items.Count
Set objEmail = objFolderSource.Items (1)
MsgBox "Subject of first email: " & objEmail.Subject
objEmail.Move objFolderDistance
Set objEmail = Nothing
Set objFolderDistance = Nothing
Set objFolderSource = Nothing
Set objFolderRoot = Nothing
Set objNamespace = Nothing
Set objOutlook = Nothing
Of course you MUST add object validation in this code.
You could also take a look to VBA (not VBS which you are using) sample on http://msdn.microsoft.com/en-us/library/office/ff860683.aspx
Related
Please help to automate the process which consists of 2 Subs:
Import - I need to make Silent import without target & destination folder selection dialog.
I need to import to my "INBOX/Imported" subfolder in Outlook and want to understand where in this code I can mention it explicitly.
I need to grab .EML files from the folder "D:\Emails" without redundant dialogue for folder selection:
Sub Redemp()
Dim objShell: Set objShell = CreateObject("Shell.Application")
Dim objFolder: Set objFolder = objShell.BrowseForFolder(0, "Select the folder containing eml-files", 0)
Dim Item
If (Not objFolder Is Nothing) Then
Set WShell = CreateObject("WScript.Shell")
Set objOutlook = CreateObject("Outlook.Application")
Set Folder = objOutlook.Session.PickFolder
If Not Folder Is Nothing Then
For Each Item In objFolder.Items
If Right(Item.name, 4) = ".eml" And Item.IsFolder = False Then
Set objPost = Folder.Items.Add(6)
Set objSafePost = CreateObject("Redemption.SafePostItem")
objSafePost.Item = objPost
objSafePost.Import Item.Path, 1024
objSafePost.MessageClass = "IPM.Note"
' remove IPM.Post icon
Set utils = CreateObject("Redemption.MAPIUtils")
PrIconIndex = &H10800003
utils.HrSetOneProp objSafePost, PrIconIndex, 256, True 'Also saves the message
End If
Next
End If
End If
MsgBox "Import completed.", 64, "Import EML"
Set objFolder = Nothing
Set objShell = Nothing
End Sub
Also, it would be great to avoid imported messages appearing in Outlook as if I already started replying to (not very convenient). If I use the above code and select imported message it doesn't look like originally received, but rather looks like text that I reply to.
I need to unify the below code that corrects ReceivedTime property of imported message (or it can modify EML file before import, sequence of actions is not important) with above import procedure.
Sub Redemp_sentreceived()
Set rSession = CreateObject("Redemption.RDOSession")
rSession.MAPIOBJECT = Application.Session.MAPIOBJECT
Set Msg = rSession.GetRDOObjectFromOutlookObject(Application.ActiveExplorer.CurrentFolder)
For Each Item In Msg.Items
Item.ReceivedTime = Item.SentOn
Item.Save
Next
End Sub
Ultimately imported .EML files should be in target folder with correct ReceivedTime.
Many thanks for helping me out in advance!
There is really no reason to use Safe*Item objects in this case - use RDOSession object, set the MAPIOBJECT property just like you do in the second example.
Off the top of my head:
Set rSession = CreateObject("Redemption.RDOSession")
rSession.MAPIOBJECT = Application.Session.MAPIOBJECT
Set folder = rSession.GetDefaultFolder(plFolderInbox).Folders.Items("Imported")
Set fileFolder = objFSO.GetFolder("D:\Emails")
For Each objFile in fileFolder.Files
set msg = folder.Items.Add("IPM.Note")
msg.Sent = true
msg.Import objFile.Path, 1031
msg.Save
Next
The problem was in number pointed in Import (I changed 1031 -> 1024) and now it works like a charm!
Sub MailImport()
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set rSession = CreateObject("Redemption.RDOSession")
rSession.MAPIOBJECT = Application.Session.MAPIOBJECT
Set Folder = rSession.GetDefaultFolder(olFolderInbox)
Set fileFolder = objFSO.GetFolder("D:\Emails")
For Each objFile In fileFolder.Files
Set msg = Folder.Items.Add("IPM.Note")
msg.sent = True
msg.Import objFile.Path, 1024
msg.ReceivedTime = msg.SentOn
msg.Save
objFile.Delete
Next
Set objFSO = Nothing
End Sub
This question already has answers here:
VBScript to send email without running Outlook
(2 answers)
Closed 3 years ago.
I want to select files within Windows Explorer and then by pressing a shortcut (assigned to a VBS-script) to send these files with Outlook (2010).
I found two working code snippets:
Code snippet1 (Creating Email):
Dim objOutl
Set objOutl = CreateObject("Outlook.Application")
Set objMailItem = objOutl.CreateItem(olMailItem)
'comment the next line if you do not want to see the outlook window
objMailItem.Display
strEmailAddr = "test#test.com"
objMailItem.Recipients.Add strEmailAddr
objMailItem.Body = "Hi, this is the body.."
objMailItem.Attachments.Add "C:\test.txt"
'objMailItem.Send
Set objMailItem = nothing
Set objOutl = nothing
Code snippet2 (returning paths of the selected files in Windows Explorer):
Function GetSelectedFiles() 'Returns paths as array of strings
Dim FileList, Window, SelectedItem
'avoid duplicates by storing paths in dictionary keys
Set FileList = CreateObject("Scripting.Dictionary")
With CreateObject("Shell.Application")
For Each Window In .Windows
'skip IE Windows
If InStr(1, Window.FullName, "iexplore.exe", vbTextCompare) = 0 Then
For Each SelectedItem In Window.Document.SelectedItems
FileList(SelectedItem.Path) = Null
'MsgBox SelectedItem.Path
Next
End If
Next
End With
GetSelectedFiles = FileList.Keys 'array of paths
End Function
MsgBox "Click OK after selecting the items", vbOKOnly Or vbInformation, "Select a few items"
Dim SelectedFiles
SelectedFiles = GetSelectedFiles
MsgBox "You selected: " & vbNewLine & vbNewLine & Join(SelectedFiles, vbNewLine), vbOKOnly Or vbInformation, "Selected Items"
How to combine these code snippets to achieve my purpose? I tried to give the SelectedItem.Path a variable to add it to the objMailItem.Attachments.Add but it is not working.
I tried the cdo approach but this issue seems to be more complex. I have an office365-account and the configuration settings seems to differ from VBScript to send email without running Outlook.
Yesss I got it working and it is very cool, I love it :-)
Dim x ,objOutl ,objMailItem ,strEmailAddr
Set objOutl = CreateObject("Outlook.Application")
Set objMailItem = objOutl.CreateItem(olMailItem)
'comment the next line if you do not want to see the outlook window
objMailItem.Display
strEmailAddr = "test#test.com"
objMailItem.Recipients.Add strEmailAddr
objMailItem.Subject = "Test"
objMailItem.Body = "Hi, this is the body.."
'in the next line it will jump in to function "GetSelectedFiles"
x=GetSelectedFiles
'comment out the next three lines for sending directly..
'objMailItem.Send
'Set objMailItem = nothing
'Set objOutl = nothing
Function GetSelectedFiles() 'Returns paths as array of strings
Dim FileList, Window, SelectedItem
'avoid duplicates by storing paths in dictionary keys
Set FileList = CreateObject("Scripting.Dictionary")
With CreateObject("Shell.Application")
For Each Window In .Windows
'skip IE Windows
If InStr(1, Window.FullName, "iexplore.exe", vbTextCompare) = 0 Then
For Each SelectedItem In Window.Document.SelectedItems
FileList(SelectedItem.Path) = Null
x = SelectedItem.Path
'next line is just for debugging..
'msgBox x
'The next line was the solution
objMailItem.Attachments.Add x
Next
End If
Next
End With
GetSelectedFiles = x 'array of paths
End Function
I have a VBScript which opens Outlook 2016 and sends a message.
The problem I have is that I have several Outlook profiles.
I would like to set the actual profile I wish to open from which to send the message.
My existing script is:
Dim objOutlook, objEmail
Dim strEmailReceiver, strEmailCc, strEmailBcc, strEmailSubject, strEmailBody, strEmailAttachments
Set objOutlook = CreateObject("Outlook.Application")
Set objEmail = objOutlook.CreateItem(0)
strEmailSubject=InPutBox("Input your message")
With objEmail
.To = "here#there.com"
' .Cc = strEmailCc
' .Bcc = strEmailBcc
.Subject = strEmailSubject
' .Body = strEmailBody
' If (strEmailAttachments <> "") Then
' .Attachments.Add strEmailAttachments
' End If
.Send
End With
'Clear the memory
Set objOutlook = Nothing
Set objEmail = Nothing
I wish to use the profile called CEO
If outlook is closed, I get a messagebox asking which profile to use, once selected the script works. This is the step I wish to avoid.
Immediately after creating an instance of the Outlook.Application object, add code like the following
Set objOutlook = CreateObject("Outlook.Application")
set objNS = objOutlook.GetNamespace("MAPI")
objNS.Logon("The Profile name")
Set objEmail = objOutlook.CreateItem(0)
keep in mind that if Outlook is already running, Namespace.Logon will do nothing and you will end up with the running instance of Outlook (since it is a singleton) using whatever profile it was using at the moment
Here is the code I have so far:
Option Explicit
Call OpenOutlook()
Function OpenOutlook()
Dim ObjShell
Set ObjShell = CreateObject("WScript.Shell")
ObjShell.Run("Outlook.exe")
Call SendEmail()
'I tried closing from here but this didn't work either
'ObjShell.Quit
End Function
Function SendEmail()
'Declaring variables used through out this function
Dim ObjOutlook
Dim objMail
Set ObjOutlook = CreateObject("Outlook.Application")
'CreateItem(0) opens a New Email window...MailItem
set objMail = ObjOutlook.CreateItem(0)
objMail.Display
'MailItem Options
objMail.to = "test#mail.com.com"
'objMail.cc = "test2#mail.com"
objMail.Subject = "Did it work!?"
objMail.Body = "If you got this email, my VBs test worked!"
'objMail.Attachments.Add("C:\Attachment\abc.jpg")
objMail.Send
'This didn't work either
'If objMail.Sent = True Then
'ObjOutlook.Quit
'End If
'Quit closes Outlook like I want but it doesn't wait for the email to send
'ObjOutlook.Quit
End Function
What I'm trying to automate using VBScript:
Open Outlook
Send an email
Wait for email to send (Outbox to finish sending)
Close Outlook AFTER the email has been sent
Where I'm stuck:
First of all, I was having trouble opening Outlook. Below is the code that I used to create an Outlook Object:
Set ObjOutlook = CreateObject("Outlook.Application")
'CreateItem(0) opens a New Email window...MailItem
set objMail = ObjOutlook.CreateItem(0)
objMail.Display
What I did (Not even sure if this is the right way to do it):
Set ObjShell = CreateObject("WScript.Shell")
ObjShell.Run("Outlook.exe")
Why can't I just do ObjShell.Quit after I call the SendEmail() Function? Using .Quit gives me an error.
I just want to close the Outlook application once the email has been sent and I can't figure out how.
MailItem has a Sent property that indicates when the message has been sent. Try this:
...
objMail.Send
Do Until objMail.Sent
WScript.Sleep 500
Loop
' Safe to close...
ObjOutlook.Quit
Try this:
Option Explicit
Sub SendMail()
Dim outobj, mailobj
Set outobj = CreateObject("Outlook.Application")
Set mailobj = outobj.CreateItem(0)
With mailobj
.To = "user#test.com"
.Subject = "Testmail"
.Body = "If you got this email, my VBs test worked!"
.Send
End With
'Clear the memory
Set outobj = Nothing
Set mailobj = Nothing
End Sub
SendMail()
Msgbox("Done")
Firstly, what if it was the user who opened Outlook? I don't think any user will appreciate your code closing Outlook. You might want to check that both Application.Explorers.Count and Application.Inspectors.Count are zero before closing Outlook. Newest version of Outlook will automatically exist if there are no open explorers or inspectors even if you hold a reference to an Outlook object - that was done to guard ageist misbehaving apps that leaked references. To prevent Outlook from closing, hodl a reference to an Explorer object t(even if you do not show it) - call Namespace.getDefaultFolder(olFolderInbox), then hold a reference to the object returned by MAPIFolder.GetExplorer .
Secondly, after calling Send, use Namespace,SyncObjects collection to retrieve the very first SyncObject. Hook up the SyncObject.SyncEnd event and call SyncObject.Start. When SyncEnd event fires, you will be all done. But I don't think you can work with events in VB script...
Please advice how to get the following
From Microsoft outlook
Type SOMETHING in the “search address books”
Click properties
In the Members list we see all the members names
The target is to print all the members names to a file.
How to do this task with VB script or with any other Code?
example:
I found this, but I not understand how to set my distribution list in the VB code to print the distribution list members
For example If I have the distribution list MY_HOME
how do I insert the MY_HOME in the VB code to print all members?
Const olFolderContacts = 10
Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set colContacts = objNamespace.GetDefaultFolder(olFolderContacts).Items
intCount = colContacts.Count
For i = 1 To intCount
If TypeName(colContacts.Item(1)) = "DistListItem" Then
Set objDistList = colContacts.Item(i)
Wscript.Echo objDistList.DLName
For j = 1 To objDistList.MemberCount
Wscript.Echo objDistList.GetMember(j).Name & " -- " & _
objDistList.GetMember(j).Address
Next
Wscript.Echo
End If
Next
Call Namespace.CreateRecipient / Recipient.Resolve / Recipient.AddressEntry.Members.
UPDATE:
Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
objNamespace.Logon
set objRecip = objNamespace.CreateRecipient("MY_HOME")
if objRecip.Resolve Then
set objMembers = objRecip.AddressEntry.Members
if not (objMembers Is Nothing) Then
for each objMember in objMembers
Wscript.Echo objMember.Name & " : " & objMember.Address
next
end If
End If