Блог

Я собрал некоторый код VBA для Outlook 2007, который работает в основном нормально. В основном он предназначен для проверки входящих сообщений и сохранения темы, тела и т.д. В базе данных, А вложения — в папке. В целом, это работает нормально, но из примерно 100 сообщений оно удаляет нечетное электронное письмо.

Ранее у меня была проблема, когда некоторые электронные письма не обрабатывались и не сохранялись в базе данных, но затем обнаружилась проблема с недопустимыми символами, которую я решил сейчас, так что этого не может быть. Я сравнил удаляемые электронные письма с теми, которые отсутствуют, с точки зрения заголовка сообщения, содержимого полей «в» и «из», и я вообще не вижу никакой разницы между двумя электронными письмами, поэтому я полностью озадачен тем, почему они удаляются. Когда я копирую содержимое электронного письма и снова пересылаю его обратно в систему, код VBA обрабатывает его нормально.

Я вставляю приведенный ниже код (код ссылается на некоторые модули, которые используются для проверки недопустимых символов или объединения строк)

 Sub SaveIncomingEmails(Items As Outlook.MailItem) ' enable this to run macro inbound emails

Dim cnn As ADODB.Connection
   Set cnn = New ADODB.Connection

' ================================================================
' Open a Connection using an ODBC DSN named "Delphi".
' ================================================================

cnn.Open "MyDB", "MyUsername", "MyPassword"


' ================================================================
' Constants declaration
' ================================================================
    Const olFolderInbox = 6
    Const olTxt = 0



' ================================================================
' variable declaration
' ================================================================

    Dim ns As NameSpace
    Dim Inbox As MAPIFolder
    Dim Item As Object
    Dim Atmt As Attachment
    Dim FileName As String
    Dim SenderName As String
    Dim i As Integer

    Dim strSQLquery As String
    Dim strSQLquery1 As String
    Dim strSQLGTDResourceQuery As String
    Dim MessageHeader As String
    Dim strCommandQuery As String
    Dim strGTDIdQuery As String
    Dim AttachmentStr As String
    Dim strFailedRcp As String
    Dim strSubject As String
    Dim hasattachment As String
    Dim AttachmentType As String
    Dim SenderAuthorised As String


    Dim strToEmail As String
    Dim strFromEmail As String

    Dim strBody As String
    Dim strSentDate As String
    Dim strReceivedDate As String
    Dim StrUniqueID As String
    Dim strCommandDate As String
    Dim strDomain As String
    Dim strBodyStripped As String

    Dim strSubjectStripped As String
    Dim rs As Object
    Dim strGoalId As String
    Dim strFile As String

   Dim strSenderAccountDescription As String
   Dim strContentType As String
   Dim strMimeVersion As String
   Dim strReceived As String



' ================================================================
'   Intializing variables
' ================================================================

    i = 0

    Set objItem = Items

    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    Set objOutlook = CreateObject("Outlook.Application")
    Set objNamespace = objOutlook.GetNamespace("MAPI")
    Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox)

    Set colMailItems = objFolder.Items
    Set Item = objItem

    strToEmail = Items.To
    strFromEmail = Items.SenderEmailAddress
    strSubject = Items.Subject
    strBody = Items.Body
    strSentDate = Items.SentOn
    strReceivedDate = Items.ReceivedTime

    'Initialize variables in a given format
    StrUniqueID = Format(Items.ReceivedTime, "ddmmyyyyhhnnss") amp; Items.SenderEmailAddress
    strCommandDate = Format(Items.ReceivedTime, "mm/dd/yyyy_hh:nn:ss")


    ' Grab the sender domain by stripping the last portion of the email address using the getdomain function
    strDomain = Module2.GetDomain(Items.SenderEmailAddress)

    ' Strip the body of illegal characters and replace with legal characters for insertion into SQL
    strBodyStripped = Module3.RemoveIllegalCharacters(Items.Body)
    strSubjectStripped = Module4.RemoveIllegalCharacters(Items.Subject)
    AttachmentStr = "images/no_attachment.png"

' ================================================================
' ================================================================
' ================================================================


' =====================================================
' Check list of authorised senders for xsCRM commands.
' Populate email addresses here
' =====================================================

If (InStr(strFromEmail, "AuthorisedSender1@email.com") > 0) Or (InStr(strFromEmail, "AuthorisedSender2@email.com") > 0) Or (InStr(strFromEmail, "AuthorisedSender3@email.com") > 0) Then

SenderAuthorised = "true"
End If



' ======================================================
' ======================================================
' ======================================================


