Outlook - get domains for each message

Attribute VB_Name = "MyDomains"
Option Explicit
'---------------------------------------
'2014-02-06-added support for missed conversations
Public Const VERSION = "2014.02.06.01.02"
Public Const USER_DOM_TO = "TO.Domain"
Public Const USER_DOM_FROM = "FROM.Domain"
Const VBQT = """"
Private DebugTime As Date
Public StartTime As Date
'Public Trace As New objTrace

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''--REFERENCE CODE TO CALL FROM OUTLOOK MACROS-----------------------------------------------------------
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub Set_Domains_for_all_messages_active_folder()
   Dim ObjFolders As Items
   Dim ForceReset As Boolean
   Set ObjFolders = Outlook.ActiveExplorer.CurrentFolder.Items.Restrict("[Message Class] = 'IPM.note'")
   ForceReset = (MsgBox("Force reset of to/from domain definitions?", vbYesNo, "Domain to/from") = vbYes)
   Set_Domains_Mail_Collection ObjFolders, ForceReset
  
    VIEW_ADD_COLUMN (USER_DOM_FROM)
   
End Sub

Sub Set_Domains_Current_Message()
   Dim objsel As Selection
   Dim ForceReset As Boolean
   Dim I As Integer
   Dim ObjMail As MailItem
  
   Set objsel = Outlook.ActiveExplorer.Selection
   ForceReset = True ''(MsgBox("Force reset of to/from domain definitions?", vbYesNo, "Domain to/from") = vbYes)
   frmProgress.SetMax (objsel.Count)
   For I = 1 To objsel.Count
      DoEvents
      frmProgress.SetCurrent (I)
      SetDomainMailObject objsel.Item(I), True
   Next I
  
   VIEW_ADD_COLUMN (USER_DOM_FROM)
  
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''------------------ACTIVE CODE--------------------------------------------------------------------------
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub SetDomainMailObject(objObject As Object, Optional ForceReset As Boolean)
 ''takes any object and uses the properties of the defined objects to set the domain info
 ''subroutine to determine type of message an run appropriate component to
 ''get domain informaion
 Dim ObjMail As MailItem
   Dim objReport As ReportItem
   Dim objMsg As MailItem                          ''container for reference mail item message
   Dim strFrom As String                           ''String for FROM email address

   On Error GoTo SetDomainMailSkip
  
   Select Case TypeName(objObject)
      Case "MailItem"
         Set ObjMail = objObject
       
         If Not (ObjMail.Subject Like "Missed conversation with*") And Not (ObjMail.Sender Is Nothing) Then
            ''check if sent on behalf of and use that email address
            If InStr(1, "@", ObjMail.SenderEmailAddress) > 0 Then
               Set_UserProperty ObjMail, USER_DOM_FROM, Get_DomainSMTPAddress(ObjMail.SenderEmailAddress), ForceReset
            Else
               Set_UserProperty ObjMail, USER_DOM_FROM, Get_Domain(ObjMail.Sender), ForceReset
            End If
            Set_UserProperty ObjMail, USER_DOM_TO, Get_Domain(ObjMail.Recipients), ForceReset
         Else
            Set_UserProperty objObject, USER_DOM_FROM, Get_DomainSMTPAddress(objObject.SenderEmailAddress), ForceReset
            Set_UserProperty objObject, USER_DOM_TO, Get_Domain(objObject.Recipients), ForceReset
         ''is lync conversation leftover
         End If
      Case "MeetingItem"
         Stop ''need code''''''''''''''<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
      Case "ReportItem"
         ''This is terrible- but the report item sender is not exposed...
         ''Is there a better way somewhere?  API call maby?
         'Set objReport = objObject                       ''Set the report object to current mail item
         Set objMsg = objObject.Actions.Item(1).Execute  ''Execute a reply
         strFrom = objMsg.Recipients.Item(1).Address        ''Get the resolved address from the 'to' of the reply
         objMsg.Delete                                   ''delete the unused draft
       
         Set_UserProperty objObject, USER_DOM_FROM, Get_DomainSMTPAddress(strFrom), ForceReset
      Case Else

   End Select
SetDomainMailSkip:
   On Error GoTo 0
End Sub



Public Sub Set_UserProperty(ByRef objObject As Object, UserPropertyID As String, UserPropertyValue As String, Optional Reset As Boolean)
'Trace.Add "Set_UserProperty"
Dim objProp As UserProperty
    ' 2014-08-20 added ReportItem
    ' Check if the item already has a Domain Property,
    ' Get a pointer to the new or existing one
    If Reset Or objObject.UserProperties(UserPropertyID) Is Nothing Then
      Set objProp = objObject.UserProperties.Add(UserPropertyID, olText)
    Else
      Set objProp = objObject.UserProperties(UserPropertyID)
    End If
  
    ' If the Item is a mail item, Get the domain, else Report that it isn't a mail item
    Select Case TypeName(objObject)
      Case "MailItem", "ReportItem"
         objProp.value = UserPropertyValue
      Case Else
      objProp.value = "Not a Mail Item"
    End Select
    objObject.Save
End Sub


Public Sub get_UserProperty(ByRef objMsg As MailItem, UserPropertyID As String, Optional Reset As Boolean)
'Trace.Add "get_UserProperty"
'PROGRESS.SubTitleUpdate "Set From Domain"
    Dim objProp As UserProperty
    Stop  '''fix to get not set
  '''''''''''''''''''''''''<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
    ' Check if the item already has a Domain Property,
    ' Get a pointer to the new or existing one
    If Reset Or objMsg.UserProperties(UserPropertyID) Is Nothing Then
      Set objProp = objMsg.UserProperties.Add(UserPropertyID, olText)
    Else
      Set objProp = objMsg.UserProperties(UserPropertyID)
    End If
  
    ' If the Item is a mail item, Get the domain, else Report that it isn't a mail item
    If olMail = objMsg.Class Then
      ''objProp.Value = GetFromDomain(str)
      'objProp.Value = UserPropertyValue
    Else
      objProp.value = "Not a Mail Item"
    End If
          
    objMsg.Save

End Sub

Private Sub Set_Domains_Mail_Collection(ByRef Mail_Items As Items, Optional ForceReset As Boolean)
'Trace.Add "Set_Domains_Mail_Collection"
'PROGRESS.SubTitleUpdate "Set_Domains_Mail_Collection"
    '''Export path
    'Dim ExPath As String
    '''''''''''''''''''''''''''''''''''''''
    ''when setting direct folder to export
    Dim ObjMail As MailItem

    Dim I As Integer
    Dim objProp As UserProperty
     
    StartTime = Time ''for debug
    On Error GoTo 0
    frmProgress.SetMax (Mail_Items.Count)
    'On Error Resume Next 'GoTo Set_Domains_Mail_Collection_ERR
    For I = 1 To Mail_Items.Count
      DoEvents
     
      SetDomainMailObject Mail_Items.Item(I)
     
      frmProgress.SetCurrent (I)
      debugx  '''<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
    Next I

GoTo ExportEmailCLEANUP:

''error trap
Set_Domains_Mail_Collection_ERR:
MsgBox Err.Description
'Stop
Resume

ExportEmailCLEANUP:
    On Error Resume Next
        Set Mail_Items = Nothing
        Set ObjMail = Nothing
        Set Mail_Items = Nothing
    On Error GoTo 0
   
frmProgress.Hide

End Sub

'''''''''''''''''''''
''''''''''''''''''''''''
Private Function Get_Domain(ByRef Addr_or_Recips As Object, Optional ReturnExchangeGroups As Boolean) As String
'Trace.Add "Get_Domain"
''If ReturnExchangeGroups then the local address exchange server group will be returned,
''othewise the local domain will be returned for exchange addresses.
   'Dim MyAtPos As Integer
   Dim ii
   Dim strOU As String
   Dim xaddr As String
   Dim rec
  
   Dim colDom As New Collection
   If IsMissing(ReturnExchangeGroups) Then ReturnExchangeGroups = False
   On Error Resume Next
   Get_Domain = ""
  
   ''check type name for rec, if an address entry was passed it has to be a collection to work properly below)
   If TypeName(Addr_or_Recips) = "AddressEntry" Then
      Dim x As New Collection
      x.Add Addr_or_Recips
      Set rec = x
      Set x = Nothing
   Else
      Set rec = Addr_or_Recips
   End If

Get_Domain_isCollection:
   For ii = 1 To rec.Count
      If "SMTP" = Left(UCase(rec.Item(ii).Address), 4) _
      Or InStr(1, rec.Item(ii).Address, "@", vbTextCompare) > 0 _
      Then
         Get_Domain = Get_Domain & Get_DomainSMTPAddress(rec.Item(ii).Address) & "; "
      Else
         If ReturnExchangeGroups Then
            ' Strip out the Domain from the mail using LDAP format. e.g. /o=LatentZero/ou=Adm..... Strip out LatentZero
            strOU = Left(rec.Item(ii).Address, InStr(1, rec.Item(ii).Address, "/ou=", vbTextCompare) - 1)
            Get_Domain = Get_Domain & Mid(strOU, 4) & "; "
         Else
            Get_Domain = Get_Domain & Get_DomainExchangeAddress(rec.Item(ii)) & ";"
         End If
      End If
      ''else try adding GetToDomainCDO???
   Next ii
 
   Get_Domain = Simplify_List(Get_Domain, ";")
  
End Function
Private Function Get_DomainSMTPAddress(Address As String) As String
Dim myAtPos As Integer

   myAtPos = InStr(1, Address, "@", vbTextCompare) + 1
   Get_DomainSMTPAddress = UCase(REDUCE_DOMAINS(Mid(Address, myAtPos)))
  
End Function
Private Function Get_DomainExchangeAddress(ObjRecipient As Object)
''http://msdn.microsoft.com/en-us/library/office/ff868695.aspx
''How to: Obtain the E-mail Address of a Recipient from outlook address entry
Dim myAtPos As Integer ''find @
   Get_DomainExchangeAddress = ObjRecipient.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x39FE001E")
   myAtPos = InStr(1, Get_DomainExchangeAddress, "@", vbTextCompare) + 1
   Get_DomainExchangeAddress = Mid(Get_DomainExchangeAddress, myAtPos)
End Function

Private Function Simplify_List(ByRef List As String, Delimeter As String) As String
   'PROGRESS.SubTitleUpdate "Simplify List"
   If Delimeter = "" Then Delimeter = ","
  
   Dim x, I, ii
   Dim uX As Integer
   Dim temp As String
  
   x = Split(UCase(List), Delimeter)
   uX = UBound(x)
  
   For I = 0 To uX
      x(I) = REDUCE_DOMAINS(Trim(x(I)))   '<<<<
   Next I
  
   ''sort
   For I = uX To 1 Step -1
      For ii = I - 1 To 0 Step -1
         If x(I) < x(ii) Then
         temp = x(I)
         x(I) = x(ii)
         x(ii) = temp
         End If
      Next ii
   Next I
  
   ''DE-DUPE
   For I = uX To 1 Step -1
      For ii = I - 1 To 0 Step -1
         If x(I) = x(ii) Then
            x(I) = ""
            Exit For
         End If
      Next ii
   Next I
  
   List = ""
  
   For I = 0 To uX
      If x(I) > "" Then List = List & Trim(x(I)) & Delimeter '& " "
   Next I
  
   Simplify_List = Left(List, Len(List) - Len(Delimeter))
End Function

Private Function REDUCE_DOMAINS(Name As String, Optional Delim As String, Optional level As Integer) As String
   ''specify level of granularity for domain
   ''ie car.foo.com level 2 = foo.com
   If level = 0 Then level = 2
   If Delim = "" Then Delim = "."
   If Name = "" Then Exit Function
  
   Dim x
   x = Split(Name, Delim)
   Dim I As Integer
  
   level = level - 1 ''adjust base 0
   If level > UBound(x) Then
   REDUCE_DOMAINS = Name
   End If
   REDUCE_DOMAINS = ""
   For I = UBound(x) - level To UBound(x)
      REDUCE_DOMAINS = REDUCE_DOMAINS & x(I) & Delim
   Next I
   REDUCE_DOMAINS = Left(REDUCE_DOMAINS, Len(REDUCE_DOMAINS) - 1)
End Function


Private Sub debugx()
''set to stop and debug every xx seconds...
If DebugTime = 0 Then DebugTime = Date + Time + 30 / 60 / 60 / 24
If DebugTime < Date + Time Then
    'Stop
    DebugTime = Date + Time + 30 / 60 / 60 / 24
End If
End Sub
Private Sub VIEW_ADD_COLUMN(ByVal strField As String)
   Dim ns As Outlook.NameSpace
   Dim fld As Outlook.Folder
   Dim vw As Outlook.TableView
   Dim vwf As Outlook.ViewField
   Dim udf As Outlook.UserDefinedProperty
   Dim udfName As String
  
   'Trace.Add "VIEW_ADD_COLUMN"
  
   On Error GoTo VIEW_ADD_COLUMN_err
  
   Set ns = Application.Session
   Set fld = Outlook.ActiveExplorer.CurrentFolder
  
   If fld Is Nothing Then
      fld = ns.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderInbox)
   End If
  
   Set vw = fld.CurrentView
  
   Set udf = fld.UserDefinedProperties.Find(strField)
  
   If udf Is Nothing Then
      Set udf = fld.UserDefinedProperties.Add(strField, Outlook.OlUserPropertyType.olText, _
      Outlook.OlFormatText.olFormatTextText, "")
     
      udfName = _
      "http://schemas.microsoft.com/mapi/string/{00020329-0000-0000-C000-000000000046}/" & strField   ''no spaces replace spaces with %20  .Replace(" ", "%20")
      Set vwf = vw.ViewFields.Insert(udfName, vw.ViewFields.Count)
      Set vwf = vw.ViewFields.Item(udfName)
     
   Else
      ''try
      On Error Resume Next
      Set vwf = vw.ViewFields(udf.Name)
     
      ''Catch ex As System.Runtime.InteropServices.COMException
      ''End Try
  
      If vwf Is Nothing Then
         vwf = vw.ViewFields.Insert(udf.Name, 1)
         vwf.ColumnFormat.Width = 60
      Else
         vwf.ColumnFormat.Width = 60
      End If
     
      vw.Save
      vw.Apply
     
   End If
VIEW_ADD_COLUMN_err:
On Error GoTo 0
End Sub

''======================================================== 
Public MAX As Integer
Public Current As Integer


Private Sub OK_Click()
   Me.Hide
End Sub

Private Sub UserForm_Initialize()
   ProgressFrame.Caption = ""
   Me.Left = Application.ActiveWindow().Left + Application.ActiveWindow().Width / 2 - (Me.Width / 2)
   Me.Top = Application.ActiveWindow().Top + Application.ActiveWindow().Height / 2 - (Me.Height / 2)
   Me.Height = 33
End Sub

Public Function SetCurrent(value As Integer)
   Dim Width As Integer
   If Me.Visible = False Then Me.Show (0)
   If MAX = 0 Then MAX = 1
   'If Value = 0 Then Value = 1
   If value > MAX Then value = MAX  ''100% max
   Width = (Me.Width - 15) * value / MAX
   If Width < 1 Then Width = 1
   ProgressFrame.Width = Width
   Me.labelProgress.Caption = Format(value / MAX * 100, "000") & "%"
   Me.Repaint
   DoEvents
   If value = MAX Then
      Me.labelProgress.Caption = Me.labelProgress.Caption & "  **DONE**"
      Me.Height = 64
   End If
  
End Function

Public Function SetMax(value As Integer)
   Dim Width As Integer
   MAX = value
   SetCurrent (0)
End Function
''==============================================================




Comments

Post a Comment

Popular posts from this blog

Powerpoint countdown and current time in slides VBA

Add text fields- this VBA searches through the objects in the first frame until it finds " " in the text some where, truncates everything from and to the right and replaces it with an active countdown timer or current time in the box. Refreshes every 500ms with a prtsafe call so it doesn't bog down the CPU. Add a slide advance to start the next slide and begin automated slide advancement. Attribute VB_Name = "Countdown" Private Declare PtrSafe Function WaitMessage Lib "user32" () As Long Public Sub Wait ( Seconds As Double ) ''non cpu-intensive wait timer '' https://stackoverflow.com/questions/57268161/sleep-wait-timer-in-powerpoint-vba-thats-not-cpu-intensive Dim endtime As Double endtime = DateTime.Timer + Seconds Do WaitMessage DoEvents Loop While DateTime.Timer < endtime End Sub Sub Countdown_from_Start () Dim Time As Date Dim Count As ...
Read more

Revit area plans adding new types and references (Gross and rentable)

Image
Note to self: Add additional (duplicate) gross area and net area schemed under Area Plans And Area schemes... Really counter-intuitive place to put this instead of say...  Area Plans> New Type> Edit Type (ADD) or Create an area plan, then Go to Properties, Edit Type and Duplicate... Always seem to forget this one! 2015-10-16-And for the calculation type... To update: this also applies to Revit as well as LT- The gross calculations cannot be overridden, however the 'rentable' comes in various flavors... From AD Revit help: Applies to Revit LT 2015 Rules are determined by one type of space bordering another space. The following table shows area measurement rules. To find the appropriate measurement rule, find the selected Area Type and the corresponding Bordering Area Type. Gross Building Area Scheme Types Gross Building Area Scheme Types Area Type Selected Bordering Area Type Measurement Rule Gross Building Area Gross Buil...
Read more