Skip to content

Instantly share code, notes, and snippets.

@agross
Created August 31, 2010 15:17
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save agross/559184 to your computer and use it in GitHub Desktop.
Save agross/559184 to your computer and use it in GitHub Desktop.
'$Id$
'QuoteFix Macro TRUNK
'QuoteFix Macro is part of the macros4outlook project
'see http://sourceforge.net/projects/macros4outlook/ for more information
'
'For more information on Outlook see http://www.microsoft.com/outlook
'Outlook is (C) by Microsoft
'If you like this software, please write a post card to
'
'Oliver Kopp
'Schwabstrasse 70a
'70193 Stuttgart
'Germany
'
'If you don't have money (or don't like the software that much, but
'appreciate the development), please send an email to
'macros4outlook-users -> lists.sourceforge.net.
'
'For bug reports please go to our sourceforge bugtracker: http://sourceforge.net/projects/macros4outlook/support
'
'Thank you :-)
'****************************************************************************
'License:
'
'QuoteFix Macro TRUNK copyright 2006-2009 Oliver Kopp and Daniel Martin. All rights reserved.
'
'Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
'
' 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
' 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
' 3. The name of the author may not be used to endorse or promote products derived from this software without specific prior written permission.
'
'THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
'****************************************************************************
'Changelog
'
'Version 1.0a - 2006-09-14
' * first public release
'
'Version 1.1 - 2006-09-15
' * Macro %OH introduced
' * Outlook header contains "> " at the end
' * If no macros are in the signature, the default behavior of outlook (insert header and quoted text) text is used. (1.0a removed the header)
'
'Version 1.2 - 2006-09-25
' * QuoteFix now also fixes newly introduced first-level-quotes ("> text")
' * Header matching now matches the English header
'
'Version 1.2a - 2006-09-26
' * quick fix of bug introduced by reformating first-level-quotes
' (it was reformated too often)
'
'Version 1.2b - 2007-01-24
' * included on-behalf-of handling written by Per Soderlind (per [at] soderlind [dot] no)
'
'Version TRUNK - not released
' * included %C patch 2778722 by Karsten Heimrich
' * included %SE patch 2807638 by Peter Lindgren
' * check for beginning of quote is now language independent
' * added support to strip quotes of level N and greater
' * more support of alternative name formatting
' * added support of reversed name format ("Lastname, Firstname" instead of "Firstname Lastname")
' * added support of "LASTNAME firstname" format
' * if no firstname is found, then the destination is used
' * "firstname.lastname@domain" is supported
' * firstName always starts with an uppercase letter
' * added call to QuoteColorizerMacro and SoftWrapMacro (if constant USE_COLORIZER for conditional compiling is set)
' * splitted code for parsing mailtext from FixMailText() into smaller functions
' * added support of removing the sender´s signature
' * bugfix: FinishBlock() would in some cases throw error 5
' * bugfix: Prevent error 91 when mail is marked as possible phishing mail
' * Original mail is marked as read
'Ideas were taken from
' * Daniele Bochicchio
' Button integration and sample code - http://lab.aspitalia.com/35/Outlook-2007-2003-Reply-With-Quoting-Macro.aspx
' * Dominik Jain
' Outlook Quotefix. An excellent program working up to Outlook 2003: http://home.in.tum.de/~jain/software/outlook-quotefix/
'Precondition:
' * The received mail has to contain the right quotes. Wrong original quotes can not always be fixed
' > > > w1
' > >
' > > w2
' > >
' > > > w3
' won't be fixed to w1 w2 w3. How can it be known, that w2 belongs to w1 and w3?
Option Explicit
'--------------------------------------------------------
'*** Constants for conditional compiling ***
'
'Enter these constants in the VBA project properties. The lines here only document the
'available constants. Multiple entries can be separated via colon
'--------------------------------------------------------
'Should mails be colorized? (needs QuoteColorizerMacro.bas)
' USE_COLORIZER = -1
'--------------------------------------------------------
'*** Configuration constants ***
'--------------------------------------------------------
'If <> -1, strip quotes with level > INCLUDE_QUOTES_TO_LEVEL
Private Const INCLUDE_QUOTES_TO_LEVEL As Integer = -1
'At which column should the text be wrapped?
Public Const LINE_WRAP_AFTER As Integer = 75
'Private Const DATE_FORMAT As String = "yyyy-mm-dd"
'alternative date format
Private Const DATE_FORMAT As String = "dd\/MM\/yyyy at HH:mm:ss"
' Message layout.
' Reference: http://sourceforge.net/apps/mediawiki/macros4outlook/index.php?title=QuoteFix_Macro
Private Const MESSAGE_LAYOUT As String = vbCrLf & vbCrLf & "Hallo %FN," & vbCrLf & "%C" & vbCrLf & "%SN wrote on %D:" & vbCrLf & "%Q"
'Strip the sender´s signature?
Private Const STRIP_SIGNATURE As Boolean = True
'--------------------------------------------------------
'Private Const Outlook_OriginalMessage = "> -----Urspr?ngliche Nachricht-----"
Private Const Outlook_OriginalMessage = "> -----Original Message-----"
'Private Const Outlook_OriginalMessage As String = "> -----"
Private Const OUTLOOK_HEADER_INDICATOR = "From: "
Private Const OUTLOOK_HEADERFINISH As String = "> "
Private Const SIGNATURE_SEPARATOR As String = "> --"
Private Const PATTERN_QUOTED_TEXT As String = "%Q"
Private Const PATTERN_CURSOR_POSITION As String = "%C"
Private Const PATTERN_SENDER_NAME As String = "%SN"
Private Const PATTERN_SENDER_EMAIL As String = "%SE"
Private Const PATTERN_FIRST_NAME As String = "%FN"
Private Const PATTERN_SENT_DATE As String = "%D"
Private Const PATTERN_OUTLOOK_HEADER As String = "%OH"
Private Enum ReplyType
TypeReply = 1
TypeReplyAll = 2
TypeForward = 3
End Enum
Public Type NestingType
level As Integer
additionalSpacesCount As Integer
'the sum + 1 (+1 because of the trailing space)
total As Integer
End Type
'Global Variables to make code more readable (-> parameter passing gets easier)
Private result As String
Private unformatedBlock As String
Private curBlock As String
Private curBlockNeedsToBeReFormated As Boolean
Private curPrefix As String
Private lastLineWasParagraph As Boolean
Private lastNesting As NestingType
'these are the macros called by the custom buttons
Sub FixedReply()
Dim m As Object
Set m = GetCurrentItem()
Call FixMailText(m, TypeReply)
End Sub
Sub FixedReplyAll()
Dim m As Object
Set m = GetCurrentItem()
Call FixMailText(m, TypeReplyAll)
End Sub
Sub FixedForward()
Dim m As Object
Set m = GetCurrentItem()
Call FixMailText(m, TypeForward)
End Sub
Function CalcNesting(line As String) As NestingType 'changed to default scope
Dim lastQuoteSignPos As Integer
Dim I As Integer
Dim count As Integer
Dim curChar As String
Dim res As NestingType
count = 0
I = 1
Do While I <= Len(line)
curChar = mid(line, I, 1)
If curChar = ">" Then
count = count + 1
lastQuoteSignPos = I
ElseIf curChar <> " " Then
'Char is neither ">" nor " " - Quote intro ended
'leave function
Exit Do
End If
I = I + 1
Loop
res.level = count
If I <= Len(line) Then
'i contains the pos of the first character
'if there is no space i = lastQuoteSignPos + 1
'One space is normal, the others are nesting
' It could be, that there is no space
res.additionalSpacesCount = I - lastQuoteSignPos - 2
If res.additionalSpacesCount < 0 Then
res.additionalSpacesCount = 0
End If
Else
res.additionalSpacesCount = 0
End If
res.total = res.level + res.additionalSpacesCount + 1 '+1 = tailing space
CalcNesting = res
End Function
'Description:
' Strips away ">" and " " at the beginning to have the plain text
Private Function StripLine(line As String) As String
Dim res As String
res = line
Do While (Len(res) > 0) And (InStr("> ", Left(res, 1)) <> 0)
'First character is a space or a quote
res = mid(res, 2)
Loop
'Remove the spaces at the end of res
res = Trim(res)
StripLine = res
End Function
Private Function CalcPrefix(ByRef nesting As NestingType) As String
Dim res As String
res = String(nesting.level, ">")
res = res & String(nesting.additionalSpacesCount, " ")
CalcPrefix = res & " "
End Function
'Description:
' Adds the current line to unfomatedBlock and to curBlock
Private Sub AppendCurLine(ByRef curLine As String)
If unformatedBlock = "" Then
'unformatedBlock has to be used here, because it might be the case that the first
' line is "". Therefore curBlock remains "", while unformatedBlock gets <> ""
If curLine = "" Then Exit Sub
curBlock = curLine
unformatedBlock = curPrefix & curLine & vbCrLf
Else
curBlock = curBlock & IIf(curBlock = "", "", " ") & curLine
unformatedBlock = unformatedBlock & curPrefix & curLine & vbCrLf
End If
End Sub
Private Sub HandleParagraph(ByRef prefix As String)
If Not lastLineWasParagraph Then
FinishBlock lastNesting
lastLineWasParagraph = True
Else
'lastline was already a paragraph. No further action required
End If
'Add a new line in all cases...
result = result & prefix & vbCrLf
End Sub
'Description:
' Finishes the current Block
'
' Also resets
' curBlockNeedsToBeReFormated
' curBlock
' unformatedBlock
Private Sub FinishBlock(ByRef nesting As NestingType)
If Not curBlockNeedsToBeReFormated Then
result = result & unformatedBlock
Else
'reformat curBlock and append it
Dim prefix As String
Dim curLine As String
Dim maxLength As Integer
Dim I As Integer
prefix = CalcPrefix(nesting)
maxLength = LINE_WRAP_AFTER - nesting.total
Do While Len(curBlock) > maxLength
'go through block from maxLength to beginning to find a space
I = maxLength
If I > 0 Then
Do While (mid(curBlock, I, 1) <> " ")
I = I - 1
If I = 0 Then Exit Do
Loop
End If
If I = 0 Then
'No space found -> use the full line
curLine = Left(curBlock, maxLength)
curBlock = mid(curBlock, maxLength + 1)
Else
curLine = Left(curBlock, I - 1)
curBlock = mid(curBlock, I + 1)
End If
result = result & prefix & curLine & vbCrLf
Loop
If Len(curBlock) > 0 Then
result = result & prefix & curBlock & vbCrLf
End If
End If
'Resetting
curBlockNeedsToBeReFormated = False
curBlock = ""
unformatedBlock = ""
'lastLineWasParagraph = False
End Sub
'Reformat text to correct broken wrap inserted by Outlook.
'Needs to be public so the test cases can run this function.
Public Function ReFormatText(text As String) As String
Dim curLine As String
Dim rows() As String
Dim lastPrefix As String
Dim I As Integer
Dim curNesting As NestingType
Dim nextNesting As NestingType
'Reset (partially global) variables
result = ""
curBlock = ""
unformatedBlock = ""
curNesting.level = 0
lastNesting.level = 0
curBlockNeedsToBeReFormated = False
rows = Split(text, vbCrLf)
For I = LBound(rows) To UBound(rows)
curLine = StripLine(rows(I))
lastNesting = curNesting
curNesting = CalcNesting(rows(I))
If curNesting.total <> lastNesting.total Then
lastPrefix = curPrefix
curPrefix = CalcPrefix(curNesting)
End If
If curNesting.total = lastNesting.total Then
'Quote continues
If curLine = "" Then
'new paragraph has started
HandleParagraph curPrefix
Else
AppendCurLine curLine
lastLineWasParagraph = False
If (curNesting.level = 1) And (I < UBound(rows)) Then
'check if the next line contains a wrong break
nextNesting = CalcNesting(rows(I + 1))
If (CountOccurencesOfStringInString(curLine, " ") = 0) And (curNesting.total = nextNesting.total) _
And (Len(rows(I - 1)) > LINE_WRAP_AFTER - Len(curLine) - 10) Then '10 is only a rough heuristics... - should be improved
'Yes, it is a wrong Wrap (same recognition as below)
curBlockNeedsToBeReFormated = True
End If
End If
End If
ElseIf curNesting.total < lastNesting.total Then 'curNesting.level = lastNesting.level - 1 doesn't work, because ">>", ">>>", ... are also killed by Office
lastLineWasParagraph = False
'Quote is idented less. Maybe it 's a wrong line wrap of outlook?
If (I < UBound(rows)) Then
nextNesting = CalcNesting(rows(I + 1))
If nextNesting.total = lastNesting.total Then
'Yeah. Wrong line wrap found
If curLine = "" Then
'The linebreak has to be interpreted as paragraph
'new Paragraph has started. No joining of quotes is necessary
HandleParagraph lastPrefix
Else
curBlockNeedsToBeReFormated = True
'nesting and prefix have to be adjusted
curNesting = lastNesting
curPrefix = lastPrefix
AppendCurLine curLine
End If
Else
'No wrong line wrap found. Last block is finished
FinishBlock lastNesting
If curLine = "" Then
If curNesting.level <> lastNesting.level Then
lastLineWasParagraph = True
HandleParagraph curPrefix
End If
End If
'next block starts with curLine
AppendCurLine curLine
End If
Else
'Quote is the last one - just use it
AppendCurLine curLine
End If
Else
lastLineWasParagraph = False
'it's nested one level deeper. Current block is finished
FinishBlock lastNesting
If curLine = "" Then
If curNesting.level <> lastNesting.level Then
lastLineWasParagraph = True
HandleParagraph curPrefix
End If
End If
'next block starts with curLine
AppendCurLine curLine
End If
Next I
'Finish current Block
FinishBlock curNesting
'strip last (unnecessary) line feeds and spaces
Do While ((Len(result) > 0) And (InStr(vbCr & vbLf & " ", Right(result, 1)) <> 0))
result = Left(result, Len(result) - 1)
Loop
ReFormatText = result
End Function
Sub ConvertToPlainText(Message As MailItem)
If (Message.BodyFormat = olFormatPlain) Then
Exit Sub
End If
Message.BodyFormat = olFormatPlain
Dim lines() As String
lines = Strings.Split(Message.Body, vbCrLf)
Dim newBody As String
Dim I As Integer
Dim line As String
Dim shouldQuote As Boolean
shouldQuote = False
For I = 0 To UBound(lines)
line = Trim(lines(I))
If (Left(line, 6) = OUTLOOK_HEADER_INDICATOR) Then
shouldQuote = True
newBody = newBody & Outlook_OriginalMessage & vbCrLf
End If
If (shouldQuote = True) Then
newBody = newBody & OUTLOOK_HEADERFINISH & line
Else
newBody = newBody & line
End If
newBody = newBody & vbCrLf
Next
Message.Body = newBody
End Sub
Private Sub FixMailText(SelectedObject As Object, MailMode As ReplyType)
Dim TempObj As Object
'we only understand mail items, no PostItems, NoteItems, ...
If Not (TypeName(SelectedObject) = "MailItem") Then
On Error GoTo catch: 'try, catch replacement
Dim HadError As Boolean
HadError = True
Select Case MailMode
Case TypeReply:
Set TempObj = SelectedObject.Reply
TempObj.Display
HadError = False
Exit Sub
Case TypeReplyAll:
Set TempObj = SelectedObject.ReplyAll
TempObj.Display
HadError = False
Exit Sub
Case TypeForward:
Set TempObj = SelectedObject.Forward
TempObj.Display
HadError = False
Exit Sub
End Select
catch:
On Error GoTo 0 'deactivate errorhandling
If (HadError = True) Then
'reply / replyall / forward caused error
' --> just display it
SelectedObject.Display
Exit Sub
End If
End If
Dim OriginalMail As MailItem
Set OriginalMail = SelectedObject 'cast!!!
'create reply --> outlook style!
Dim NewMail As MailItem
Select Case MailMode
Case TypeReply:
Set NewMail = OriginalMail.Reply
Case TypeReplyAll:
Set NewMail = OriginalMail.ReplyAll
Case TypeForward:
Set NewMail = OriginalMail.Forward
End Select
'if the mail is marked as a possible phishing mail, a warning will be shown and
'the reply methods will return null (forward method is ok)
If NewMail Is Nothing Then Exit Sub
' Force plain text.
ConvertToPlainText NewMail
' Force signature.
NewMail.Body = MESSAGE_LAYOUT & NewMail.Body
'put the whole mail as composed by Outlook into an array
Dim BodyLines() As String
BodyLines = Split(NewMail.Body, vbCrLf)
'lineCounter is used to provide information about how many lines we already parsed.
'This variable is always passed to the various parser functions by reference to get
'back the new value.
Dim lineCounter As Long
' A new mail starts with signature -if- set, try to parse until we find the the
' original message separator - might loop until the end of the whole message since
' this depends on the International Option settings (english), even worse it might
' find some separator in-between and mess up the whole reply, so check the nesting too.
Dim MySignature As String
MySignature = getSignature(BodyLines, lineCounter)
Dim fromName As String
Dim firstName As String
Call getNames(OriginalMail, fromName, firstName)
If InStr(MySignature, PATTERN_SENDER_EMAIL) <> 0 Then
Dim senderEmail As String
senderEmail = getSenderEmailAdress(OriginalMail)
MySignature = Replace(MySignature, PATTERN_SENDER_EMAIL, senderEmail)
End If
MySignature = Replace(MySignature, PATTERN_FIRST_NAME, firstName)
MySignature = Replace(MySignature, PATTERN_SENT_DATE, Format(OriginalMail.SentOn, DATE_FORMAT))
MySignature = Replace(MySignature, PATTERN_SENDER_NAME, fromName)
Dim OutlookHeader As String
OutlookHeader = getOutlookHeader(BodyLines, lineCounter)
Dim quotedText As String
quotedText = getQuotedText(BodyLines, lineCounter)
Dim NewText As String
'create mail according to reply mode
Select Case MailMode
Case TypeReply:
NewText = quotedText
Case TypeReplyAll:
NewText = quotedText
Case TypeForward:
NewText = OutlookHeader & quotedText
End Select
'Put text in signature (=Template for text)
MySignature = Replace(MySignature, PATTERN_OUTLOOK_HEADER & vbCrLf, OutlookHeader)
If InStr(MySignature, PATTERN_QUOTED_TEXT) <> 0 Then
MySignature = Replace(MySignature, PATTERN_QUOTED_TEXT, NewText)
Else
'There's no placeholder. Fall back to outlook behavior
MySignature = vbCrLf & vbCrLf & MySignature & OutlookHeader & NewText
End If
'Calculate number of downs to sent
Dim downCount As Long
downCount = -1
If (InStr(MySignature, PATTERN_CURSOR_POSITION) <> 0) Then
downCount = CalcDownCount(PATTERN_CURSOR_POSITION, MySignature)
ElseIf InStr(MySignature, PATTERN_QUOTED_TEXT) <> 0 Then
'if PATTERN_CURSOR_POSITION is not set, but PATTERN_QUOTED_TEXT is, then the cursor is moved to the quote
downCount = CalcDownCount(PATTERN_QUOTED_TEXT, MySignature)
End If
'remove cursor_position pattern from mail text
MySignature = Replace(MySignature, PATTERN_CURSOR_POSITION, "")
NewMail.Body = MySignature
'Extensions, in case Colorize and SoftWrap are activated
#If USE_COLORIZER Then
Dim mailID As String
mailID = QuoteColorizerMacro.ColorizeMailItem(NewMail)
If (Trim("" & mailID) <> "") Then 'no error occured or quotefix macro not there...
Call QuoteColorizerMacro.DisplayMailItemByID(mailID)
Call SoftWrapMacro.ResizeWindowForSoftWrap
Else
'Display window
NewMail.Display
End If
#Else
NewMail.Display
#End If
'jump to the right place
Dim I As Integer
For I = 1 To downCount
SendKeys "{DOWN}"
Next I
'mark original mail as read
OriginalMail.UnRead = False
End Sub
Private Function getSignature(ByRef BodyLines() As String, ByRef lineCounter As Long) As String
' drop the first two lines, they're empty
For lineCounter = 2 To UBound(BodyLines)
If (InStr(BodyLines(lineCounter), Outlook_OriginalMessage) <> 0) Then
If (CalcNesting(BodyLines(lineCounter)).level = 1) Then
Exit For
End If
End If
getSignature = getSignature & BodyLines(lineCounter) & vbCrLf
Next lineCounter
End Function
Private Function getSenderEmailAdress(ByRef OriginalMail As MailItem) As String
Dim senderEmail As String
If OriginalMail.SenderEmailType = "SMTP" Then
senderEmail = OriginalMail.SenderEmailAddress
ElseIf OriginalMail.SenderEmailType = "EX" Then
Dim gal As Outlook.AddressList
Dim exchAddressEntries As Outlook.AddressEntries
Dim exchAddressEntry As Outlook.AddressEntry
Dim I As Integer, found As Boolean
'FIXME: This seems only to work in Outlook 2007
Set gal = OriginalMail.Session.GetGlobalAddressList
Set exchAddressEntries = gal.AddressEntries
'check if we can get the correct item by sendername
Set exchAddressEntry = exchAddressEntries.item(OriginalMail.SenderName)
If exchAddressEntry.Name <> OriginalMail.SenderName Then Set exchAddressEntry = exchAddressEntries.GetFirst
found = False
While (Not found) And (Not exchAddressEntry Is Nothing)
found = (LCase(exchAddressEntry.Address) = LCase(OriginalMail.SenderEmailAddress))
If Not found Then Set exchAddressEntry = exchAddressEntries.GetNext
Wend
If Not exchAddressEntry Is Nothing Then
senderEmail = exchAddressEntry.GetExchangeUser.PrimarySmtpAddress
Else
senderEmail = ""
End If
End If
getSenderEmailAdress = senderEmail
End Function
'Names are returned by reference
Private Sub getNames(ByRef OriginalMail As MailItem, ByRef fromName As String, ByRef firstName As String)
'Wildcard replaces
fromName = OriginalMail.SentOnBehalfOfName
If fromName = "" Then
fromName = OriginalMail.SenderName
End If
'default: fullname
firstName = fromName
Dim pos As Integer
pos = InStr(fromName, ",")
If pos > 0 Then
'Firstname is separated by comma and positioned behind the lastname
firstName = Trim(mid(fromName, pos + 1))
Else
pos = InStr(fromName, " ")
If pos > 0 Then
firstName = Trim(Left(fromName, pos - 1))
If firstName = UCase(firstName) Then
'in case the firstName is written in uppercase letters,
'we assume that the lastName is the real firstName
firstName = Trim(mid(fromName, pos + 1))
End If
Else
pos = InStr(fromName, "@")
If pos > 0 Then
firstName = Left(fromName, pos - 1)
End If
pos = InStr(firstName, ".")
If pos > 0 Then
firstName = Left(firstName, pos - 1)
End If
End If
End If
'fix casing of firstname
firstName = UCase(Left(firstName, 1)) + mid(firstName, 2)
End Sub
Private Function getOutlookHeader(ByRef BodyLines() As String, ByRef lineCounter As Long) As String
' parse until we find the header finish "> " (Outlook_Headerfinish)
For lineCounter = lineCounter To UBound(BodyLines)
If (BodyLines(lineCounter) = OUTLOOK_HEADERFINISH) Then
Exit For
End If
getOutlookHeader = getOutlookHeader & BodyLines(lineCounter) & vbCrLf
Next lineCounter
'skip OUTLOOK_HEADERFINISH
lineCounter = lineCounter + 1
End Function
Private Function getQuotedText(ByRef BodyLines() As String, ByRef lineCounter As Long) As String
' parse the rest of the message
For lineCounter = lineCounter To UBound(BodyLines)
If STRIP_SIGNATURE And (BodyLines(lineCounter) = SIGNATURE_SEPARATOR) Then
'beginning of signature reached
Exit For
End If
getQuotedText = getQuotedText & BodyLines(lineCounter) & vbCrLf
Next lineCounter
getQuotedText = ReFormatText(getQuotedText)
If INCLUDE_QUOTES_TO_LEVEL <> -1 Then
getQuotedText = StripQuotes(getQuotedText, INCLUDE_QUOTES_TO_LEVEL)
End If
End Function
Private Function CalcDownCount(pattern As String, textToSearch As String) As Long
Dim PosOfPattern As Long
Dim TextBeforePattern As String
PosOfPattern = InStr(textToSearch, pattern)
TextBeforePattern = Left(textToSearch, PosOfPattern - 1)
CalcDownCount = CountOccurencesOfStringInString(TextBeforePattern, vbCrLf)
End Function
Function GetCurrentItem() As Object 'changed to default scope
Dim objApp As Application
Set objApp = Session.Application
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer": 'on clicking reply in the main window
Set GetCurrentItem = objApp.ActiveExplorer.Selection.item(1)
Case "Inspector": 'on clicking reply when mail is shown in separate window
Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
End Select
End Function
'Parameters:
' InString: String to count in
' What: What to count
'Note:
' * Order of parameters taken from "InStr"
Public Function CountOccurencesOfStringInString(InString As String, What As String) As Long
Dim count As Long
Dim lastPos As Long
Dim curPos As Long
count = 0
lastPos = 0
curPos = InStr(InString, What)
Do While curPos <> 0
lastPos = curPos + 1
count = count + 1
curPos = InStr(lastPos, InString, What)
Loop
CountOccurencesOfStringInString = count
End Function
Private Function StripQuotes(quotedText As String, stripLevel As Integer) As String
Dim quoteLines() As String
Dim level As Integer
Dim curLine As String
Dim res As String
Dim I As Integer
quoteLines = Split(quotedText, vbCrLf)
For I = 1 To UBound(quoteLines)
level = InStr(quoteLines(I), " ") - 1
If level <= stripLevel Then
res = res + quoteLines(I) + vbCrLf
End If
Next I
StripQuotes = res
End Function
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment