전자 메일에서 테이블 제거

Question

일부 동료로부터 테이블이 포함 된 전자 메일을 수신하고 테이블을 넣지 않도록 요청했습니다. 거기에 테이블에서 정보를 제외하고 내가 그들을 재생할 때 재생할 수있는 방법이 있나요? 고맙습니다.

내가 objItem.Tables 에서 각 ATABLE은 표

으로

희미한 ATABLE

을 시도 aTable.Delete 다음

Answer 1

아래 루틴을 테스트하지만 내 전체 만족하고있다. 오늘은 시간이 없어서 월요일 저녁에 다시 볼 수있게 될 것입니다.

나는이 질문에 답을하지는 못했지만 이전에는 이메일 본문을 수정 한 적이 없었으며 이는 좋은 시도였습니다. 나는 그것이 쉽게 걱정되는 것을 발견했다. 사람들은 전자 메일을 신뢰하지만 프로그램 서비스에 대해 £ 500 (너무 욕심스럽지 않아 의심 스러울 것임)을 지불하는 것에 동의한다고 말하면서 누군가가 보낸 전자 메일을 개정하지 못하게하는 것은 무엇입니까?

이 코드는 Outlook 탐색기를 사용합니다. 사용자는 일부 전자 메일을 선택한 다음 매크로를 호출하여 선택한 전자 메일을 처리합니다. 매크로는 원본 이메일을 수정하지 않습니다. "with tables removed"라는 접미사가 붙은 사본을 작성하고이를 수정합니다.

매크로는 사용자가 요구하는 것을 수행하지만 사용자가 필요로하는 것이 아니라는 점을 염려합니다. 이 전자 메일에 원하는 텍스트와 포함되지 않은 테이블이 포함되어 있으면 테이블이 제거됩니다. 이러한 이메일이 여러 사람을 위해 생성되고 그 테이블을 원하지 않는 사람이 유일하다면 왜 발신자가 테이블이없는 버전을 만들지 않을지 이해할 수 있습니다. 그러나 이러한 전자 메일이 다른 미디어 유형에서 읽도록 설계된 경우 원하는 텍스트가 표 안에있을 수 있습니다. 이러한 전자 메일이 일부 멀티미디어 패키지를 사용하여 작성되는 경우 보낸 사람이 할 수있는 일은 없을 수 있습니다.

매크로에 내 진단 코드가 남았습니다. 그것을 시험해보고 그것이 당신을 위해 어떻게 작동하는지 말해주십시오.

Option Explicit 
Public Sub DeleteTables() 

    ' Deletes any tables within selected mail items. 

    ' 7Jan17 Coded. Based on Demo Explorer 

    Dim Exp As Outlook.Explorer 
    Dim HtmlBodyLc As String 
    Dim PosTabEnd As Long 
    Dim PosTabOuter As Long 
    Dim PosTabStart As Long 
    Dim ItemCrnt As MailItem 
    Dim ItemNew As MailItem 
    Dim NumNested As Long 
    Dim NumNestedMax As Long 

    Set Exp = Outlook.Application.ActiveExplorer 

    If Exp.Selection.Count = 0 Then 
    Call MsgBox("No emails selected", vbOKOnly) 
    Else 
    For Each ItemCrnt In Exp.Selection 
     Set ItemNew = ItemCrnt.Copy   ' Create copy so original not changed 
     With ItemNew 
     Debug.Print .Sender & " " & .ReceivedTime & " " & .Subject 
     .Subject = .Subject & " with tables removed" 
     HtmlBodyLc = LCase(.HtmlBody)  ' Lower case version of Html body for searching 
     NumNested = 0 ' Not within table 
     PosTabStart = InStr(1, HtmlBodyLc, "<table") 
     PosTabEnd = InStr(1, HtmlBodyLc, "</table>") 
     Do While True 
      If PosTabStart = 0 Then 
      ' No more start tags 
      Do While NumNested > 1 
       ' Search for end tags to match open start tags 
       PosTabEnd = InStr(PosTabEnd + 8, HtmlBodyLc, "</table>") 
       NumNested = NumNested - 1 
       Debug.Print NumNested & Space(1 + NumNested * 5) & PadL(PosTabEnd, 5) 
      Loop 
      If PosTabEnd > 0 And NumNested = 1 Then 
       ' Have end tag that matches outer start tag. 
       ' Everything between these two tags is part of a table 
       PosTabEnd = PosTabEnd + 8 ' Position after end tag 
       .HtmlBody = Mid(.HtmlBody, 1, PosTabOuter - 1) & _ 
          Mid(.HtmlBody, PosTabEnd) 
       Debug.Print "Delete " & PosTabOuter & " to " & PosTabEnd - 1 
       Exit Do ' All tables removed from this mail item 
      Else 
       ' Some mismatch between start and end tags. 
       Debug.Assert False 
      End If 
      End If 
      ' At least one more table 
      If PosTabStart < PosTabEnd Then 
      ' Start of next table before end of any outer table. 
      If NumNested = 0 Then 
       ' This is an outer table 
       PosTabOuter = PosTabStart 
      End If 
      NumNested = NumNested + 1 
      Debug.Print NumNested & Space(1 + NumNested * 5) & PadL(PosTabStart, 5) 
      PosTabStart = InStr(PosTabStart + 6, HtmlBodyLc, "<table") ' Find next if any 
      Else 
      ' End of previous table before start of new table. 
      PosTabEnd = PosTabEnd + 8 ' Position after end tag 
      If NumNestedMax < NumNested Then 
       NumNestedMax = NumNested 
      End If 
      Debug.Print NumNested & Space(1 + NumNested * 5) & PadL(PosTabEnd, 5) 
      NumNested = NumNested - 1 
      If NumNested = 0 Then 
       ' Have found end tag for outer table. Delete it and any nested 
       ' tables from both body and copy so they continue to match. 
       .HtmlBody = Mid(.HtmlBody, 1, PosTabOuter - 1) & _ 
          Mid(.HtmlBody, PosTabEnd) 
       HtmlBodyLc = Mid(HtmlBodyLc, 1, PosTabOuter - 1) & _ 
          Mid(HtmlBodyLc, PosTabEnd) 
       Debug.Print "Delete " & PosTabOuter & " to " & PosTabEnd - 1 
       ' Need new values for PosTabStart and PosTabEnd becauseof deletion 
       PosTabStart = InStr(PosTabOuter, HtmlBodyLc, "<table") 
       If PosTabStart = 0 Then 
        ' Last table processed 
        Exit Do 
       End If 
       PosTabEnd = InStr(PosTabOuter, HtmlBodyLc, "</table>") 
      ElseIf NumNested > 0 Then 
       ' Need to find more end tags before end tag for outer start tag found 
       PosTabEnd = InStr(PosTabEnd, HtmlBodyLc, "</table>") ' Find next if any 
      Else ' NumNested < 0 
       ' More end tags than start tags. Can do nothing about faulty Html 
       Debug.Assert False 
       Exit Do 
      End If 
      End If 
     Loop 
     Debug.Assert InStr(1, LCase(.Body), "<table") = 0 
     Debug.Assert InStr(1, LCase(.Body), "</table") = 0 
     'debug.print .subject 
     .Save 
     End With 
    Next 
    End If 
End Sub 
Function PadL(ByVal Str As String, ByVal PadLen As Long, _ 
       Optional ByVal PadChr As String = " ") As String 

    ' Pad Str with leading PadChr to give a total length of PadLen 
    ' If the length of Str exceeds PadLen, Str will not be truncated 

    ' Sep15 Coded 
    ' 20Dec15 Added code so overlength strings are not truncated 
    ' 10Jun16 Added PadChr so could pad with characters other than space 

    If Len(Str) >= PadLen Then 
    ' Do not truncate over length strings 
    PadL = Str 
    Else 
    PadL = Right$(String(PadLen, PadChr) & Str, PadLen) 
    End If 

End Function