Malicious Office (OOXML) — malware analysis report

Attribute VB_Name = "ThisDocument"
Attribute VB_Base = "0{00020906-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
Option Explicit

Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey, http://gregmaxey.com/word_tips.html, 12/16/2018
  MsgBox AscW(Selection.Range.ContentControls(1).Range.Text)
lbl_Exit:
  Exit Sub
End Sub


Attribute VB_Name = "Dictionary"
Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
Option Explicit

'Module Name Dictionary
'Module Type Class
'Patrick O'Beirne @ sysmod
'https://sysmod.wordpress.com/2011/11/24/dictionary-vba-class-update/
'Emulates and Replaces the need for “Microsoft Scripting Runtime” dictionary (scrrun.dll)

'Collection methods: Add, Count, Item, Remove
'Dictionary : .Add(Key as string, Item as variant), .CompareMode, .Count, .Exists(Key); _
   .Item(Key) - writeable, .Items, .Keys, .Remove(Key), .RemoveAll
'plus KeyValuePairs collection, KeyValuePair(Index as long), Tag as variant
'KeyValuePair helper object

Public KeyValuePairs As Collection ' open access but allows iteration
Public Tag As Variant      ' read/write unrestricted

Private Sub Class_Initialize()
  Set KeyValuePairs = New Collection
End Sub

Private Sub Class_Terminate()
  Set KeyValuePairs = Nothing
End Sub

Public Property Get CompareMode() As VbCompareMethod
  'In Scripting.Dictionary this is writeable, here we have only vbtextCompare because we are using a Collection
  CompareMode = vbTextCompare   '=1; vbBinaryCompare=0
End Property

Public Property Let Item(Key As String, Item As Variant)
 'dic.Item(Key) = value ' update a scalar value for an existing key
 Let KeyValuePairs.Item(Key).value = Item
End Property

Public Property Set Item(Key As String, Item As Variant)
  'Set dic.Item(Key) = value ' update an object value for an existing key
  Set KeyValuePairs.Item(Key).value = Item
End Property

Public Property Get Item(Key As String) As Variant
  AssignVariable Item, KeyValuePairs.Item(Key).value
End Property

Public Sub add(Key As String, Item As Variant)
'Collection parameter order is Add(Item,Key); Dictionary is Add(Key,Item) so always used named arguments
Dim oKVP As KeyValuePair
  Set oKVP = New KeyValuePair
  oKVP.Key = Key
  If IsObject(Item) Then
    Set oKVP.value = Item
  Else
    Let oKVP.value = Item
  End If
  KeyValuePairs.add Item:=oKVP, Key:=Key
lbl_Exit:
  Exit Sub
End Sub

Public Property Get Exists(Key As String) As Boolean
  On Error Resume Next
  Exists = TypeName(KeyValuePairs.Item(Key)) > ""  ' we can have blank key, empty item
End Property

Public Sub Remove(Key As String)
  On Error Resume Next
  KeyValuePairs.Remove Key
End Sub

Public Sub RemoveAll()
  Set KeyValuePairs = Nothing
  Set KeyValuePairs = New Collection
End Sub

Public Property Get Count() As Long
  Count = KeyValuePairs.Count
End Property

Public Property Get Items() As Variant
'For compatibility with Scripting.Dictionary
Dim vlist As Variant, i As Long
  If Me.Count > 0 Then
    ReDim vlist(0 To Me.Count - 1) ' to get a 0-based array same as scripting.dictionary
    For i = LBound(vlist) To UBound(vlist)
      AssignVariable vlist(i), KeyValuePairs.Item(1 + i).value ' could be scalar or array or object
    Next i
    Items = vlist
  End If
End Property

Public Property Get keys() As String()
Dim vlist() As String, i As Long
  If Me.Count > 0 Then
    ReDim vlist(0 To Me.Count - 1)
    For i = LBound(vlist) To UBound(vlist)
      vlist(i) = KeyValuePairs.Item(1 + i).Key   '
    Next i
    keys = vlist
  End If
End Property

Public Property Get KeyValuePair(Index As Long) As Variant  ' returns KeyValuePair object
  Set KeyValuePair = KeyValuePairs.Item(1 + Index)      ' collections are 1-based
End Property

Private Sub AssignVariable(variable As Variant, value As Variant)
  If IsObject(value) Then
    Set variable = value
  Else
    Let variable = value
  End If
lbl_Exit:
  Exit Sub
End Sub

Public Sub DebugPrint()
Dim lItem As Long, lIndex As Long, vItem As Variant, oKVP As KeyValuePair
  lItem = 0
  For Each oKVP In KeyValuePairs
    lItem = lItem + 1
    Debug.Print lItem; oKVP.Key; " "; TypeName(oKVP.value);
    If InStr(1, TypeName(oKVP.value), "()") > 0 Then
      vItem = oKVP.value
      Debug.Print "("; CStr(LBound(vItem)); " to "; CStr(UBound(vItem)); ")";
      For lIndex = LBound(vItem) To UBound(vItem)
        Debug.Print " (" & CStr(lIndex) & ")"; TypeName(vItem(lIndex)); "="; vItem(lIndex);
      Next
      Debug.Print
    Else
      'Debug.Print "="; oKVP.value
    End If
  Next
lbl_Exit:
  Exit Sub
End Sub

'NB VBA Collection object index is 1-based, scripting.dictionary items array is 0-based
'cf Scripting.Dictionary Methods s.Add(Key, Item), s.CompareMode, s.Count, s.Exists(Key); _
   s.Item(Key) - updateable, s.Items, s.Key(Key), s.Keys, s.Remove(Key), s.RemoveAll
'Scripting.Dictionary has no index number; you can index the 0-based variant array of Items returned
'  unlike Collections which can be indexed starting at 1
'Efficient iteration is For Each varPair in thisdic.KeyValuePairs
'Another difference I introduce is that in a scripting.dictionary, the doc says
'  If key is not found when changing an item, a new key is created with the specified newitem.
'  If key is not found when attempting to return an existing item, a new key is created and its corresponding item is left empty.
'but I want to raise an error when addressing a key that does not exist
'similarly, the scripting.dictionary will create separate integer and string keys for eg 2



Attribute VB_Name = "ModPDFCreator"
Option Explicit
Public m_arrFileNames() As String

Type PDFCreator
  Initalized As Boolean
  SingleOrMergeSuccess As Boolean
  MultiFailOneOrMoreEvent As Boolean
End Type

Function fcnPDFCreatorInitialize_Print(Optional Path As String, Optional Name As Variant, _
                     Optional JobCount As Long = 1, Optional MergeAllJobs As Boolean = False, _
                     Optional Protected As Boolean = False, Optional OwnerPassword As String = "Owner", _
                     Optional UPWTO As Boolean = False, Optional UserPassword As String = "User", _
                     Optional RestrictPrint As Boolean = False, Optional RestrictEdit As Boolean = False, _
                     Optional RestrictAssembly As Boolean = False, Optional RestrictCopy As Boolean = False, _
                     Optional RestrictSR As Boolean = False, Optional RestrictComment As Boolean = False, _
                     Optional RestrictFillin As Boolean = False, Optional OpenViewer As Boolean = False, _
                     Optional EmailWithClient As Boolean = False, Optional RecipientNames = vbNullString, _
                     Optional EmailSubj As String = vbNullString, Optional EmailBody As String = vbNullString, _
                     Optional EmailWithSMTP As Boolean = False, Optional EmailAddPDFSig As Boolean = False, _
                     Optional InhibitRestore As Boolean = False, Optional ForceRestore As Boolean = False, _
                     Optional OutputFormat As String = "Pdf") As PDFCreator
'A collborative effort with Graham Mayor with additional assistance from Andreas Killer.
Dim colPrinters As Collection
Static varPDFCreatorPrinter As Variant
Static bRestorePrinter As Boolean
Static strCurrentPrinter
Static oPDFCreatorQueue As Object
Dim oPrintJob As Object
Dim lngCounter As Long, lngJob As Long
  If IsMissing(Name) Then
    If Not ForceRestore Then
      'This half of the IsMissing If ... Else ... End if statement determines the active printer _
      (sets PDFCreator printer as active printer if required\installed) and initiallizes the PDFCreator COM interface object.
      Set colPrinters = fcnPDFCreatorPrintersCollection
      On Error GoTo Err_Handler
      If colPrinters.Count > 0 Then
        For Each varPDFCreatorPrinter In colPrinters
          If InStr(1, ActivePrinter, varPDFCreatorPrinter, vbTextCompare) > 0 Then
            bRestorePrinter = False
            Exit For
          End If
        Next
        If IsEmpty(varPDFCreatorPrinter) Then
          'Change active printer to the first detected PDFCreator printer.
          With Dialogs(wdDialogFilePrintSetup)
            strCurrentPrinter = .printer
            .printer = colPrinters.Item(1)
            .DoNotSetAsSysDefault = True
            .Execute
          End With
          bRestorePrinter = True
        End If
      Else
        Err.Raise 68  'PDFCreator is not the active printer
      End If
      On Error GoTo 0
      If oPDFCreatorQueue Is Nothing Then
        Set oPDFCreatorQueue = CreateObject("PDFCreator.JobQueue")
        On Error Resume Next
        oPDFCreatorQueue.ReleaseCom
        oPDFCreatorQueue.Initialize
        On Error GoTo 0
      End If
      'PDFCreator printer set as active printer and initialized.
      fcnPDFCreatorInitialize_Print.Initalized = True
    Else
      'Restore the original printer
      With Dialogs(wdDialogFilePrintSetup)
        .printer = strCurrentPrinter
        .Execute
      End With
    End If
  Else
    'No luck in Word with the JobQueue.WaitForJobs() method.  The following seems to work well.
    Do
      DoEvents
    Loop Until oPDFCreatorQueue.Count = JobCount
    If MergeAllJobs Then
      'Variable passed instructing all jobs be merged into a single print job (print all to one file).
      oPDFCreatorQueue.MergeAllJobs
      'Since all jobs have been merged to a single job, reset the the JobCount variable.
      JobCount = 1
      Set oPrintJob = oPDFCreatorQueue.NextJob
    Else
      Set oPrintJob = oPDFCreatorQueue.GetJobByIndex(0)
    End If
    lngCounter = oPDFCreatorQueue.Count
    lngJob = 1
    fcnPDFCreatorInitialize_Print.MultiFailOneOrMoreEvent = False
    Do
      'Process the PrintJob(s)
      With oPrintJob
        .SetProfileSetting "OpenViewer", OpenViewer
        .SetProfileSetting "OutputFormat", OutputFormat
        'Security settings.
        .SetProfileSetting "PdfSettings.Security.Enabled", fcnBoolToString(Protected)  'If True, the PDF file will be password protected
        .SetProfileSetting "PdfSettings.Security.OwnerPassword", OwnerPassword  'String password that can be used to modify the document
        .SetProfileSetting "PdfSettings.Security.RequireUserPassword", fcnBoolToString(UPWTO)  ' If True, a password is required to open the document.
        If UPWTO = True Then .SetProfileSetting "PdfSettings.Security.UserPassword", UserPassword  'String password that must be used to open if set."
        .SetProfileSetting "PdfSettings.Security.AllowPrinting", fcnNotBoolToString(RestrictPrint)
        .SetProfileSetting "PdfSettings.Security.AllowToEditTheDocument", fcnNotBoolToString(RestrictEdit)
        .SetProfileSetting "PdfSettings.Security.AllowToEditAssembly", fcnNotBoolToString(RestrictAssembly)  'Adobe "Document Assembly" property.
        .SetProfileSetting "PdfSettings.Security.AllowToCopyContent", fcnNotBoolToString(RestrictCopy)
        .SetProfileSetting "PdfSettings.Security.AllowScreenReader", fcnNotBoolToString(RestrictSR)   'Adobe Content Copying for Accessibility
        .SetProfileSetting "PdfSettings.Security.AllowToEditComments", fcnNotBoolToString(RestrictComment)  'If true, overrides a false Filling In Form Fields
        .SetProfileSetting "PdfSettings.Security.AllowToFillForms", fcnNotBoolToString(RestrictFillin)  'Adobe Filling in Form Fields, Signing and Create Template Pages.
        If EmailWithClient Then
          .SetProfileSetting "EmailClientSettings.Enabled", fcnBoolToString(EmailWithClient)  'Enables the EmailClient action
          .SetProfileSetting "EmailClientSettings.Recipients", RecipientNames  'Recipients separated with ;
          .SetProfileSetting "EmailClientSettings.Subject", EmailSubj  'Subject line of the email
          .SetProfileSetting "EmailClientSettings.Content", EmailBody  'Body text of the email
          .SetProfileSetting "EmailClientSettings.AddSignature", fcnBoolToString(EmailAddPDFSig)  'Add the PDFCreator signature to the mail
        End If
        On Error GoTo 0
        If JobCount > 1 Then Name = m_arrFileNames(lngJob - 1)
        .ConvertToAsync Path & Application.PathSeparator & Name
        lngJob = lngJob + 1
      End With
      'Dim y As Long
      Do
        DoEvents
        'y = y + 1
        'If y = 10000 Then Exit Do
      Loop Until oPrintJob.IsSuccessful Or oPrintJob.IsFinished
      'Oddly enough, IsFinished seems to indicate the job quited without actually creating a file. So we _
      simply loop until the job either prints (IsSuccessful) or quits without printing (IsFinished) and evaluate.
      If oPrintJob.IsSuccessful Then
        fcnPDFCreatorInitialize_Print.SingleOrMergeSuccess = True
      Else
        fcnPDFCreatorInitialize_Print.SingleOrMergeSuccess = False
        fcnPDFCreatorInitialize_Print.MultiFailOneOrMoreEvent = True
      End If
      lngCounter = lngCounter - 1
      If lngCounter > 0 Then Set oPrintJob = oPDFCreatorQueue.NextJob
    Loop Until oPDFCreatorQueue.Count = 0
Cleanup:
    If Not InhibitRestore Then
      oPDFCreatorQueue.ReleaseCom
      Set oPDFCreatorQueue = Nothing
    End If
    If Not InhibitRestore And bRestorePrinter Then
      'Restore the original printer
      With Dialogs(wdDialogFilePrintSetup)
        .printer = strCurrentPrinter
        .Execute
      End With
    End If
  End If
lbl_Exit:
  Exit Function
Err_Handler:
  Select Case Err.Number
  Case Is = 168
    ShowMsg 2, 1, "An error " & Err.Naumber & " (" & Err.Description & ") has occured with PDFCreator.  The developer has no access to or control over the functionality of this freeware application.' & vbCr +vbcr" _
          & "When it works, it works brillantly.  When it doesn't well here you are.  Sorry.", "USER NOTIFICATION - PDF CREATOR", , 200, , "OK"
    fcnPDFCreatorInitialize_Print.Initalized = False
  Case Else
    fcnPDFCreatorInitialize_Print.Initalized = False
    Resume Cleanup
  End Select
  Resume lbl_Exit
End Function

Function fcnPDFCreatorPrintersCollection() As Collection
'Returns a collection of all PDFCreator printers. Adapted from code posted by Andreas Killer.
Dim oPDFCreator As Object  'PDFCreator.PdfCreatorObj
Dim oPrinters As Object  'PDFCreator.Printers
Dim lngIndex As Long
  Set fcnPDFCreatorPrintersCollection = New Collection
  On Error GoTo lbl_Exit
  Set oPDFCreator = CreateObject("PDFCreator.PdfCreatorObj")
  Set oPrinters = oPDFCreator.GetPDFCreatorPrinters
  For lngIndex = 0 To oPrinters.Count - 1
    fcnPDFCreatorPrintersCollection.add oPrinters.GetPrinterByIndex(lngIndex)
  Next lngIndex
lbl_Exit:
  Set oPDFCreator = Nothing
  Set oPrinters = Nothing
End Function

Function fcnBoolToString(bPassed As Boolean) As String
  fcnBoolToString = "False"
  If bPassed Then fcnBoolToString = "True"
lbl_Exit:
  Exit Function
End Function

Function fcnNotBoolToString(bPassed As Boolean) As String
  fcnNotBoolToString = "True"
  If bPassed Then fcnNotBoolToString = "False"
lbl_Exit:
  Exit Function
End Function



Attribute VB_Name = "modOLFunctions"
Option Explicit
'Adapted form http://www.rondebruin.nl/win/s1/outlook/openclose.htm
#Const LateBind = True
'Outook early bind contants:
Const olMinimized As Long = 1
Const olMaximized As Long = 2
Const olFolderInbox As Long = 6
Const olFolderOutbox = 4
Const olFolderDrafts As Long = 16

Private m_olItem As Object      'As Outlook.MailItem
Private m_oSyncs As Object      'As Outlook.SyncObjects
Private m_olSyc As Object       'As Outlook.SyncObject
Private m_oOLFolder As Object     'As Outlook.Folder
Private m_bNewOLInstance As Boolean
#If LateBind Then
Public Function OutlookApp(Optional WindowState As Long = 1, Optional Folder As Long = 6, _
               Optional ReleaseIt As Boolean = False) As Object
  Static oOLApp As Object
#Else
Public Function OutlookApp(Optional WindowState As Outlook.OlWindowState = olMinimized, Optional Folder As Long = olFolderInbox, _
        Optional ReleaseIt As Boolean) As Outlook.Application
  Static oOLApp As Outlook.Application
#End If
Dim lngCounter As Long
Dim strSuppress As String

  On Error GoTo ErrHandler
  Select Case True
    Case oOLApp Is Nothing, Len(oOLApp.Name) = 0
      Set oOLApp = GetObject(, "Outlook.Application")
      If oOLApp.Explorers.Count = 0 Then
InitOutlook:
        'Open inbox to prevent errors with security prompts.
        oOLApp.Session.GetDefaultFolder(Folder).Display
        oOLApp.ActiveExplorer.WindowState = WindowState
      End If
    Case ReleaseIt
       Set oOLApp = Nothing
  End Select
  Set OutlookApp = oOLApp
  On Error GoTo 0
  If GetOLSpellCheckOptionFromRegistry(OutlookApp.Version) = "1" Then
    On Error GoTo ErrHandler
    lngCounter = CLng(GetSetting(Globals.AddInID, "Config", "OL Spellcheck Message Counter"))
    Select Case lngCounter
      Case Is = 1: strSuppress = "This notication is auto suppressed."
      Case Is = 2: strSuppress = "This notication will auto suppress after one more appearance."
      Case Else: strSuppress = "This notification will auto suppres after " & lngCounter - 1 & " more appearances."
    End Select
    If lngCounter > 0 Then
      ShowMsg 2, 4, "A registry query indicates you have set the Outlook mail option ""Always check spelling before sending."" The AddIn option " _
          & "to ""Suppress Outlook Spellchecking"" overrides this setting for messages using HTML format but has no bearing on plain text messages." & vbCr + vbCr _
          & "If you intend to use plain text messages then be sure they are error free or cancel the current merge process and change the option in Outlook." & vbCr + vbCr _
          & "Note - " & strSuppress, _
            "USER NOTIFICATION - OUTLOOK SPELLCHECKING", 400, 160, , "OK", "SUPRRESS NOW"
      If frmMsg.Tag = 0 Then
        SaveSetting Globals.AddInID, "Config", "OL Spellcheck Message Counter", 0
      Else
        SaveSetting Globals.AddInID, "Config", "OL Spellcheck Message Counter", CStr(lngCounter - 1)
      End If
      Unload frmMsg
    End If
  End If
lbl_Exit:
  Exit Function
ErrHandler:
  Select Case Err.Number
    Case -2147352567
      'User cancelled setup, silently exit.
      Set oOLApp = Nothing
    Case 429, 462
      Set oOLApp = GetOutlookApp()
      If oOLApp Is Nothing Then
        Err.Raise 429, "OutlookApp", "Outlook Application does not appear to be installed."
      Else
        Resume InitOutlook
      End If
    Case Else: ShowMsg 2, 1, "Error " & Err.Number & ": " & Err.Description & ".", "USER NOTIFCATION - UNEXPECTED ERROR", , , wdColorRed, "OK"
  End Select
  Resume lbl_Exit
End Function

#If LateBind Then
Private Function GetOutlookApp() As Object
#Else
Private Function GetOutlookApp() As Outlook.Application
#End If
  On Error GoTo ErrHandler
  Set GetOutlookApp = CreateObject("Outlook.Application")
lbl_Exit:
  Exit Function
ErrHandler:
  Set GetOutlookApp = Nothing
  Resume lbl_Exit
  Resume
End Function

Sub Mail_PushToOutbox()
Dim oFrm As frmMsgThrottle
Dim strSendAt As String
Dim lngLimit As Long
Dim lngIndex As Long
'***The ribbon invalidate should preclude being able to perform this routine but with earlier  revs. it seemed unreliable.
  If Globals.AddInID = vbNullString Then modGlobals.SetGlobals
  If CBool(GetSetting(Globals.AddInID, "Config", "Outlook Available")) = True Then
    Set oFrm = New frmMsgThrottle
    RemoveCloseButton oFrm
    With oFrm
      .Show
      strSendAt = .SendTime
      lngLimit = .Limit
    End With
    If oFrm.Tag = "CANCEL" Then Exit Sub
    Unload oFrm
    On Error Resume Next
    Set Globals.OutlookApp = GetObject(, "Outlook.Application")
    If Err.Number > 0 Then
      m_bNewOLInstance = True
      Set Globals.OutlookApp = OutlookApp()
    End If
    On Error GoTo 0
    Set Globals.OutlookApp.ActiveExplorer.CurrentFolder = Globals.OutlookApp.Session.GetDefaultFolder(16).Parent
    If fcnSend_EMMTO_Drafts(strSendAt, lngLimit) Then
      If lngLimit > 0 Then
        ShowMsg 2, 4, "A mail item or mail items up to the defined limit of (" & lngLimit & ") were moved from the " _
              & "Outlook Draft\" & Globals.OLFolderName & " folder to the outbox." & vbCr + vbCr _
              & "If your Outlook application is configured to send items immediately then those mail items have sent or are sending. " & vbCr + vbCr _
              & "Otherwise you may select ""SEND ALL"" to synchronize OUTLOOK and send and receive all items now or click ""CLOSE"" to end this " _
              & "dialog without further action." & vbCr + vbCr _
              & "Repeat using ""Push to Outbox"" as required to send any remaining mail items in sub-sets defined.", "USER NOTIFICATION", 340, 220, , "SEND ALL", "CLOSE"
      Else
        ShowMsg 2, 4, "Mail items were moved from the Outlook Draft\" & Globals.OLFolderName & " folder to the outbox." & vbCr + vbCr _
              & "If your Outlook application is configured to send items immediately then those mail items have sent or are sending. " & vbCr + vbCr _
              & "Otherwise you may select ""SEND ALL"" to synchronize OUTLOOK and send and receive all items now or click ""CLOSE"" to end this " _
              & "dialog without further action.", "USER NOTIFICATION", 340, 200, , "SEND ALL", "CLOSE"
      End If
      If frmMsg.Tag = 1 Then
        Set m_oSyncs = Globals.OutlookApp.Session.SyncObjects
        For lngIndex = 1 To m_oSyncs.Count
          Set m_olSyc = m_oSyncs.Item(lngIndex)
          m_olSyc.Start
          DoEvents
        Next lngIndex
        Mail_SendAll
        Unload frmMsg
      End If
    End If
    If m_bNewOLInstance = True Then Globals.OutlookApp.Quit
  End If
lbl_Exit:
  Unload frmMsg
  Set Globals.OutlookApp = Nothing
  Exit Sub
End Sub

Sub Mail_SendAll()
Dim olItems As Object
Dim lngIndex As Long, lngSent As Long
  '***The ribbon invalidate should preclude being able to perform this routing but with earlier  revs. it seemed unreliable.
  If CBool(GetSetting(Globals.AddInID, "Config", "Outlook Available")) = True Then
    m_bNewOLInstance = False
    On Error Resume Next
    Set Globals.OutlookApp = GetObject(, "Outlook.Application")
    If Err.Number > 0 Then
      m_bNewOLInstance = True
      Set Globals.OutlookApp = OutlookApp()
    End If
    On Error GoTo Err_Handler
    Set olItems = Globals.OutlookApp.Session.GetDefaultFolder(4).Items 'Outbox
    For lngIndex = olItems.Count To 1 Step -1
      Set m_olItem = olItems(lngIndex)
      m_olItem.Send
      DoEvents
      lngSent = lngSent + 1
    Next lngIndex
    Set m_oSyncs = Globals.OutlookApp.Session.SyncObjects
    For lngIndex = 1 To m_oSyncs.Count
      Set m_olSyc = m_oSyncs.Item(lngIndex)  'There are two "All Accounts" and "Application Folders"
      m_olSyc.Start
      DoEvents
    Next
    If m_bNewOLInstance = True Then Globals.OutlookApp.Quit
    ShowMsg 1, , "OUTLOOK has sent or is sending " & lngSent & " messages.", "USER INFORMATION", 340, 80, , "OK"
  Else
    ShowMsg 1, , "OUTLOOK is either not installed, not the default mail application, not checked in the Add-In configuration as intalled or not repsponding.", "USER INFORMATION", 340, , , "OK"
  End If
lbl_Exit:
  Set Globals.OutlookApp = Nothing: Set olItems = Nothing: Set m_olItem = Nothing
  Set m_oSyncs = Nothing: Set m_olSyc = Nothing
  Exit Sub
Err_Handler:
  ShowMsg 2, , "OUTLOOK could not send a message in the queue due to: " & Err.Description & "." & vbCr + vbCr _
       & "After the send process completes, review any messages in your Outlook Outbox for " _
       & "possible cause including no subject or invalid/missing recipient names.", "USER NOTIFICATIN - ACTION REQUIRED", 400, 130, , "OK"
  Resume lbl_Exit
End Sub

Sub Validate_EMMTO_DraftSubfolder()
'Checks for\creates the Outlook Draft message subfolder.
  On Error Resume Next
  Set m_oOLFolder = Globals.OutlookApp.Session.GetDefaultFolder(16).Folders(Globals.OLFolderName)
  If Err.Number <> 0 Then
    Set m_oOLFolder = Globals.OutlookApp.Session.GetDefaultFolder(16)
    m_oOLFolder.Folders.add (Globals.OLFolderName)
  End If
lbl_Exit:
  Set m_oOLFolder = Nothing
  Exit Sub
End Sub

Sub RouteToDraft(strSubject As String)
'Moves generated messages from the Outlook Drafts folder to the defined Add-In message drafts sub-folder
Dim oOLFolder As Object   'As Outlook.Folder
Dim oMailItems As Object  'As Outlook.Items
Dim oMail As Object     'As Outlook.MailItem
Dim lngIndex As Long, lngCount As Long
  Set oOLFolder = Globals.OutlookApp.Session.GetDefaultFolder(16).Folders(Globals.OLFolderName)
  'We just put a message in the Draft folder.
  Set oMailItems = Globals.OutlookApp.Session.GetDefaultFolder(16).Items
  'Get the last item (the one we just put there)
  Set oMail = oMailItems(oMailItems.Count)
  oMail.UnRead = True
  oMail.Move oOLFolder
lbl_Exit:
  Set oOLFolder = Nothing: Set oMailItems = Nothing: Set oMail = Nothing
  Exit Sub
End Sub

Sub Kill_EMMTO_DraftSubfolder()
  On Error Resume Next
  Set Globals.OutlookApp = GetObject(, "Outlook.Application")
  If Err.Number > 0 Then
    m_bNewOLInstance = True
    Set Globals.OutlookApp = OutlookApp()
    End If
    Set m_oOLFolder = Globals.OutlookApp.Session.GetDefaultFolder(16).Folders(Globals.OLFolderName)
    If Not m_oOLFolder Is Nothing Then
      If m_oOLFolder.Items.Count > 0 Then
        ShowMsg 2, 4, "The Add-In message draft folder " & Chr(34) + Globals.OLFolderName & Chr(34) _
            & "contains messages that have not been sent." & vbCr + vbCr _
            & "Are you sure that you want to remove it?", "USER NOTIFICATION/ACTION", , 110
        If frmMsg.Tag = 0 Then GoTo lbl_Exit
      End If
    m_oOLFolder.Delete
  End If
  ShowMsg 2, 1, "The temporary Outlook folder " & Chr(34) & Globals.OLFolderName & Chr(34) & " has been removed.", , , 100, , "OK"
  Unload frmMsg
  If m_bNewOLInstance = True Then Globals.OutlookApp.Quit
lbl_Exit:
  If Not frmMsg Is Nothing Then Unload frmMsg
  Set Globals.OutlookApp = Nothing: Set m_oOLFolder = Nothing
  Exit Sub
End Sub

Private Function fcnSend_EMMTO_Drafts(SendDelay As String, SendLimit As Long) As Boolean
Dim oFolder As Object
Dim lngMsg As Long, lngError As Long, lngItem As Long
  On Error Resume Next
  Set oFolder = Globals.OutlookApp.Session.GetDefaultFolder(16).Folders(Globals.OLFolderName)
  If Not oFolder Is Nothing Then
    lngError = 0: lngMsg = 1
    If oFolder.Items.Count > 0 Then
      On Error GoTo Err_Handler
      For lngItem = oFolder.Items.Count To 1 Step -1
        Select Case SendLimit
          Case Is = -9999 'No limit, send all
          Set m_olItem = oFolder.Items(lngItem)
          m_olItem.UnRead = True
          If m_olItem.Recipients.Count > 0 Then
            m_olItem.DeferredDeliveryTime = CDate(SendDelay)
            m_olItem.Save
            m_olItem.Send
            lngMsg = lngMsg + 1
          Else
            lngError = lngError + 1
          End If
          Case Else
            If lngMsg <= SendLimit Then
              Set m_olItem = oFolder.Items(lngItem)
              m_olItem.UnRead = True
              If m_olItem.Recipients.Count > 0 Then
                If Not SendDelay = vbNullString Then m_olItem.DeferredDeliveryTime = CDate(SendDelay)
                m_olItem.Save
                m_olItem.Send
                lngMsg = lngMsg + 1
              Else
                lngError = lngError + 1
              End If
            End If
        End Select
        DoEvents
Next_Item:
      Next lngItem
      If lngError > 0 Then
        ShowMsg 2, , "One or more messages were invalidated due to undefined recipient(s)." & vbCr + vbCr _
                   & "These messages are retained in the Outlook Draft\" & Globals.OLFolderName & " subfolder pending your review", _
                     "USER NOTIFICATIN - ACTION REQUIRED", 400, 150, , "OK"
        Unload frmMsg
      End If
      fcnSend_EMMTO_Drafts = True
    Else
       ShowMsg 1, , "The Add-In Outlook folders is empty. There are no messages to send.", "USER NOTIFICATON", , , , "OK"
       Unload frmMsg
       fcnSend_EMMTO_Drafts = False
    End If
  Else
    ShowMsg 1, , "The Add-In Outlook folders is missing. There are no messages to send.", "USER NOTIFICATON", , , , "OK"
    fcnSend_EMMTO_Drafts = False
  End If
lbl_Exit:
  Set oFolder = Nothing: Set m_olItem = Nothing
Exit Function
Err_Handler:
  ShowMsg 2, , "OUTLOOK could not send a message in the queue due to " & Err.Description & "." & vbCr + vbCr _
       & "After the send process completes, review any messages in your Outlook Outbox or Outlook Drafts\" & Globals.OLFolderName & " for " _
       & "possible cause and resolution.", "USER NOTIFICATIN - ACTION REQUIRED", 400, 170, , "OK"
  Unload frmMsg
  Resume Next_Item
End Function

Function GetOLSpellCheckOptionFromRegistry(strVerBuild As String) As String
Dim oShell As Object
Dim strRegKey As String, strKeyWord As String
Dim strVerFromBuild As String
  If Len(strVerBuild) > 4 Then
    strVerFromBuild = Left(strVerBuild, 4)
  Else
    strVerFromBuild = strVerBuild
  End If
  strRegKey = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & strVerFromBuild & "\Outlook\Options\Spelling\Check"
  Set oShell = CreateObject("WScript.Shell")
  On Error Resume Next
  GetOLSpellCheckOptionFromRegistry = oShell.RegRead(strRegKey)
  If Err.Number <> 0 Then GetOLSpellCheckOptionFromRegistry = "0"
  On Error GoTo 0
lbl_Exit:
  Set oShell = Nothing
  Exit Function
End Function

Sub Test()
Dim lngLimit As Long
lngLimit = 75
Globals.OLFolderName = "Enhanced Merge"
        ShowMsg 2, 4, "A mail item or mail items up to the defined limit of (" & lngLimit & ") were moved from the " _
              & "Outlook Draft\" & Globals.OLFolderName & " folder to the outbox." & vbCr + vbCr _
              & "If your Outlook application is configured to send items immediately then those mail items have sent or are sending. " & vbCr + vbCr _
              & "Otherwise you may select ""SEND ALL"" to synchronize OUTLOOK and send and recieve all items now or click ""CLOSE"" to end this " _
              & "dialog without further action." & vbCr + vbCr _
              & "Repeat using ""Push to Outbox"" as required to send any remaining mail items in sub-sets defined.", "USER NOTIFICATION", 340, 220, , "SEND ALL", "CLOSE"

End Sub

Attribute VB_Name = "modEnhancedMergeRibCon"
Option Explicit
Private m_bState As Boolean

#If VBA7 Then
    Public Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef destination As Any, ByRef source As Any, ByVal length As Long)
#Else
    Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef destination As Any, ByRef source As Any, ByVal length As Long)
#End If
Public p_oRibbon As IRibbonUI

Public Sub EDMOnload(oRibbon As IRibbonUI)
  Set p_oRibbon = oRibbon
  m_bState = True
  ThisDocument.Variables("RXPointer") = ObjPtr(oRibbon)
  ThisDocument.Saved = True
  modGlobals.SetGlobals
lbl_Exit:
  Exit Sub
End Sub

#If VBA7 Then
  Function GetRibbon() As Object
  Dim lngRibPtr As LongPtr
  lngRibPtr = CLngPtr(ThisDocument.Variables("RXPointer"))
#Else
  Function GetRibbon() As Object
  Dim lngRibPtr As Long
  lngRibPtr = CLng(ThisDocument.Variables("RXPointer"))
#End If
  Dim oRibbon As Object
  CopyMemory oRibbon, lngRibPtr, LenB(lngRibPtr)
  Set GetRibbon = oRibbon
  Set oRibbon = Nothing
lbl_Exit:
  Exit Function
End Function

Sub Test()
  p_oRibbon.Invalidate
  Set p_oRibbon = Nothing
  If p_oRibbon Is Nothing Then Set p_oRibbon = GetRibbon
  p_oRibbon.Invalidate
End Sub

Sub AutoClose()
  ClearRibbonMemory
lbl_Exit:
  Exit Sub
End Sub

Sub ClearRibbonMemory()
  Set p_oRibbon = Nothing
lbl_Exit:
  Exit Sub
End Sub

Sub ButtonOnAction(Control As IRibbonControl)
Dim strMute As String
Dim oFrm As frmDataSource
Dim strSource As String
Dim oCC As ContentControl
Dim oRng As Word.Range

  If Documents.Count = 0 Then SetGlobals
  If Globals.AddInID = vbNullString Then modGlobals.SetGlobals
  Select Case Control.ID
    Case "EDM_Btn01"
      If Documents.Count = 0 Then
        ShowMsg 2, , "There is no merge template opened to process." & vbCr + vbCr _
               & "Open the merge template file you want to process and try again.", "USER NOTIFCATION", 340, 100, , "OK"
        Unload frmMsg
        Documents.Open modUtilities.fcnFileDialogFile("Open the merge template you want to edit:")
        Exit Sub
      End If
      If ActiveDocument.MailMerge.MainDocumentType <> wdNotAMergeDocument Then
        ShowMsg 2, , "Enhanced Merge has detected a mail merge document. Enhanced Merge is not designed " _
               & "to use mail merge documents or merge fields. Enhanced Merge uses content controls as data field identifiers." & vbCr + vbCr _
               & "You can use the add-in ""Merge Template Tools - Convert Mail Merge Fields"" to convert the document type and to convert most basic merge fields " _
               & "to content controls.", _
               "USER NOTIFICATION/ACTION REQUIRED", 400, 145, , "OK"
        Unload frmMsg
        GoTo lbl_Exit
      End If
      If ActiveDocument.Windows(1).View.ShowFieldCodes = True Then
        ActiveDocument.Windows(1).View.ShowFieldCodes = False
      End If
      Set Globals.CC_IDs = modUtilities.fcnGetMergeTemplateCCCollection(ActiveDocument)
      If Documents.Count = 0 Or Globals.CC_IDs.Count = 0 Then
        ShowMsg 2, , "Enhanced Merge is designed for use with a document or template opened and containing " _
               & "content controls used as data field identifiers." & vbCr + vbCr _
               & "Open the appropriate document\template or add appropriate content controls to the existing document\template and try again!", _
               "USER NOTIFICATION/ACTION REQUIRED", 400, 125, , "OK"
        Unload frmMsg
        GoTo lbl_Exit
      End If
      On Error Resume Next
      'Verify a data source is associated with the document or template.
      Globals.DataValidity = -999
      With ActiveDocument
        Globals.DataSourcePath = .Variables("DataSourcePath")
        Globals.DS_SheetOrTableName = .Variables("DataTableOrSheetName")
        Globals.DataValidity = .Variables("DataValidity")
        On Error GoTo 0
        If Globals.DataSourcePath = vbNullString Then .Variables("DataSourcePath").value = "~*~Undefined~*~"
        If Globals.DS_SheetOrTableName = vbNullString Then .Variables("DataTableOrSheetName").value = "~*~Undefined~*~"
        If Globals.DataValidity = -999 Then .Variables("DataValidity").value = -999
        If Not modUtilities.fcnFileExists(Globals.DataSourcePath) Or .Variables("DataTableOrSheetName").value = "~*~Undefined~*~" _
                                      Or .Variables("DataValidity").value = -999 Then
          Set oFrm = New frmDataSource
          oFrm.Show
          Unload oFrm
          Set oFrm = Nothing
        End If
      End With
      If Not modUtilities.fcnFileExists(Globals.DataSourcePath) Or Globals.DS_SheetOrTableName = "~*~Undefined~*~" Then
        ShowMsg 2, , "A data source (Access or Excel) must exist and be assoicated with the merge document or template." & vbCr + vbCr _
              & "Click ""Set or Change Data Source"" in the ribbon ""Utilities"" group to select and associate a data source.", _
              "USER NOTIFICATION/ACTION REQUIRED", 400, 130, , "OK"
        Unload frmMsg
        GoTo lbl_Exit
      End If
      

      'Force disclaimer presentation and update defaults on new version and new user.
      If Not modUtilities.AppVer = GetSetting(Globals.AddInID, "Config", "Current Version") Or _
         Not GetSetting(AppID, "Config", "Current User") = GetSetting(Globals.AddInID, "Config", "Current User") Then
        modUtilities.ResetRegistryAndDefaults True
      End If
      modEnhancedMerge.EnhancedMergeMainRouting
  
    Case Is = "EDM_Btn02"
      If Documents.Count > 0 Then
        Set oRng = Selection.Range
        oRng.Collapse wdCollapseStart
        Set oCC = oRng.ContentControls.add(wdContentControlRichText)
        With oCC
          .Tag = "Independent List"
          .SetPlaceholderText , , "Independent List"
        End With
        Else
        ShowMsg 2, , "There is no merge template opened to edit." & vbCr + vbCr _
               & "Open the merge template you want to edit and try again.", "USER NOTIFCATION", 340, 100, , "OK"
        Unload frmMsg
        Documents.Open modUtilities.fcnFileDialogFile("pen the merge template you want to edit:")
      End If
    Case Is = "EDM_Btn03"
      If Documents.Count > 0 Then
        modUtilities.ConvertMergeTemplateToEnhancedMergeTemplate
      Else
        ShowMsg 2, , "There is no document opened to process." & vbCr + vbCr _
               & "Open the document or template containing merge fields and try again.", "USER NOTIFCATION", 340, 100, , "OK"
        Unload frmMsg
        Documents.Open modUtilities.fcnFileDialogFile("Open the file containing the merge fields:")
      End If
    Case "EDM_Btn04": modOLFunctions.Mail_PushToOutbox
    Case "EDM_Btn05":  modOLFunctions.Mail_SendAll
    Case Is = "EDM_Btn06"
      On Error GoTo Err_Variables
      Globals.DataSourcePath = ActiveDocument.Variables("DataSourcePath")
      Globals.DS_SheetOrTableName = ActiveDocument.Variables("DataTableOrSheetName")
      Set oFrm = New frmDataSource
      oFrm.Show
      Unload oFrm
      Set oFrm = Nothing
    Case "EDM_Btn07"
       modUtilities.ResetRegistryAndDefaults
       p_oRibbon.InvalidateControl "EDM_TogBtn01"
  End Select
  If p_oRibbon Is Nothing Then Set p_oRibbon = modEnhancedMergeRibCon.GetRibbon
  On Error GoTo 0
lbl_Exit:
  Exit Sub
Err_Variables:
  ActiveDocument.Variables("DataSourcePath").value = "~*~Undefined~*~"
  ActiveDocument.Variables("DataTableOrSheetName") = "~*~Undefined~*~"
  Resume
End Sub
Sub ToggleButtonOnAction(Control As IRibbonControl, pressed As Boolean)
Dim strMute As String
  Select Case Control.ID
    Case Is = "EDM_TogBtn01"
      If pressed Then
        SaveSetting Globals.AddInID, "Config", "Mute", "False"
        ShowMsg 1, , "Notification tone is on.", "TONES", 170, , , "OK"
        m_bState = True
      Else
        SaveSetting Globals.AddInID, "Config", "Mute", "True"
        ShowMsg 1, , "Notification tone is off.", "TONES", 170, , , "OK"
        m_bState = False
      End If
      p_oRibbon.InvalidateControl "EDM_TogBtn01"
  End Select
lbl_Exit:
  Exit Sub
End Sub

Sub GetPressed(Control As IRibbonControl, ByRef returnedVal)
  If Globals.AddInID = vbNullString Then modGlobals.SetGlobals
  m_bState = GetSetting(Globals.AddInID, "Config", "Mute")
  Select Case Control.ID
    Case "EDM_TogBtn01": returnedVal = Not m_bState
  End Select
lbl_Exit:
  Exit Sub
End Sub

Sub GetLabel(Control As IRibbonControl, ByRef returnedVal)
  Select Case Control.ID
    Case "EDMTab"
     If Val(Application.Version) = 15 Then
       returnedVal = "ENHANCED MERGE"
     Else
       returnedVal = "Enhanced Merge"
     End If
    Case "EDM_TogBtn01"
      m_bState = Not CBool(GetSetting(Globals.AddInID, "Config", "Mute"))
      If m_bState Then
        returnedVal = "Notification Tone (on)"
      Else
        returnedVal = "Notification Tone (Off)"
      End If
  End Select
lbl_Exit:
  Exit Sub
End Sub

Sub GetSuperTip(Control As IRibbonControl, ByRef returnedVal)
  Select Case Control.ID
  Case "EDM_Btn01"
    returnedVal = "Intiates process to create a Many To One (or One To One) enhanced data merge to separate documents, " _
          & "or, where Outlook is the default email application, to the bodies of email messages, or as attachments to email messages" & vbCr + vbCr _
          & "The documents may be saved as Word document format or PDF format." & vbCr + vbCr _
          & "CAUTION - DO NOT ATTEMPT TO START THE MERGE IF OUTLOOK BACKUP IS RUNNING!"
   Case "EDM_Btn02"
     returnedVal = "Inserts a unique ""Independent List"" content control in the merge document or template at the cursor locaction for use in special cases e.g., a signature list." & vbCr + vbCr _
          & "For more information, review the contextual help on the ""List Field"" feature."
   Case "EDM_Btn03"
     returnedVal = "Creates an Enhanced Merge template with content controls from an existing letter type mail merge main document." & vbCr + vbCr _
           & "The letter type mail merge main documument must be open as the active document."
   Case "EDM_Btn04"
     returnedVal = "If Outlook is the default email application, this button transfers messages created in the merge process to the Outlook outbox."
  Case "EDM_Btn05"
    returnedVal = "If Outlook is the default email application, this button mimics the native Outlook ""Send\Receive All"" and sends all messages in the Outbox outbox." & vbCr + vbCr _
          & "Note - ""all messages"" includes messages not created by the enhanced merge processes."
  Case "EDM_TogBtn01"
    returnedVal = "Toggles tone (on/off) when notifications, warnings, or help dialogs are displayed. & vbCr + vbCr" _
          & "Tone used is the Windows Media ""Notify.wav"" sound clip.  If the sound file is not found the default PC ""Beep"" occurs."
  Case "EDM_Btn06"
    returnedVal = "Opens a dialog which enables you to confirm or change the data source associated with the merge template or document."
  Case "EDM_Btn07"
    returnedVal = "During processing, the add-in stores a number of settings in the registry. This button removes or returns those setting to the default new installed state." & vbCr + vbCr _
          & "If Outlook is the default email application, the process creates a temporary folder as a sub folder of the default ""Drafts"" folder." & vbCr + vbCr _
          & "This button also provides an option to remove that temporary folder and any files it contains."
  End Select
lbl_Exit:
   Exit Sub
End Sub

Sub GetEnabled(Control As IRibbonControl, ByRef returnedVal)
  On Error Resume Next
  Select Case Control.ID
    Case "EDM_Btn04"
      returnedVal = CStr(Globals.OutlookAvailable) 'GetSetting(Globals.AddInID, "Config", "Outlook Available")
    Case "EDM_Btn05"
      returnedVal = CStr(Globals.OutlookAvailable) 'GetSetting(Globals.AddInID, "Config", "Outlook Available")
  End Select
  On Error GoTo 0
lbl_Exit:
   Exit Sub
End Sub
…