' ================================================================
'  check if subject holds a command
' ================================================================
   'check to see if email sender is authorised
           If SenderAuthorised = "true" Then

    ' Check if the subject line contains the string xs4crm is true
   If InStr(strSubject, "xs4crm") > 0 Then


   'If its true then do this
   strCommandQuery = "INSERT INTO XSCRMEMAILCOMMAND (" amp; vbCrLf amp; _
           "FromEmail," amp; vbCrLf amp; _
           "command," amp; vbCrLf amp; _
           "date," amp; vbCrLf amp; _
           "Body" amp; vbCrLf amp; _
           ") VALUES ('" amp; strFromEmail amp; "','" amp; strSubject amp; "',GETDATE(),'" amp; strBody amp; "')"

           Set rs = cnn.Execute(strCommandQuery)




           'Look for a GTDID string so that we can save data to resources table
           If InStr(strSubject, "gtdid=") > 0 Then

          'Set the hasattachment variable to zero since we only want to run this loop if there are no attachments
          hasattachment = "0"

          'Set the variable to 1 so that we that our next if statement can only run if there are no attachments
          For Each Atmt In Item.Attachments
            hasattachment = "1"
          Next Atmt              


          If hasattachment = "0" Then

             'Grab the GTDId so we know which goal this resource belongs too.
             strGoalId = Module5.GetHeaderProperty(strSubject, "gtdid=", ";", 5)


            'Save data to table
             strGTDIdQuery = "INSERT INTO XSCRMGTDRESOURCES (" amp; vbCrLf amp; _
             "GoalId," amp; vbCrLf amp; _
             "insertdatetime" amp; vbCrLf amp; _
             ") VALUES ('" amp; strGoalId amp; "',GETDATE())"

             Set rs = cnn.Execute(strGTDIdQuery)

          End If

           End If
    End If
    End If


' ================================================================
' ================================================================
' ================================================================



' ================================================================
'  Create folders for atttachments
' ================================================================

    ' Save any attachments found
    For Each Atmt In Item.Attachments

    AttachmentStr = "images/attachment.png"  'because it has gone into attachment loop the icon is now required.

    'Create the subfolder for the attachment if it doesnt exist based on sender domain

    Dim fso
    Dim fol As String
    fol = "c:OLAttachments" amp; strDomain
    Set fso = CreateObject("Scripting.FileSystemObject")

    If Not fso.FolderExists(fol) Then
      fso.CreateFolder (fol)
    End If


' ================================================================
' ================================================================
' ================================================================



' ================================================================
'  save attachments
' ================================================================

  FileName = "C:OLAttachments" amp; strDomain amp; "" amp; _
  Format(Item.CreationTime, "ddmmyyyy-") amp; Items.SenderEmailAddress amp; "-" amp; Atmt.FileName
  Atmt.SaveAsFile FileName


            i = i   1

        strFile = Atmt.FileName

        strSQLquery1 = "INSERT INTO XSCRMEMAILSATTACHMENTS (" amp; vbCrLf amp; _
           "FileSavedIn," amp; vbCrLf amp; _
           "ActualFileName," amp; vbCrLf amp; _
           "UniqueIdentifier," amp; vbCrLf amp; _
           "SendersEmail" amp; vbCrLf amp; _
           ") VALUES ('" amp; FileName amp; "','" amp; StrUniqueID amp; "','" amp; strFile amp; "','" amp; strFromEmail amp; "')"


          Set rs = cnn.Execute(strSQLquery1)



          'If there is a GTDCommand, then grab the GTDId so we know which goal this resource belongs too.
             If InStr(strSubject, "gtdid=") > 0 Then
             strGoalId = Module5.GetHeaderProperty(strSubject, "gtdid=", ";", 5)
             End If




        AttachmentType = ""

        'If the attachment is png or jpg set attachment type string to image
        If (InStr(Atmt.FileName, ".png") > 0) Or (InStr(Atmt.FileName, ".jpg") > 0) Then
          AttachmentType = "image"
        End If

        'If attachment is .mov set attachment type string to video
        If InStr(Atmt.FileName, ".mov") > 0 Then
          AttachmentType = "video"
        End If

        'If the attachment is mp3 or m4a set attachment type string to audio
        If (InStr(Atmt.FileName, ".mp3") > 0) Or (InStr(Atmt.FileName, ".m4a") > 0) Then
          AttachmentType = "audio"
        End If



         'check to see if email sender is authorised
           If SenderAuthorised = "true" Then

          'If attachment type is an image, audio or video as per extensions above then populate the xscrmgtdresource table with following fields
         If (InStr(Atmt.FileName, ".png") > 0) Or (InStr(Atmt.FileName, ".jpg") > 0) Or (InStr(Atmt.FileName, ".mov") > 0) Or (InStr(Atmt.FileName, ".m4a") > 0) Or (InStr(Atmt.FileName, ".mp3") > 0) Then
              strSQLGTDResourceQuery = "INSERT INTO XSCRMGTDRESOURCES (" amp; vbCrLf amp; _
              "GoalId," amp; vbCrLf amp; _
              "Title," amp; vbCrLf amp; _
              "Type," amp; vbCrLf amp; _
              "insertdatetime," amp; vbCrLf amp; _
              "ResourcePath," amp; vbCrLf amp; _
              "UniqueIdentifier" amp; vbCrLf amp; _
            ") VALUES ('" amp; strGoalId amp; "','" amp; Atmt.FileName amp; "','" amp; AttachmentType amp; "',GETDATE(),'" amp; FileName amp; "','" amp; StrUniqueID amp; "')"


          End If

          Set rs = cnn.Execute(strSQLGTDResourceQuery)

          End If


   Next Atmt

