Vba - первенствовать - внешний вид - отчет по электронной почте заголовки и автоматически отправить сообщение на адрес электронной почты нового

Question

мне нужно немного помочь, я полностью потерял в моем коде ...

Мой код должен использоваться в разных учетных записей перспектив, которые используют разные учетные записи электронной почты и должны экспортировать заголовки электронной почты в порядке их поступления в один лист 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 

так Перспективы ничего не знает о перечислениях 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"))