電子メールvbaからテーブルを削除

Question

私はテーブルを含む同僚の電子メールを受け取り、テーブルを置かないように頼んだことがあります。方法はありますか？テーブルから情報を取り出すのではなく、テーブルから情報を取り出そうとするのですか？ありがとうございました。

私は次

Answer 1

objItem.Tables 内の各引数aTableについては、表

aTable.Delete として

薄暗い引数aTableを試してみましたが、以下のルーチンはなく、私の全体の満足度にテストされています。私は今日の時間がなくなり、月曜日の夕方になり、私はこのことを再び見て自由になります。

私はおそらくこの質問に答えることはできませんでしたが、以前はメールの本文を修正したことはありませんでした。これは試してみるとよい言い訳でした。私はそれが気になりやすいと感じました。人々は電子メールを信じていますが、プログラミングサービスのために500ポンド（欲張りすぎてはならない、疑わしいと思わないでください）を支払うことに同意すると言う人からの電子メールを修正するのを止めるのは何ですか？

このコードはOutlook Explorerに依存しています。ユーザは、いくつかの電子メールを選択し、マクロを呼び出して、選択された電子メールを処理する。マクロは元の電子メールを修正しません。 "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