New Excel Forum

This forum has been moved to TeachExcel.com

Ask all future questions in the New Excel Forum.

ExcelKey

Modify Outlook code

Macros, VBA, Excel Automation, etc.

Modify Outlook code

Postby jsoros60 » Tue Apr 11, 2017 10:11 am

Hi,

i found this code, how can i modify it, because even there's not a word attachment keep saying i forgot the attachment,

it works fine, it ask about attachment every time i sent an email, even though there's no keywords for attachment.

here is the code:
Code: Select all
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
  Dim bCancelSend As Boolean
  Dim sTextToSearch As String
  Dim vSearchForWord(2) As String  'used as keyword list for attachment check
  Dim iStartOfQuote As Long
  Dim iAttachmentCount As Long
  Dim i As Long
 
  'CHECK FOR BLANK SUBJECT LINE
  If Item.Subject = "" Then
    bCancelSend = MsgBox("This message does not have a subject." & vbNewLine & _
                         "Do you wish to continue sending anyway?", _
                         vbYesNo + vbExclamation, "No Subject") = vbNo
  End If
 
  'CHECK BODY AND SUBJECT FOR ATTACMENT KEYWORDS.
  'Set TextToSearch variable to message Body based on message type
  'and find start of quoted text.
  Select Case Item.BodyFormat
    Case olFormatHTML
      iStartOfQuote = InStr(Item.HTMLBody, "<DIV class=OutlookMessageHeader") - 1
      sTextToSearch = Item.HTMLBody
    Case olFormatRichText
      iStartOfQuote = InStr(Item.Body, "_____________________________________________") - 1
      sTextToSearch = Item.Body
    Case olFormatPlain
      iStartOfQuote = InStr(Item.Body, "-----Original Message-----") - 1
      sTextToSearch = Item.Body
  End Select
   
  '
  'Need to add code to get count of embedded attachments vs non-embedded attachments.
  'If user has a signature file with an image of it Attachments.Count counts it as an attachment
  'SuedoCode:
  'iAttachmentCount = (Item.Attachments.Count - EmbeddedAttchments.Count)
  '
   
  'Adjust TextToSearch if there is quoted text
  If iStartOfQuote > 0 Then sTextToSearch = Left(sTextToSearch, iStartOfQuote)
  'Add subject to search text
  sTextToSearch = sTextToSearch & " " & Item.Subject
 
 
  If Not bCancelSend Then
    If iAttachmentCount = 0 Then
     
      'Check for attachment keywords.
      'Use lowercase keywords.
      vSearchForWord(0) = "attach"  'finds attached, attachment & attaching
      vSearchForWord(1) = "enclosed"
      vSearchForWord(2) = "here it is"
     
 
 
      For i = LBound(vSearchForWord) To UBound(vSearchForWord)
        If InStr(LCase(sTextToSearch), vSearchForWord(i)) > 0 Then
          bCancelSend = MsgBox("It appears you were going to send an attachment but nothing is attached." & vbNewLine & _
                               "Do you wish to continue sending anyway?", _
                               vbYesNo + vbExclamation, "Attachment Not Found") = vbNo
          Exit For
        End If
      Next i
 
    End If
  End If
 
  'Cancel sending message if answered yes to either message box.
  Cancel = bCancelSend
 
End Sub


thank you
  • 0

jsoros60
Rookie
 
Posts: 2
Joined: Mar 29, 2017
Reputation: 0
Excel Version: 2007

Return to Macros and VBA Questions

Who is online

Users browsing this forum: Google [Bot] and 68 guests