' ================================================================
' ================================================================
' ================================================================


' ================================================================
'  Setting up to work with the Email Message Header
' ================================================================
  'This accesses the message header property and sets the variable MessageHeader
  Const PR_TRANSPORT_MESSAGE_HEADERS = "http://schemas.microsoft.com/mapi/proptag/0x007D001E"
  MessageHeader = objItem.PropertyAccessor.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS)
  If MessageHeader <> "" Then

  End If
' ================================================================
' ================================================================
' ================================================================


' ================================================================
' Accessing the message header and collecting specific info for database tables
' ================================================================


 strSenderAccountDescription = Module5.GetHeaderProperty(MessageHeader, "From:", "<", 5)
 strContentType = Module5.GetHeaderProperty(MessageHeader, "Content-Type:", ";", 13)
 strMimeVersion = Module5.GetHeaderProperty(MessageHeader, "MIME-Version:", vbNewLine, 13)
 strReceived = Module5.GetHeaderProperty(MessageHeader, "Received:", "(", 9)

 'As the x-failed-recipients property does not appear in ALL messageheaders, we have to first check if it is present
 If InStr(MessageHeader, "X-Failed-Recipients:") > 0 Then
 'Get the MessageHeader Property value
 strFailedRcp = Module5.GetHeaderProperty(MessageHeader, "X-Failed-Recipients:", vbNewLine, 20)


 'Else set the variable value to blank so that we still have something to supply to the SQL query
 Else
 strFailedRcp = ""
 End If


' ================================================================
' ================================================================
' ================================================================


' ================================================================
' Save Email into the database DeplphiDude and table xsCRMEmails for attachment based emails and without attachments
' ================================================================


   If InStr(strSubject, "xs4crm") = 0 Then 'only insert if the emails is not a command

   strSQLquery = "INSERT INTO XSCRMEMAILS (" amp; vbCrLf amp; _
           "XFailedRecipients," amp; vbCrLf amp; _
           "Received," amp; vbCrLf amp; _
           "MimeVersion," amp; vbCrLf amp; _
           "ContentType," amp; vbCrLf amp; _
           "SendersAccountDescription," amp; vbCrLf amp; _
           "FromEmail," amp; vbCrLf amp; _
           "ToEmail," amp; vbCrLf amp; _
           "Subject," amp; vbCrLf amp; _
           "Body," amp; vbCrLf amp; _
           "SentDate," amp; vbCrLf amp; _
           "ReceivedDate," amp; vbCrLf amp; _
           "UniqueIdentifier," amp; vbCrLf amp; _
           "Status," amp; vbCrLf amp; _
           "AttachmentIcon," amp; vbCrLf amp; _
           "AssignedToUser," amp; vbCrLf amp; _
           "EmailHeader" amp; vbCrLf amp; _
           ") VALUES ('" amp; strFailedRcp amp; "','" amp; strReceived amp; "','" amp; strMimeVersion amp; "','" amp; strContentType amp; "','" amp; strSenderAccountDescription amp; "', '" amp; strFromEmail amp; "','" amp; strToEmail amp; "','" amp; strSubjectStripped amp; "','" amp; strBodyStripped amp; "','" amp; strSentDate amp; "','" amp; strReceivedDate amp; "','" amp; StrUniqueID amp; "','EmailStatus_New','" amp; AttachmentStr amp; "','','" amp; Module4.RemoveIllegalCharacters(MessageHeader) amp; "')"


          Set rs = cnn.Execute(strSQLquery)
   End If




' ================================================================
'  final steps
' ================================================================ 

'Delete email
objItem.Delete


Set objItem = Nothing
Set Atmt = Nothing


' ================================================================
'  close connection to the sql server and end the program
' ================================================================

cnn.Close


End Sub
  

Вам следует добавить некоторые записи в журнал, чтобы помочь отследить проблему.

Я не использовал это лично, но, возможно, попробую: Log4VBA

Кроме того, вам следует добавить обработку ошибок:

• Советы по обработке ошибок и отладке для Access 2007, VB и VBA

• Обработка ошибок в VBA

Во-первых, вы не говорите, какая часть вашего процесса не работает. Вы показали процедуру, которая не запускается сама по себе, она должна быть вызвана чем-то другим. К этому чему-то еще должны быть привязаны некоторые условия для вызова вашей процедуры. Что это такое? Можете ли вы показать, как это работает.

Если вы используете правило, не могли бы вы показать условия правила. Далее, что, если вместо правила мы закодируем событие в VBEditor, чтобы вы, возможно, могли увидеть, что это событие также происходит? Вот о чем я говорю, и там есть пример кода о том, как это сделать MSDN Application_New_MAIL

Далее я согласен со всеми остальными, что вам нужно немного протоколировать, так много всего происходит, и невозможно сказать, где вы зависаете. На вашем месте я бы получил электронное письмо, которое не работает, и отправил его самому себе, установив точку останова в самом начале вашего кода, чтобы вы могли видеть a. Что ваш код на самом деле вызывается, а затем происходит сбой.