Vba - Excel - Outlook - Bericht: E-Mail-Header und Autonachrichtens auf neue E-Mail

Question

ich eine wenig Hilfe brauchen, ich in meinem Code vollständig verloren ...

Mein Code ist, die Verwendung in verschiedenen Outlook-Konten verwendet werden verschiedene E-Mail-Konten und sollten die E-Mail-Header in der Reihenfolge ihrer Ankunft in einem einzigen Excel-Blatt exportieren (als Datenbank verwendet), um die ankommende E-Mail zu sichern, als gelesen markieren und automatisch mit einem nummernunabhängigen Protokoll antworten.

Klar, wenn die E-Mail bereits zuvor bearbeitet worden wäre, wünsche ich, dass der Prozess möglicherweise verpufft und nur neue E-Mails eintreffen.

Derzeit funktioniert mein Code teilweise, weil manchmal die Ankunft einer neuen E-Mail nicht die Daten in der letzten Zeile der Excel-Tabelle sondern in der ersten Zeile schreibt und die vorhandenen Daten überschreibt.

Wenn ich jedoch den Code mit einem anderen E-Mail-Konto verwende, löscht das Skript die Daten im Excel-Blatt vollständig und gibt nur die neuen Daten an das neue E-Mail-Konto zurück.

Irgendwelche Vorschläge, wie ich die Situation lösen kann? Vielen Dank.

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 

sollte

Answer 1

das Hauptproblem in der Folge sein ist:

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

seit Outlook weiß nichts über Excel Aufzählungen und wertet so xlUp-Null , so dass die End(0)Range Methode werfen n Fehler, die von der herrschenden On Error Resume Next Fehlerbehandlung außer Acht gelassen werden würde, die schließlich rCount Aufenthalt auf seinem Initialisierungswert machen, das sind zero

so müssen Sie entweder:

• Verwendung früh Bindung, das Hinzufügen von Microsoft Excel XY.Z Bibliothek Verweis auf Ihr Projekt

  und dann

  Dim xlApp As Excel.Application 
      ' ...and so on 
  

• Aufenthalt mit dem späten Bindung (wie Sie jetzt sind) und verwenden die tatsächlichen Enumerationswerts (die -4162 ist) anstelle von xlUp

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

Immer noch nicht sicher über Ihre E-Mail-Verarbeitung Fluss, aber Sie können wollen die folgende partielle Refactoring des Codes zu berücksichtigen:

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 

, wo Sie auch alle entfernte ich fast jene On Error Resume Next, die fast ist immer eine schlechte Codierung Praxis, mit sehr wenigen Ausnahmen (wie in der Set xlApp = GetObject(, "Excel.Application") Anweisung)