I am trying to automate sending an email and copy the meeting organizer through an Outlook VBA macro. My company is using Office 365.
I am using the item.GetOrganizer element to get the organizer's name.
Debug.Print oItem.GetOrganizer.Address gives:
/o=ExchangeLabs/ou=Exchange Administrative Group (FYDIBOHF23SPDLT)/cn=Recipients/cn=c035bc5647d64d89aecbc6d3ddb5580b-Name
How do I get the email address?
Example
Option Explicit
Private Function GetMeetingOrganizer( _
ByVal appt As Outlook.AppointmentItem) As Outlook.AddressEntry
If appt Is Nothing Then Exit Function
Dim PR_SENT_REPRESENTING_ENTRYID As String
PR_SENT_REPRESENTING_ENTRYID = _
"http://schemas.microsoft.com/mapi/proptag/0x00410102"
Dim organizerEntryID As String
organizerEntryID = _
appt.PropertyAccessor.BinaryToString( _
appt.PropertyAccessor.GetProperty(PR_SENT_REPRESENTING_ENTRYID))
Dim organizer As Outlook.AddressEntry
Set organizer = Application.Session.GetAddressEntryFromID(organizerEntryID)
If organizer Is Nothing Then
Debug.Print "No organizer" ' Print on Immediate Window
Else
Debug.Print organizer ' Print on Immediate Window
Dim Email_Address As String
If organizer.Type = "SMTP" Then
Email_Address = organizer.Address
Else
If organizer.Type = "EX" Then
Email_Address = organizer.GetExchangeUser.PrimarySmtpAddress
End If
End If
Debug.Print Email_Address ' Print on Immediate Window
End If
End Function
Private Sub Example()
Dim Item As Object
Set Item = ActiveExplorer.Selection.Item(1)
Debug.Print TypeName(Item)
GetMeetingOrganizer Item
End Sub
Function GetOrganizerEmail(ApptItem As Outlook.AppointmentItem) As String
Dim organizer As Outlook.AddressEntry
Set org = ApptItem.GetOrganizer
If org.Type = "SMTP" Then
GetOrganizerEmail = org.Address
ElseIf org.Type = "EX" Then
GetOrganizerEmail = org.GetExchangeUser.PrimarySmtpAddress
End If
End Function
Related
I track POD's Online. I do it from behind a proxy and use Microsoft Access in a query to execute the function to download the tracking information and parse it out. The base code is below. The function I use is TrackNew(trackingNumber). Each morning when I run this access.exe is asking for my credentials. I track from UPS and FedEx xml gateways and it doesn't ask for the proxy credentials. Is there a way that I can add the credentials inside my code so it doesn't prompt for this?
Here at the top is everything that makes this work. At the bottom is the actual function.
Private Enum HTTPequestType
HTTP_GET
HTTP_POST
HTTP_HEAD
End Enum
#If VBA7 Then
' 64-bit
Private Declare PtrSafe Function InternetGetConnectedState Lib "wininet"
(ByRef dwflags As LongPtr, _
ByVal dwReserved As Long) As Long
#Else
' pre 64-bit
Private Declare PtrSafe Function InternetGetConnectedState Lib "wininet"
(ByRef dwflags As Long, _
ByVal
dwReserved As Long) As Long
#End If
Private Const CONNECT_LAN As Long = &H2
Private Const CONNECT_MODEM As Long = &H1
Private Const CONNECT_PROXY As Long = &H4
Private Const CONNECT_OFFLINE As Long = &H20
Private Const CONNECT_CONFIGURED As Long = &H40
' Application Objects
Private xl As Access.Application
' misc symbols
Private Const CHAR_SPACE As String = " "
Private Const CHAR_UNDERSCORE As String = "_"
Private Const CHAR_COMMA As String = ","
Private Const CHAR_SLASH As String = "/"
Private Const AT_SYMBOL As String = "#"
' list of carriers (must be UPPER CASE, comma-delimited)
Private Const CARRIER_LIST As String =
"UPS,UPS1,UPS2,UPS3,UPS4,UPS5,UPS6,UPS7,UPS8,NEW,DHL,DHL1,FEDEX,FEDEX2,FEDEX3,FEDEX4,FEDEX5,HOLLAND,CONWAY,ABF,CEVA,USPS,TNT,YRCREGIONAL,YRC,NEMF,A1,RWORLDCOURIER,BLUEDART,TCIXPS,PUROLATOR,EXPINT,CMACGM,SAFM,PLG,DHL,ONTRAC,AAACT,RLC,ODFL,SAIA,DHLGLOBAL,LASERSHIP"
' MSXML stuff
Private Const MSXML_VERSION As String = "6.0"
' error Msgs
Private Const UNKNOWN_CARRIER As String = "Unknown carrier"
Private Const ERROR_MSG As String = "Error"
Private Const PACKAGE_NOT_FOUND As String = "Package Not Found"
Private Const MSIE_ERROR As String = "Cannot start Internet Explorer."
Private Const MSXML_ERROR As String = "Cannot start MSXML 6.0."
Private Const MSHTML_ERROR As String = "Cannot load MSHTML Object library."
' URLs for each carrier
Private Const NEWUrl As String = "https://www.newpenn.com/embeddable-tracking-results/?track="
'
' system functions
'
Private Function GetAppTitle() As String
GetAppTitle = App.Title & " " & App.Major & "." & App.Minor & "." & App.Revision
End Function
Private Function IsWindowsOS() As Boolean
' true if operating system is Windows
IsWindowsOS = (GetWindowsOS Like "*Win*")
End Function
'
' required addin procedures
'
Private Sub AddinInstance_OnAddInsUpdate(custom() As Variant)
' needed for operation
Exit Sub
End Sub
Private Sub AddinInstance_OnStartupComplete(custom() As Variant)
' needed for operation
Exit Sub
End Sub
' helper functions
Private Function GetRequestType(reqType As HTTPequestType) As String
Select Case reqType
Case 1
GetRequestType = "POST"
Case 2
GetRequestType = "HEAD"
Case Else ' GET is default
GetRequestType = "GET"
End Select
End Function
Private Function IsValidCarrier(CarrierName As String) As Boolean
' returns TRUE if the given carrier is on the global list
Dim carriers() As String
carriers = Split(CARRIER_LIST, ",")
IsValidCarrier = (UBound(Filter(carriers, CarrierName)) > -1)
End Function
Private Function GetHTMLAnchors(htmlDoc As Object) As Object ' MSHTML.IHTMLElementCollection
On Error Resume Next
Set GetHTMLAnchors = htmlDoc.anchors
End Function
Private Function LoadError(xmlDoc As Object) As Boolean
' checks if a xml file load error occurred
LoadError = (xmlDoc.parseError.ErrorCode <> 0)
End Function
Private Function GetRootNode(xmlDoc As Object) As Object
' returns root node
Set GetRootNode = xmlDoc.DocumentElement
End Function
Private Function GetNode(parentNode As Object, nodeNumber As Long) As Object
On Error Resume Next
' if parentNode is a MSXML2.IXMLDOMNodeList
Set GetNode = parentNode.Item(nodeNumber - 1)
' if parentNode is a MSXML2.IXMLDOMNode
If GetNode Is Nothing Then
Set GetNode = parentNode.ChildNodes(nodeNumber - 1)
End If
End Function
Private Function CreateFile(fileName As String, contents As String) As String
' creates file from string contents
Dim TempFile As String
Dim nextFileNum As Long
nextFileNum = FreeFile
TempFile = fileName
Open TempFile For Output As #nextFileNum
Print #nextFileNum, contents
Close #nextFileNum
CreateFile = TempFile
End Function
Here is where it prompts me for the windows domain credentials for the proxy.
Private Function GetResponse(xml As Object, requestType As HTTPequestType, _
destinationURL As String, Optional async As Boolean, _
Optional requestHeaders As Variant, Optional postContent As String) As String
Dim reqType As String
Dim response As String
Dim i As Long
reqType = GetRequestType(requestType)
With xml
.Open reqType, destinationURL, async
' check for headers
If Not IsMissing(requestHeaders) Then
For i = LBound(requestHeaders) To UBound(requestHeaders)
.setRequestHeader requestHeaders(i, 1), requestHeaders(i, 2)
Next i
End If
' if HTTP POST, need to send contents
' will not harm GET or HEAD requests
.Send (postContent)
' if HEAD request, return headers, not response
If reqType = "HEAD" Then
response = xml.getAllResponseHeaders
Else
response = xml.responseText
End If
End With
GetResponse = response
End Function
Private Function GetRequestHeaders() As Variant
Dim tempArray(1 To 1, 1 To 2) As Variant
tempArray(1, 1) = "Content-Type"
tempArray(1, 2) = "application/x-www-form-urlencoded"
GetRequestHeaders = tempArray
End Function
' major objects
Private Function GetMSIE() As Object ' InternetExplorer.Application
On Error Resume Next
Set GetMSIE = CreateObject("InternetExplorer.Application")
End Function
Private Function CreateHTMLDoc() As Object ' MSHTML.HTMLDocument
On Error Resume Next
Set CreateHTMLDoc = CreateObject("htmlfile")
End Function
Private Function GetMSXML() As Object ' MSXML2.XMLHTTP60
On Error Resume Next
Set GetMSXML = CreateObject("MSXML2.XMLHTTP" & IIf(Len(MSXML_VERSION) = 0, "", "." & MSXML_VERSION))
End Function
Private Function GetServerMSXML() As Object
On Error Resume Next
Set GetServerMSXML = CreateObject("MSXML2.ServerXMLHTTP" &
IIf(Len(MSXML_VERSION) = 0, "", "." & MSXML_VERSION))
End Function
Private Function CreateXMLDoc() As Object ' MSXML2.DOMDocument60
On Error Resume Next
Set CreateXMLDoc = CreateObject("MSXML2.DOMDocument" & IIf(Len(MSXML_VERSION) = 0, "", "." & MSXML_VERSION))
End Function
' XMLHTTP or MSIE
'''''Private Function GetMSXMLWebResponse(URL As String) As String
''''' Dim webObject As Object ' MSXML2.XMLHTTP60
''''' Set webObject = GetMSXML
''''' If webObject Is Nothing Then ' cannot start MSXML6
''''' Exit Function
''''' End If
''''' ' open URL and scrape result
''''' With webObject
''''' .Open "GET", URL, False
''''' .send
''''' End With
''''' GetMSXMLWebResponse = webObject.responseText
'''''End Function
Private Function GetMSIEWebResponse(URL As String) As String
Dim webObject As Object ' InternetExplorer.Application
Set webObject = GetMSIE
If webObject Is Nothing Then ' cannot start MSIE
Exit Function
End If
'open the url
webObject.navigate URL
'wait for the site to be ready
Do Until webObject.readyState = 4 ' READYSTATE_COMPLETE
DoEvents
Loop
'read the text from the body of the site
GetMSIEWebResponse = webObject.Document.body.innerText
webObject.Quit
End Function
Here is the actual tracking code:
Private Function TrackNEW(trackingNumber As String) As String
Dim xml As Object
Dim tempString As String
Dim htmlDoc As Object ' MSHTML.HTMLDocument
Dim htmlBody As Object ' MSHTML.htmlBody
Dim anchors As Object ' MSHTML.IHTMLElementCollection
Dim anchor As Object ' MSHTML.IHTMLElement
Dim dda As Object ' MSHTML.IHTMLElementCollection
Dim ddb As Object
Dim ddc As Object
Dim ddd As Object
Dim span As Object
Dim div As Object
Dim class As Object ' MSHTML.IHTMLElement
Set xml = GetMSXML
If xml Is Nothing Then ' cannot start MSXML 6.0
TrackNEW = MSXML_ERROR
Exit Function
End If
tempString = GetResponse(xml, HTTP_GET, NEWUrl & trackingNumber, False)
If Len(tempString) = 0 Then
MsgBox "5"
TrackNEW = ERROR_MSG
Exit Function
End If
Set htmlDoc = CreateHTMLDoc
If htmlDoc Is Nothing Then ' cannot reference MSHTML object library
MsgBox "6"
TrackNEW = MSHTML_ERROR
Exit Function
End If
On Error Resume Next
Set htmlBody = htmlDoc.body
htmlBody.innerHTML = tempString
Set dda = htmlDoc.getElementsByTagName("span")
Set ddb = htmlDoc.getElementsByTagName("span")
Set ddc = htmlDoc.getElementsByTagName("span")
Set ddd = htmlDoc.getElementsByTagName("div")
Item = 1
For Each Strg4 In ddd
For ItemNumber4 = 400 To 450
Strg4 = ddd.Item(ItemNumber4).innerText
If InStr(Strg4, "Projected Delivery Date") >= 1 Then
Why = ItemNumber4
Strg4 = ddd.Item(Why).innerText
GoTo Line8
Else
End If
Next ItemNumber4
Next Strg4
GoTo Line9
Exit Function
Line8:
TrackNEW = "INTRANSIT" & "|" & Right(Strg4, 11)
Exit Function
Line9:
Item = 1
For Each Strg In dda
For ItemNumber = 160 To 200
Strg = dda.Item(ItemNumber).innerText
If InStr(Strg, "DELIVERED") >= 1 Then
That = ItemNumber
Strg = dda.Item(That).innerText
GoTo Line2
Else
End If
Next ItemNumber
Next Strg
GoTo Line1
Line2:
Item2 = 1
For Each Strg2 In ddb
For ItemNumber2 = 160 To 200
Strg2 = ddb.Item(ItemNumber2).innerText
If InStr(Strg2, "DELIVERED") >= 1 Then
This = ItemNumber2 + 3
Strg2 = ddb.Item(This).innerText
GoTo Line3
Else
End If
Next ItemNumber2
Next Strg2
GoTo Line1
Line3:
Item3 = 1
For Each Strg3 In ddb
For ItemNumber3 = 160 To 200
Strg3 = ddb.Item(ItemNumber3).innerText
If InStr(Strg3, "DELIVERED") >= 1 Then
How = ItemNumber3 + 5
Strg3 = ddc.Item(How).innerText
GoTo Line4
Else
End If
Next ItemNumber3
Next Strg3
GoTo Line1
Line4:
TrackNEW = Strg & "|" & Strg2 & "|" & Strg3
Set xml = Nothing
Set htmlDoc = Nothing ' MSHTML.HTMLDocument
Set htmlBody = Nothing ' MSHTML.htmlBody
Set anchors = Nothing ' MSHTML.IHTMLElementCollection
Set anchor = Nothing ' MSHTML.IHTMLElement
Set dda = Nothing
Exit Function
Line1:
TrackNEW = "TRACKING|CANNOT|BE|FOUND"
Set xml = Nothing
Set htmlDoc = Nothing ' MSHTML.HTMLDocument
Set htmlBody = Nothing ' MSHTML.htmlBody
Set anchors = Nothing ' MSHTML.IHTMLElementCollection
Set anchor = Nothing ' MSHTML.IHTMLElement
Set dda = Nothing
Exit Function
End Function
Any help would be appreciated. I need the actual lines of code or reference that would get around it from prompting me for the windows credentials the proxy.
I found this snippet of code. Under the GETMSXML i could add this?
'Set GetMSXML = CreateObject("MSXML2.ServerXMLHTTP" & IIf(Len(MSXML_VERSION) = 0, "", "." & MSXML_VERSION))
'xmlhttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
'GetMSXML.setProxy 2, "proxy.website.com:8080"
'GetMSXML.setProxyCredentials "user", "password"
I want to perform the equivalent actions of:
Power Pivot > Tables > Update All
Pivot Table Tools > Data > Refresh All
using VBA. All the tables are Excel tables contained within the file.
Is there a simple way to do this in Excel 2010?
For Pivot Tables update, this code will work smoothly :
ThisWorkbook.RefreshAll
Or, if your Excel version is too old :
Dim Sheet as WorkSheet, _
Pivot as PivotTable
For Each Sheet in ThisWorkbook.WorkSheets
For Each Pivot in Sheet.PivotTables
Pivot.RefreshTable
Pivot.Update
Next Sheet
Next Pivot
In Excel 2013, to refresh PowerPivot, it is a simple line ActiveWorkbook.Model.Refresh.
In Excel 2010, ... It is FAR more complicated! Here is the general code made by Tom Gleeson :
' ==================================================
' Test PowerPivot Refresh
' Developed By: Tom http://www.tomgleeson.ie
' Based on ideas by Marco Rosso, Chris Webb and Mark Stacey
' Dedicated to Bob Phillips a most impatient man ...
' Sep 2011
'
' =======================================================
Option Explicit
#If Win64 Then
Public Declare PtrSafe Sub Sleep Lib "Kernel32" (ByVal dwMilliseconds As Long)
#Else
Public Declare Sub Sleep Lib "Kernel32" (ByVal dwMilliseconds As Long)
#End If
Sub Refresh()
Dim lDatabaseID As String
Dim lDimensionID As String
Dim lTable As String
Dim RS As Object 'ADODB.Recordset
Dim cnn As Object 'ADODB.Connection
Dim mdx As String
Dim xmla As String
Dim cnnName As String
Dim lSPID As String
Dim lArray
Dim i As Long
On Error Resume Next
' For Excel 2013+ use connection name e.g. "Text InvoiceHeaders"
' Fr Excel 2010 use table name e.g. "InvoiceHeaders"
lTable = [TableToRefresh]
On Error GoTo 0
' if Excel 2013 onwards: use Connections or Model refresh option via Object Model
If Application.Version() > 14 Then
' "wake up" model
ActiveWorkbook.Model.Initialize
If lTable <> "" Then
ActiveWorkbook.Connections(lTable).Refresh
Else
ActiveWorkbook.Model.Refresh
End If
' For Excel 2013 that's all folks.
Exit Sub
End If
cnnName = "PowerPivot Data"
'1st "wake up" default PowerPivot Connection
ActiveWorkbook.Connections(cnnName).Refresh
'2nd fetch that ADO connection
Set cnn = ActiveWorkbook.Connections(cnnName).OLEDBConnection.ADOConnection
Set RS = CreateObject("ADODB.Recordset")
' then fetch the dimension ID if a single table specified
' FIX: need to exclude all rows where 2nd char = "$"
mdx = "select table_id,rows_count from $System.discover_storage_tables where not mid(table_id,2,1) = '$' and not dimension_name = table_id and dimension_name='<<<<TABLE_ID>>>>'"
If lTable <> "" Then
mdx = Replace(mdx, "<<<<TABLE_ID>>>>", lTable)
RS.Open mdx, cnn
lDimensionID = fetchDIM(RS)
RS.Close
If lDimensionID = "" Then
lDimensionID = lTable
End If
End If
' then fetch a valid SPID for this workbook
mdx = "select session_spid from $system.discover_sessions"
RS.Open mdx, cnn
lSPID = fetchSPID(RS)
If lSPID = "" Then
MsgBox "Something wrong - cannot locate a SPID !"
Exit Sub
End If
RS.Close
'Next get the current DatabaseID - changes each time the workbook is loaded
mdx = "select distinct object_parent_path,object_id from $system.discover_object_activity"
RS.Open mdx, cnn
lArray = Split(lSPID, ",")
For i = 0 To UBound(lArray)
lDatabaseID = fetchDatabaseID(RS, CStr(lArray(i)))
If lDatabaseID <> "" Then
Exit For
End If
Next i
If lDatabaseID = "" Then
MsgBox "Something wrong - cannot locate DatabaseID - refesh PowerPivot connnection and try again !"
Exit Sub
End If
RS.Close
'msgbox lDatabaseID
If doXMLA(cnn, lDatabaseID, lDimensionID) = "OK" Then
Sleep 1000
' refresh connections and any related PTs ...
ActiveWorkbook.Connections(cnnName).Refresh
End If
End Sub
Private Function doXMLA(cnn, databaseID As String, Optional dimensionID As String = "", Optional timeout As Long = 30)
Dim xmla As String
Dim lRet
Dim comm As Object ' ADODB.Command
' The XMLA Batch request
If dimensionID = "" Then
xmla = "<Batch xmlns=""http://schemas.microsoft.com/analysisservices/2003/engine""><Parallel><Process xmlns:xsd=""http://www.w3.org/2001/XMLSchema"" xmlns:xsi=""http://www.w3.org/2001/XMLSchema-instance"" xmlns:ddl2=""http://schemas.microsoft.com/analysisservices/2003/engine/2"" xmlns:ddl2_2=""http://schemas.microsoft.com/analysisservices/2003/engine/2/2"" xmlns:ddl100_100=""http://schemas.microsoft.com/analysisservices/2008/engine/100/100""><Object><DatabaseID><<<DatabaseID>>></DatabaseID></Object><Type>ProcessFull</Type><WriteBackTableCreation>UseExisting</WriteBackTableCreation></Process></Parallel></Batch>"
xmla = Replace(xmla, "<<<DatabaseID>>>", databaseID)
Else
xmla = "<Batch xmlns=""http://schemas.microsoft.com/analysisservices/2003/engine""><Parallel><Process xmlns:xsd=""http://www.w3.org/2001/XMLSchema"" xmlns:xsi=""http://www.w3.org/2001/XMLSchema-instance"" xmlns:ddl2=""http://schemas.microsoft.com/analysisservices/2003/engine/2"" xmlns:ddl2_2=""http://schemas.microsoft.com/analysisservices/2003/engine/2/2"" xmlns:ddl100_100=""http://schemas.microsoft.com/analysisservices/2008/engine/100/100""><Object><DatabaseID><<<DatabaseID>>></DatabaseID><DimensionID><<<DimensionID>>></DimensionID></Object><Type>ProcessFull</Type><WriteBackTableCreation>UseExisting</WriteBackTableCreation></Process></Parallel></Batch>"
xmla = Replace(xmla, "<<<DatabaseID>>>", databaseID)
xmla = Replace(xmla, "<<<DimensionID>>>", dimensionID)
End If
Set comm = CreateObject("ADODB.command")
comm.CommandTimeout = timeout
comm.CommandText = xmla
Set comm.ActiveConnection = cnn
comm.Execute
' Make the request
'On Error Resume Next - comment out on error as most are not trappable within VBA !!!
'lRet = cnn.Execute(xmla)
'If Err Then Stop
doXMLA = "OK"
End Function
Private Function fetchDatabaseID(ByVal inRS As Object, SPID As String) As String
Dim i As Long
Dim useThis As Boolean
Dim lArray
Dim lSID As String
lSID = "Global.Sessions.SPID_" & SPID
Do While Not inRS.EOF
'Debug.Print inRS.Fields(0)
If CStr(inRS.Fields(0)) = lSID Then
lArray = Split(CStr(inRS.Fields(1)), ".")
On Error Resume Next
If UBound(lArray) > 2 Then
' find database permission activity for this SPID to fetch DatabaseID
If lArray(0) = "Permissions" And lArray(2) = "Databases" Then
fetchDatabaseID = CStr(lArray(3))
Exit Function
End If
End If
End If
On Error GoTo 0
inRS.MoveNext
Loop
inRS.MoveFirst
fetchDatabaseID = ""
End Function
Private Function fetchSPID(ByVal inRS As Object) As String
Dim lSPID As String
lSPID = ""
Do While Not inRS.EOF
If lSPID = "" Then
lSPID = CStr(inRS.Fields(0).Value)
Else
lSPID = lSPID & "," & CStr(inRS.Fields(0).Value)
End If
inRS.MoveNext
Loop
fetchSPID = lSPID
End Function
Private Function fetchDIM(ByVal inRS As Object) As String
Dim lArray
Dim lSID As String
If Not inRS.EOF Then
fetchDIM = inRS.Fields(0)
Else
fetchDIM = ""
End If
End Function
How would I get a folder that I, as a user, have been added to.
I need to do an addin for work, how would I access an inbox which isn't mine?
So the top one is my personal inbox, I need to access the inbox within 'MIS'.
Private Sub ThisApplication_NewMail() Handles Application.NewMail
Dim myNameSpace = Application.GetNamespace("MAPI")
Dim oParentFolder = myNameSpace.Folders("MIS")
Dim mis = oParentFolder.Folders.Item("Inbox")
Dim moveMail As Outlook.MailItem = Nothing
Dim mItems As Outlook.Items = mis.Items
mItems.Restrict("[Read] = true")
Dim destFolder As Outlook.MAPIFolder = mis.Folders("Test")
Dim SubjName = "TestingAddin123"
Dim sender As String = "michael"
Dim FName As String = "[Some recurring subject]"
Dim tStamp As String = Format(DateTime.Now, "ddMMyy").ToString()
Try
For Each eMail As Object In mItems
moveMail = TryCast(eMail, Outlook.MailItem)
If Not moveMail Is Nothing Then
If InStr(moveMail.SenderEmailAddress, sender) Then
If InStr(moveMail.Subject, SubjName) > 0 Then
Dim rn As New Random
Dim n = rn.Next(1, 9999)
'n()
moveMail.SaveAs("W:\NS\" & FName & "_" & tStamp & n.ToString() + ".html", Outlook.OlSaveAsType.olHTML)
moveMail.Move(destFolder)
End If
End If
End If
Next eMail
Catch ex As Exception
MsgBox(ex.Message)
End Try
End Sub
So I'm using the above code so far but I don't seem to be able to find the MIS Inbox.
How would I achieve this?
Try to use the Namespace.CreateRecipient / Namespace.GetSharedDefaultFolder methods.
As the title says, I'm having issues with enumerating and outputting item in my sent items folder in outlook. Specifically I'm looking for sent tasks. It keeps telling me there's nothing in the folder, when there is. The code is:
Private Sub GetSentTasks(objApp As Microsoft.Office.Interop.Outlook.Application)
Dim objNS As Outlook.NameSpace = objApp.GetNamespace("MAPI")
Dim folder As Outlook.MAPIFolder = _
objNS.GetDefaultFolder( _
Outlook.OlDefaultFolders.olFolderSentMail)
Dim searchCriteria As String = "[MessageClass] = 'IPM.TaskRequest'"
Dim strBuilder As StringBuilder = Nothing
Dim counter As Integer = 0
Dim taskItem As Outlook._TaskItem = Nothing
Dim folderItems As Outlook.Items = Nothing
Dim resultItem As Object = Nothing
Dim TTDcounter As Integer = 0
Try
folderItems = folder.Items
folderItems.IncludeRecurrences = True
If (folderItems.Count > 0) Then
resultItem = folderItems.Find(searchCriteria)
If Not IsNothing(resultItem) Then
strBuilder = New StringBuilder()
Do
If (TypeOf (resultItem) Is Outlook._TaskRequestItem) Then
counter += 1
taskItem = resultItem
'If taskItem.Categories = "TTD" Then
TTDcounter += 1
Dim listarray() As String = {taskItem.Delegator, taskItem.Subject, taskItem.DueDate, stripEstComp(taskItem.Body.ToString())}
taskPaneControl3.ListView1.Items.Add(TTDcounter).SubItems.AddRange(listarray)
'End If
End If
Marshal.ReleaseComObject(resultItem)
resultItem = folderItems.FindNext()
Loop Until IsNothing(resultItem)
End If
End If
If Not IsNothing(strBuilder) Then
Debug.WriteLine(strBuilder.ToString())
Else
Debug.WriteLine("There is no match in the " + _
folder.Name + " folder.")
End If
Catch ex As Exception
System.Windows.Forms.MessageBox.Show(ex.Message)
Finally
If Not IsNothing(folderItems) Then Marshal.ReleaseComObject(folderItems)
End Try
End Sub
I use SmtpMail for users to forward site content. The user fills out a form which includes first name and email.
The email sent has the full email address as the "From address" in the recipients inbox (they see From: Joe#Gmail.com while I want them to see From: Joe).
How can I format the "From address" to be the users inputted first name?
Thanks!
The MailAddress class has an optional parameter where you can specify a display name. I assume it will be used when present.
Dim from As MailAddress = New MailAddress("ben#contoso.com", "Ben Miller")
Dim to As MailAddress = New MailAddress("jane#contoso.com", "Jane Clayton")
Dim message As MailMessage = New MailMessage(from, to)
This has always worked for me:
Dim myMessage As New MailMessage
Dim myFrom As MailAddress = New MailAddress("bob#contoso.com", "Bob Denver")
Dim myTo As MailAddress = New MailAddress("steve#contoso.com", "Steve Miller")
myMessage.From = myFrom
myMessage.To.Add(myTo)
The format I ended up using was: mailer.From = name & "<" & emailer & ">"
This formats the from address to include Name as well as Email address. It will be displayed in most email clients as Joe <Joe#email.com>. This was my desired outcome.
Thank you Knslyr and lincolnk for the support.
this method displays 'Rameez' instead of 'Rameez#abc.com.pk'
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim objRecip As Recipient
Dim strMsg As String
Dim res As Integer
Dim strBcc As String
On Error Resume Next
strBcc = """Rameez"" <Rameez#abc.com.pk>"
Set objRecip = Item.Recipients.Add(strBcc)
objRecip.Type = olBCC
If Not objRecip.Resolve Then
strMsg = "Could not resolve the Bcc recipient. " & _
"Do you want still to send the message?"
res = MsgBox(strMsg, vbYesNo + vbDefaultButton1, _
"Could Not Resolve Bcc Recipient")
If res = vbNo Then
Cancel = True
End If
End If
Set objRecip = Nothing
End Sub