Question

我需要一点帮助，我的代码完全丢失了......

我的代码将用于使用不同电子邮件帐户的不同Outlook帐户，并应按照到达的顺序将电子邮件标头导出到单个Excel工作表（用作数据库），以备份到达的电子邮件，标记为使用数字唯一协议自动读取和响应。

显然，如果先前已经处理过该电子邮件，则希望该过程可能已过世，并且只会新来的电子邮件到达。

目前我的代码部分工作，因为有时新电子邮件的到达不会将数据写入Excel电子表格的最后一行，而是写入第一行，覆盖现有的数据。

但是，如果我将代码与其他电子邮件帐户一起使用，该脚本会完全删除Excel工作表中的数据，并仅将新数据返回到新的电子邮件帐户。

有关如何解决问题的任何建议？非常感谢。

This is the code:

Sub Mail_Protocol()

Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String
Dim olItem As Outlook.MailItem
Dim strColB, strColC, strColD, strColE, strColF, strColG As String
Dim objns As Outlook.NameSpace
Dim objName As Outlook.MAPIFolder
Dim objFolder As Outlook.MAPIFolder
Dim objItems As Outlook.Items
Dim obj As Object
Dim strbody As String
Dim oMail As Outlook.MailItem
Dim objItem As Object
Dim sPath As String
Dim dtDate As Date
Dim sName As String

' Get Excel set up
enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
strPath = enviro & "\Desktop\DataBase.xlsx"
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
'Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Foglio1")

' Process the message record

On Error Resume Next

xlSheet.Cells(1, 1) = "prot"
xlSheet.Cells(1, 2) = "email"
xlSheet.Cells(1, 3) = "name"
xlSheet.Cells(1, 4) = "object"
xlSheet.Cells(1, 5) = "message"
xlSheet.Cells(1, 6) = "receiver"
xlSheet.Cells(1, 7) = "date"

'Find the next empty line of the worksheet

rCount = xlSheet.Cells("B" & xlSheet.Rows.Count).End(xlUp).Row
rCount = rCount + 1


Set objns = GetNamespace("MAPI")
Set objName = objns.Folders("OneOfMyEmail@email.com")
Set objFolder = objName.Folders("Posta in arrivo")
Set objItems = objFolder.Items


For Each obj In objItems

Set olItem = obj
Set objMsg = Application.CreateItem(olMailItem)


'if email value exist in databese skip to next

If xlSheet.Range("E" & rCount + 1) <> olItem.Body _
And xlSheet.Range("D" & rCount + 1) <> olItem.Subject Then

'collect the fields
strColB = olItem.SenderName
strColC = olItem.SenderEmailAddress
strColG = olItem.Subject
strColD = olItem.Body
strColE = olItem.To
strColF = olItem.ReceivedTime

'write them in the excel sheet

xlSheet.Range("A" & rCount + 1) = rCount
xlSheet.Range("B" & rCount + 1) = strColB
xlSheet.Range("C" & rCount + 1) = strColC
xlSheet.Range("D" & rCount + 1) = strColG
xlSheet.Range("E" & rCount + 1) = strColD
xlSheet.Range("F" & rCount + 1) = strColE
xlSheet.Range("G" & rCount + 1) = strColF


'-----------------Send Email Protocol--------------------
strbody = "Buongiorno," & vbNewLine & vbNewLine & _
      "Questo è un messsaggio generato automaticamente, si prega di non    rispondere." & vbNewLine & vbNewLine & _
      "La sua email è stata correttamente ricevuta." & vbNewLine & _
      "Il suo numero protocollo è : " & rCount & vbNewLine & _
      "La sua richiesta verrà evasa quanto prima." & vbNewLine & vbNewLine & _
      "Distinti saluti."

On Error Resume Next
With objMsg
    .To = olItem.SenderEmailAddress
    .CC = ""
    .BCC = ""
    .Subject = "RICEZIONE EMAIL - PROTOCOLLO N. " & rCount
    .Body = strbody
    .Send   'or use .Display
End With
On Error GoTo 0

'-----------------Backup Email---------------------------

Set oMail = obj
sName = oMail.Subject
ReplaceCharsForFileName sName, "-"
dtDate = oMail.ReceivedTime
sName = "P.g." & rCount & "_" & Format(dtDate, "dd.mm.yy", vbUseSystemDayOfWeek, _                        
vbUseSystem) & "_" & "" & sName & ".msg"
sPath = enviro & "\Desktop\"
Debug.Print sPath & sName
oMail.SaveAs sPath & sName, olMSG
obj.UnRead = True

Else: GoTo prossimo

End If

prossimo:
rCount = rCount + 1
Next


xlWB.Close 1
If bXStarted Then
xlApp.Quit
End If

Set olItem = Nothing
Set obj = Nothing
Set Items = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing

End Sub

Private Sub ReplaceCharsForFileName(sName As String, sChr As String)

sName = Replace(sName, "'", sChr)
sName = Replace(sName, "*", sChr)
sName = Replace(sName, "/", sChr)
sName = Replace(sName, "\", sChr)
sName = Replace(sName, ":", sChr)
sName = Replace(sName, "?", sChr)
sName = Replace(sName, Chr(34), sChr)
sName = Replace(sName, "<", sChr)
sName = Replace(sName, ">", sChr)
sName = Replace(sName, "|", sChr)

End Sub

这应该是结果

Answer 1

主要问题在于：

rCount = xlSheet.Cells("B" & xlSheet.Rows.Count).End(xlUp).Row

因为Outlook对Excel枚举一无所知，所以它会将xlUp评估为零，从而使End(0) Range方法抛出一个将被忽略的错误通过裁定On Error Resume Next错误处理，最终使rCount保持其初始化值zero

所以你必须要么：

使用早期绑定，将Microsoft Excel XY.Z库引用添加到项目中

然后
```
   Dim xlApp As Excel.Application
   ' ...and so on
```
保持延迟绑定（就像你现在一样）并使用实际的枚举值（-4162）代替xlUp
```
 rCount = xlSheet.Cells("B" & xlSheet.Rows.Count).End(-4162).Row
```

仍然不确定您的电子邮件处理流量，但您可能需要考虑以下部分重构代码：

Option Explicit

Sub Mail_Protocol()

    Dim xlApp As Object
    Dim rCount As Long
    Dim bXStarted As Boolean
    Dim enviro As String
    Dim strPath As String
    Dim strColB As String, strColC As String, strColD As String, strColE As String, strColF As String, strColG As String
    Dim objns As Outlook.NameSpace
    Dim objItems As Outlook.Items
    Dim objItem As Outlook.MailItem
    Dim strbody As String
    Dim sPath As String
    Dim dtDate As Date
    Dim sName As String

    MsgBox xlUp
    Set objItems = GetNamespace("MAPI").Folders("OneOfMyEmail@email.com").Folders("Posta in arrivo").Items

    ' Get Excel set up
    Set xlApp = GetExcel(bXStarted) '<-- get Excel
    If xlApp Is Nothing Then Exit Sub

    enviro = CStr(Environ("USERPROFILE"))
    'the path of the workbook
    strPath = enviro & "\Desktop\DataBase.xlsx"
    'Open the data workbook and reference its worksheet where to put them into
    With xlApp.Workbooks.Open(strPath).Sheets("Foglio1")

        ' write headers
        .Range("A1:G1") = Array("prot", "email", "name", "object", "message", "receiver", "date")

        'Find the next empty line of the worksheet
        rCount = .Cells(.Rows.Count, "B").End(-4162).Row + 1

        For Each objItem In objItems

            'if email value exist in database skip to next

            If .Range("E" & rCount + 1) <> objItem.Body _
            And .Range("D" & rCount + 1) <> objItem.Subject Then
                'write them in the excel sheet
                .Range("A" & rCount + 1).resize(, 7) = GetInfoArray(objItem, rCount)

                '-----------------Send Email Protocol--------------------
                strbody = "Buongiorno," & vbNewLine & vbNewLine & _
                      "Questo è un messsaggio generato automaticamente, si prega di non    rispondere." & vbNewLine & vbNewLine & _
                      "La sua email è stata correttamente ricevuta." & vbNewLine & _
                      "Il suo numero protocollo è : " & rCount & vbNewLine & _
                      "La sua richiesta verrà evasa quanto prima." & vbNewLine & vbNewLine & _
                      "Distinti saluti."

                With Application.CreateItem(olMailItem)
                    .To = objItem.SenderEmailAddress
                    .CC = ""
                    .BCC = ""
                    .Subject = "RICEZIONE EMAIL - PROTOCOLLO N. " & rCount
                    .Body = strbody
                    .Save
        '            .Send   'or use .Display
                End With

                '-----------------Backup Email---------------------------
                sName = ReplaceCharsForFileName(objItem.Subject, "-")
                dtDate = objItem.ReceivedTime
                sName = "P.g." & rCount & "_" & Format(dtDate, "dd.mm.yy", vbUseSystemDayOfWeek, _
                vbUseSystem) & "_" & "" & sName & ".msg"
                sPath = enviro & "\Desktop\"
                Debug.Print sPath & sName
                objItem.SaveAs sPath & sName, olMSG
                objItem.UnRead = True

            Else: GoTo prossimo

            End If

prossimo:
            rCount = rCount + 1
        Next
    End With

    xlApp.ActiveWorkbook.Close 1
    If bXStarted Then xlApp.Quit

    Set objItem = Nothing
    Set xlApp = Nothing

End Sub

Private Function GetInfoArray(objItem As Outlook.MailItem, rCount As Long)
    With objItem
        GetInfoArray = Array(rCount, _
                            .SenderName, _
                            .SenderEmailAddress, _
                            .Subject, _
                             .Body, _
                             .To, _
                             .ReceivedTime)
    End With
End Function

Private Function ReplaceCharsForFileName(ByVal sName As String, sChr As String) As String
    sName = Replace(sName, "'", sChr)
    sName = Replace(sName, "*", sChr)
    sName = Replace(sName, "/", sChr)
    sName = Replace(sName, "\", sChr)
    sName = Replace(sName, ":", sChr)
    sName = Replace(sName, "?", sChr)
    sName = Replace(sName, Chr(34), sChr)
    sName = Replace(sName, "<", sChr)
    sName = Replace(sName, ">", sChr)
    sName = Replace(sName, "|", sChr)
    ReplaceCharsForFileName = sName
End Function


Private Function GetExcel(bXStarted As Boolean) As Object
    Dim xlApp As Object
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err <> 0 Then
        Application.StatusBar = "Please wait while Excel source is opened ... "
        Set xlApp = CreateObject("Excel.Application")
        bXStarted = True
    End If
    On Error GoTo 0
    Set GetExcel = xlApp
End Function

你看到我也删除了几乎所有那些On Error Resume Next，这几乎总是一个糟糕的编码习惯，只有很少的例外（比如在Set xlApp = GetObject(, "Excel.Application")语句中）< / p>

Vba - excel - Outlook - 报告电子邮件标题并在新电子邮件上自动发送消息

1 个答案: