Outlook позволяет электронному письму иметь текстовое тело, тело Html и / или тело RTF. Я никогда не видел тела RTF, поэтому я не могу их комментировать. Я полагаю, что большинство электронных писем сегодня отправляются только с телом Html, а Outlook затем создает текстовое тело из тела Html в соответствии с несколькими простыми правилами. Моя причина этого убеждения заключается в том, что большинство текстовых тел соответствуют одному и тому же простому формату, но некоторые выглядят очень по-разному и явно созданы для того, чтобы хорошо выглядеть с пакетом электронной почты, который не обрабатывает Html.
Ваш существующий Код должен разбивать текстовое тело на CRLF, чтобы создать строки, которые хранятся в vText. Затем у вас есть al oop, который проверяет каждую строку в vTest. Код, который вы показываете, будет в пределах этого l oop.
. Вы показываете нам, как отображается тело Html, но это не точно показывает, как выглядит текстовое тело. Попробуйте следующий код. Если результат удовлетворительный, я покажу вам, как преобразовать его в код, который вы хотите.
Добавьте эти операторы в начало вашей процедуры:
Dim InxPart As Long
Dim LinePart() As String
Замените существующий контрольный код с этим:
If Left$(vText(i), 15) = "Customer info: " Then
LinePart = Split(Mid$(vText(i), 16), ",")
Debug.Print LinePart(0)
Debug.Print LinePart(1)
Debug.Print LinePart(4)
Debug.Assert False
Exit For
End If
Если код, кажется, ничего не делает, это означает, что код не нашел "Информация о клиенте:".
Если код останавливается в операторе Debug.Assert False, и вы должны увидеть что-то подобное в «Немедленном окне»:
John
Doe
JohnDoe@AcmeProducts.ng
Если вы это сделаете, то простое изменение в моем коде даст эффект, который вы ищете. Если нет, нам нужно будет более подробно изучить текст вашего тела.
Редактировать Код, разрешающий расследование.
InStr найдет подстроку в любом месте строки , Left$ требует подстроки для начала строки. Возможно, есть одно или несколько ведущих мест. Возможно, здесь больше встроенных пространств, чем на дисплее. Возможно, есть неразрывные пробелы. Вместо того, чтобы экспериментировать, посмотрите, что работает, давайте проведем правильную диагностику.
Пожалуйста, добавьте эту функцию в ваш модуль.
Public Function TidyTextForDspl(ByVal Text As String) As String
' Tidy Text for display by replacing white space with visible strings:
' Leave single space unchanged
' Replace single LF by ‹lf›
' Replace single CR by ‹cr›
' Replace single TB by ‹tb›
' Replace single non-break space by ‹nbs›
' Replace single CRLF by ‹crlf›
' Replace multiple spaces by ‹n s› where n is number of repeats
' Replace multiple LFs by ‹n lf› of white space character
' Replace multiple CRs by ‹cr› or ‹n cr›
' Replace multiple TBs by ‹n tb›
' Replace multiple non-break spaces by ‹n nbs›
' Replace multiple CRLFs by ‹n crlf›
' 15Mar16 Coded
' 3Feb19 Replaced "{" (\x7B) and "}" (\x7D) by "‹" (\u2039) and "›" (\u203A)
' on the grounds that the angle quotation marks were not likely to
' appear in text to be displayed.
' 5Feb19 Add code to treat CRLF as unit
' 28Mar19 Code to calculate PosWsChar after "<x>...<x>" converted to "<n x>"
' incorrect if "<x>...<x>" at the start of the string. Unlikely it
' was correct in other situations but this did not matter since the
' calculated value would be before the next occurrence of "<x>...<x>".
' But, if the string was near the beginning of the string, the
' calculated value was negative and the code crashed.
Dim InsStr As String
Dim InxWsChar As Long
Dim NumWsChar As Long
Dim PosWsChar As Long
Dim RetnVal As String
Dim WsCharCrnt As Variant
Dim WsCharValue As Variant
Dim WsCharDspl As Variant
WsCharValue = VBA.Array(" ", vbCr & vbLf, vbLf, vbCr, vbTab, Chr(160))
WsCharDspl = VBA.Array("s", "crlf", "lf", "cr", "tb", "nbs")
RetnVal = Text
' Replace each whitespace individually
For InxWsChar = 0 To UBound(WsCharValue)
RetnVal = Replace(RetnVal, WsCharValue(InxWsChar), "‹" & WsCharDspl(InxWsChar) & "›")
Next
' Look for repeats. If found replace <x> by <n x>
For InxWsChar = 0 To UBound(WsCharValue)
'Debug.Assert InxWsChar <> 1
PosWsChar = 1
Do While True
InsStr = "‹" & WsCharDspl(InxWsChar) & "›"
PosWsChar = InStr(PosWsChar, RetnVal, InsStr & InsStr)
If PosWsChar = 0 Then
' No [more] repeats of this <x>
Exit Do
End If
' Have <x><x>. Count number of extra <x>x
NumWsChar = 2
Do While Mid(RetnVal, PosWsChar + NumWsChar * Len(InsStr), Len(InsStr)) = InsStr
NumWsChar = NumWsChar + 1
Loop
RetnVal = Mid(RetnVal, 1, PosWsChar - 1) & _
"‹" & NumWsChar & " " & WsCharDspl(InxWsChar) & "›" & _
Mid(RetnVal, PosWsChar + NumWsChar * Len(InsStr))
PosWsChar = PosWsChar + Len(InsStr) + Len(NumWsChar)
Loop
Next
' Restore any single spaces
RetnVal = Replace(RetnVal, "‹" & WsCharDspl(0) & "›", " ")
TidyTextForDspl = RetnVal
End Function
Пожалуйста, добавьте что-то вроде этого выше l oop:
Debug.Print TidyTextForDspl(Mid$(.Body, 1, 200))
Согласно комментарию Нитона, было бы полезно, если бы вы включили больше своего кода. Я написал .Body, но вам может понадобиться MyMailItem.Body или что-то подобное.
Мое утверждение отображает первые 200 символов текстового тела с каждым пробелом, переводом каретки и переводом строки, чтобы мы могли точно знать, что там. Я предполагаю, что строка «Информация о клиенте» находится в начале текста. Если он еще ниже, вам нужно будет увеличить 1. Нам нужно увидеть строку выше и строку ниже, а также всю строку «Информация о клиенте», чтобы мы могли знать, как лучше извлечь части строки .
Пожалуйста, добавьте вывод, созданный оператором Debug.Print, к вашему вопросу или комментарию.