Ricerca filtrata di mail: richiesta a chi-sa-parli
Un certo Lorenzo Pedrinolli mi ha sottoposto un problema, al quale onestamente non trovo soluzione per mancanza di tempo (o incompetenza? Ebbene sì...). Tuttavia ritengo che la cosa sia di grande interesse per molti, me incluso, tanto più che il buon Lorenzo fornisce pure una complessa routine attinta dal Web, che ahimè sul suo PC malfunziona, ma fusse che fusse che un erroraccio banale è alla base del dramma?
Che fare? Pensa e ripensa ho creduto utile pubblicare la richiesta del sullodato Pedrinolli, nella speranza che qualche anima buona ed esperta sappia aiutarlo. In tal caso siete pregati di rivolgersi al sottoscritto solo in caso di soluzioni valide, altrimenti indirizzate soltanto al sullodato:
lorenzo.pedrinolli@gmail.com
Ma ecco la missiva in questione, che al termine riporta la routine che delude. Ovviamente sono gradite anche soluzioni diverse da quella-che-delude.
Salve Gianni,
Il mio datore di lavoro, per mia disgrazia, mi ha promosso programmatore solo perché me la cavo con Visual Basic e SQL. Sono incappato nel suo sito alla disperata ricerca di una soluzione per esportare le mail da Outlook con una procedura quanto più automatica possibile e, facendole i complimenti [non c’è di che – G.G. ], ho trovato tutto quello che mi serviva. Ora però è nato il problema opposto: da 50 - 100 mail che dovevano essere archiviate siamo passati a 4 - 5000 in poco più di due mesi e, ovviamente, mi è stato chiesto un programma per ricercarle in base ad attributi vari: corpo, destinatario, mittente ecc.
Ora non sono in grado di trovare un modo per leggere le proprietà di un file *.msg presente sul disco ne tantomeno di far riconoscere a vb che quel file è un messaggio.
L'unica soluzione che ho trovato è una script (che riporto qui sotto). A detta dell'autore dovrebbe leggere queste proprietà senza far ricorso ad oggetti esterni... peccato che non riconosca i file msg presenti sul mio pc e che vada in ciclo senza fine una volta sì e l'altra pure.
Confidando che riesca a trovare 10 minuti per aiutarmi [altro che dieci minuti! Ce ne vorrebbero molti di più! Io non li ho ma qualcun altro ? G.G.] le porgo saluti e rinnovati ringraziamenti per avermi salvato in varie occasioni.
La routine deludente
Viene qui sotto riportata senza altri commenti se non quelli incorporate [e sperando che gli esperti cui si rivolge la richiesta di aiuto se la cavino in tale guazzabuglio. G.G. ]
Option Explicit On
Module Prova
'MsgBox MsgGet("DateSent,ReplyType,DateReply,RecipientsBCC,RecipientsTo,RecipientsCC,From,Prefix,MessageID,Subject,DateSent,DateReceived,AttachmentNumbers,AttachmentExtract,AttachmentNames,Recipients","temp.MSG")
Function MsgGet(ByVal s_Val, ByVal s_fileName)
' **********************************************************************************
' Outlook MSG Reading Utility
' Sean Currie @2005
'
' Description : Decodes an Outlook MSG file by reading the Compound Binary File
' format directly. Note most of the details on the compound binary
' file format derived from www.openoffice.org
' It DOES NOT require Outlook to be installed on the client machine
' nor does it require access to any libraries or third party DLL's
' Arguments : The value or values to return (each separated by a comma)
' e.g.
' Subject - The subject of the email
' Prefix - The subject prefix of the email
' MessageID - The Message ID
' From - The from address or name whichever
' available
' Body - The Message Body
' AttachmentNumbers - The number of attachments
' AttachmentNames - The names of the attachments
' (multiple values separated by a |)
' Recipients - All of the recipient addresses or name whichever
' available (multiple values
' separated by a |)
' includes TO, CC and BCC
' RecipientsTo - All the TO addresses or name whichever
' available (multiple values
' separated by a |)
' RecipientsCC - All the CC addresses or name whichever
' available (multiple values
' separated by a |)
' RecipientsBCC - All the BCC addresses or name whichever
' available (multiple values
' separated by a |)
' AttachmentExtract - The attachments are extracted to
' a temporary folder and the names
' returned to the user
' (multiple values spearated by a |)
' DateSent - The date sent of the email (may not
' have been sent if in drafts)
' DateReceived - The date received if the email has
' been received
' DateReply - Date reply requested in follow up
' ReplyType - Reply type (Follow up type)
'
' Each value is separated by a ^ and each sub value by a |
' For example:
' asking for Recipients could return
' sean.currie@poboxes.com|nuala.currie@poboxes.com
' You could then use Split to create an array
' For example:
' asking for "Recipients,From" could return
' sean.currie@poboxes.com|nuala.currie@poboxes.com^anyone@internet.com
' You could then use Split with ^ to create two arrays
' One of recipients and one of froms
' Then you could use Split again to get a list of the Recipients
'
'Examples : Extract just the subject
' MsgBox MsgGet("Subject","test.msg")
'
' Extract multiple fields there we extract the Subject and the From address
' MsgBox MsgGet("Subject,From","test2.msg")
'
' Extract the subject, extract the attachments to the temporary folder and
' return the names of the attachments
' MsgBox MsgGet("Subject,AttachmentExtract","shortcut.msg")
'
' Created : 24/12/2005
' Version : 1.0
'
' Description : Modified the way attachments are decoded using a new feature I call
' the MultiSectorReader, this speeds up sector decoding by reading
' sequential sectors in one go thereby speeding up the read process for
' big emails
' Modified : 02/01/2006
' Version : 1.1
'
' Description : Found failure when number of bytes to read for a sector was zero added
' code to check for zero sectors
' Modified : 28/01/2007
' Version : 1.2
'
' Description : Major rewrite to reflect use of OutlookSpy to determine ID's of fields
' Now accurately reports submit time and received time (previously searched
' headers, now uses proper MAPI properties to get them).
' Now also report recipients more accurately and can now separate TO, CC and
' BCC.
' Removed receivedby as didn't think it would ever be used.
' Added support to determine follow up date of email (reply by field)
' Now also correctly builds the directory from the array
' Modified : 23/02/2007
' Version : 2.0
' **********************************************************************************
Dim o_FSO ' File system object
Dim o_File ' The input MSG file
Dim s_String ' Temporary string
Dim s_Temp ' Temporary variable
Dim s_SectSize ' Sector size
Dim s_ShortSectSize ' Short sector size
Dim s_SectSAT ' No of SAT sectors
Dim s_DIRSID ' First SID of directory
Dim s_MinStream ' Minimum size of standard stream
Dim s_SIDSSAT ' SID of the SSAT
Dim s_SSATNumber ' Number of SSAT sectors
Dim s_SAT ' The array of SAT entries
Dim s_MSATSID ' First sector of MSAT
Dim s_SectMSAT ' No of MSAT sectors
Dim a_Temp(0, 0) ' The array of temporary entries
Dim a_Dir(0, 0) ' The array of directory entries
Dim a_MSAT() ' The array of MSAT entries
Dim a_SSAT() ' The array of SSAT entries
Dim M_W ' Temporary Counter
Dim M_X ' Temporary Counter
Dim M_Y ' Temporary Counter
Dim M_Z ' Temporary Counter
Dim s_ShortSat ' The short sector container stream
Dim s_ShortStart ' The short sector SAT data
Dim s_ShortSize ' The short sector SAT data
Dim a_Val ' Array of s_Val awaiting return values
Dim b_Debug ' Set this variable to True to create TXT files in the
' current directory to see what is being read from the
' MSG file
Dim s_Return ' The returned string
Dim s_MessageID ' The message ID
Dim s_Subject ' The message subject
Dim s_From ' The message from address
Dim s_Prefix ' The message subject prefix
Dim s_Body ' The message body
Dim s_AttachNums ' The message attachment numbers
Dim a_AttachNames() ' The message attachment names
Dim a_Recipients() ' The message recipients (To, CC and BCC)
Dim a_RecipientsTo() ' The message recipients in the TO list
Dim a_RecipientsCC() ' The message recipients in the CC list
Dim a_RecipientsBCC() ' The message recipients in the BCC list
Dim a_Attachments() ' The message attachments names on disk
Dim a_Attachments2() ' The message attachments names
Dim s_DateSent ' The message date was sent
Dim s_DateReceived ' The message date was received
Dim s_DateReply ' The message date of reply (also known as follow up date)
Dim s_ReplyType ' The message follow up type
' Create object and get the file
o_FSO = My.Computer.FileSystem
If Not o_FSO.FileExists(s_fileName) Then
MsgGet = "Error: File does not exist!"
Exit Function
End If
If UCase(Right(s_fileName, 4)) <> ".MSG" Then
MsgGet = "Error: Not an MSG file!"
Exit Function
End If
o_File = My.Computer.FileSystem.ReadAllText(s_fileName)
' Check that right hand of s_Val has comma
If Right(s_Val, 1) <> "," Then
s_Val = s_Val & ","
End If
s_Val = UCase(s_Val)
' Set the return variables to nothing
MsgGet = ""
s_ShortSat = ""
s_Return = ""
s_Subject = ""
s_MessageID = ""
s_From = ""
s_Prefix = ""
s_Body = ""
s_AttachNums = 0
b_Debug = True
s_DateSent = ""
s_DateReceived = ""
s_DateReply = ""
s_ReplyType = ""
' Read header characters
s_String = o_File.Read(8)
' Check its a compound file
If s_String <> MyHexToHexCoded("D0CF11E0A1B11AE1") Then
MsgGet = "Error: Not an MSG file!"
Exit Function
End If
' Read 16 chars unique identifier with revision
s_String = o_File.Read(20)
' Read 2 chars of byte identifier
s_String = o_File.Read(2)
If s_String <> MyHexToHexCoded("FEFF") Then
MsgGet = "Error: Not an MSG file!"
Exit Function
End If
' Read 2 chars of sector size
s_String = o_File.Read(2)
' Convert to number and power of 2
s_SectSize = 2 ^ MyVBNumber(s_String)
' Read 2 chars of short sector size
s_String = o_File.Read(2)
' Convert to number and power of 2
s_ShortSectSize = 2 ^ MyVBNumber(s_String)
' Read 10 chars of invalid data
s_String = o_File.Read(10)
' Read 4 chars of sectors in SAT
s_String = o_File.Read(4)
' Convert to number
s_SectSAT = MyVBNumber(s_String)
' Read 4 chars of first DIR SID
s_String = o_File.Read(4)
' Convert to number
s_DIRSID = MyVBNumber(s_String)
' Read 4 chars of invalid data
s_String = o_File.Read(4)
' Read 4 chars of min stream size
s_String = o_File.Read(4)
' Convert to number
s_MinStream = MyVBNumber(s_String)
' Read 4 chars of SID of the SSAT
s_String = o_File.Read(4)
' Convert to number
s_SIDSSAT = MyVBNumber(s_String)
' Read 4 chars of number of SSAT sectors
s_String = o_File.Read(4)
' Convert to number
s_SSATNumber = MyVBNumber(s_String)
' Read 4 chars of MSAT SID
s_String = o_File.Read(4)
' Convert to number
s_MSATSID = MyVBNumber(s_String)
' Read 4 chars of number of sectors in MSAT
s_String = o_File.Read(4)
' Convert to number
s_SectMSAT = MyVBNumber(s_String)
' Now read the first 109 entries in the MSAT
For M_X = 1 To 109
' Read 4 chars of MSAT sector IDs
s_String = o_File.Read(4)
If MyVBNumber(s_String) >= 0 Then
ReDim Preserve a_MSAT(MyArrayLen(a_MSAT, 1) + 1)
a_MSAT(MyArrayLen(a_MSAT, 1) - 1) = MyVBNumber(s_String)
End If
Next
o_File.Close()
' The header has now been read
' We now know quite a few things
' - The total number of sectors in the MSAT
' - The first sector of the MSAT to start reading it
' We can now read the MSAT and from there we can read everything
' Do we need to read the MSAT if it is more than 109 entries?
If s_MSATSID <> -2 Then
M_Y = s_MSATSID
' Lets loop through the MSAT
Do While M_Y >= 0
s_Temp = MySectorReader(s_SectSize, M_Y, s_fileName)
For M_X = 1 To s_SectSize - 4 Step 4
s_String = Mid(s_Temp, M_X, 4)
If MyVBNumber(s_String) > 0 Then
ReDim Preserve a_MSAT(MyArrayLen(a_MSAT, 1) + 1)
a_MSAT(MyArrayLen(a_MSAT, 1) - 1) = MyVBNumber(s_String)
End If
Next
s_String = Right(s_Temp, 4)
If MyVBNumber(s_String) > 0 Then
M_Y = MyVBNumber(s_String)
Else
M_Y = -2
End If
Loop
End If
' Temporary debug routine to write out the MSAT
If b_Debug Then
o_File = o_FSO.CreateTextFile("MSAT.TXT")
For M_X = 0 To MyArrayLen(a_MSAT, 1) - 1
o_File.WriteLine("---" & a_MSAT(M_X))
Next
o_File.Close()
End If
' We now have the MSAT hence we can now build the SAT from this
s_SAT = ""
For M_Y = 0 To (MyArrayLen(a_MSAT, 1) - 1)
s_SAT = s_SAT & MySectorReader(s_SectSize, a_MSAT(M_Y), s_fileName)
Next
' Temporary debug routine to write out the SAT
If b_Debug Then
o_File = o_FSO.CreateTextFile("SAT.TXT")
o_File.WriteLine("Sector" & Chr(9) & " : " & "Value")
For M_X = 1 To Len(s_SAT) Step 4
o_File.WriteLine(Int(M_X / 4) & Chr(9) & " : " & MyVBNumber(Mid(s_SAT, M_X, 4)))
Next
o_File.Close()
End If
' Now we can read the Short Sector SSAT
If s_SIDSSAT <> -2 Then
M_Y = s_SIDSSAT
s_Temp = MySectorReader(s_SectSize, M_Y, s_fileName)
For M_X = 1 To s_SectSize Step 4
s_String = Mid(s_Temp, M_X, 4)
ReDim Preserve a_SSAT(MyArrayLen(a_SSAT, 1) + 1)
a_SSAT(MyArrayLen(a_SSAT, 1) - 1) = MyVBNumber(s_String)
Next
M_Z = 1
Do While True
M_Y = MyVBNumber(Mid(s_SAT, (M_Y * 4) + 1, 4))
If M_Y > 0 Then
M_Z = M_Z + 1
s_Temp = MySectorReader(s_SectSize, M_Y, s_fileName)
For M_X = 1 To s_SectSize Step 4
s_String = Mid(s_Temp, M_X, 4)
ReDim Preserve a_SSAT(MyArrayLen(a_SSAT, 1) + 1)
a_SSAT(MyArrayLen(a_SSAT, 1) - 1) = MyVBNumber(s_String)
Next
End If
If M_Z = s_SSATNumber Then
Exit Do
End If
Loop
End If
' Temporary debug routine to write out the SSAT
If b_Debug Then
o_File = o_FSO.CreateTextFile("SSAT.TXT")
For M_X = 0 To MyArrayLen(a_SSAT, 1) - 1
o_File.WriteLine(M_X & Chr(9) & " : " & a_SSAT(M_X))
Next
o_File.Close()
End If
' Finally lets read the directory
M_Y = s_DIRSID
' Lets loop through the DIRECTORY
M_Z = -1
Do While M_Y >= 0
s_Temp = MySectorReader(s_SectSize, M_Y, s_fileName)
For M_X = 1 To s_SectSize Step 128
M_Z = M_Z + 1
' First lets check the type of the directory entry and if zero it is unused
If MyVBNumber(Mid(s_Temp, M_X + 66, 1)) <> 0 Then
If MyArrayLen(a_Dir, 2) = 0 Then
ReDim Preserve a_Dir(8, 1)
Else
ReDim Preserve a_Dir(8, MyArrayLen(a_Dir, 2) + 1)
End If
' Format of the array
' 0 - DID
' 1 - Name
' 2 - Type
' 3 - DID Left Child
' 4 - DID Right Child
' 5 - DID root node
' 6 - SID of first sector
' 7 - Stream size
a_Dir(0, MyArrayLen(a_Dir, 2) - 1) = M_Z
a_Dir(1, MyArrayLen(a_Dir, 2) - 1) = Replace(Mid(s_Temp, M_X, MyVBNumber(Mid(s_Temp, M_X + 64, 2))), Chr(0), "")
a_Dir(2, MyArrayLen(a_Dir, 2) - 1) = MyVBNumber(Mid(s_Temp, M_X + 66, 1))
a_Dir(3, MyArrayLen(a_Dir, 2) - 1) = MyVBNumber(Mid(s_Temp, M_X + 68, 4))
a_Dir(4, MyArrayLen(a_Dir, 2) - 1) = MyVBNumber(Mid(s_Temp, M_X + 72, 4))
a_Dir(5, MyArrayLen(a_Dir, 2) - 1) = MyVBNumber(Mid(s_Temp, M_X + 76, 4))
a_Dir(6, MyArrayLen(a_Dir, 2) - 1) = MyVBNumber(Mid(s_Temp, M_X + 116, 4))
a_Dir(7, MyArrayLen(a_Dir, 2) - 1) = MyVBNumber(Mid(s_Temp, M_X + 120, 4))
End If
Next
M_Y = MyVBNumber(Mid(s_SAT, (M_Y * 4) + 1, 4))
Loop
' Temporary debug routine to write out the SSAT
' TO BE REMOVED
'If b_Debug Then
' o_File = o_FSO.CreateTextFile("DIR.TXT")
' o_File.WriteLine("DID" & Chr(9) & " : " & "Name" & String(30 - Len("Name"), " ") & " : " & "Type" & Chr(9) & " : " & "Left DID" & Chr(9) & " : " & "Right DID" & Chr(9) & " : " & "Root DID" & Chr(9) & " : " & "Start Sec" & Chr(9) & " : " & "Size")
' For M_X = 0 To MyArrayLen(a_Dir, 2) - 1
' o_File.WriteLine(a_DIR(0,M_X) & Chr(9) & " : " & a_DIR(1,M_X) & String(30-Len(a_DIR(1,M_X))," ") & " : " & a_DIR(2,M_X) & Chr(9) & Chr(9) & " : " & a_DIR(3,M_X) & Chr(9) & Chr(9) & " : " & a_DIR(4,M_X) & Chr(9) & Chr(9) & " : " & a_DIR(5,M_X) & Chr(9) & Chr(9) & " : " & a_DIR(6,M_X) & Chr(9) & Chr(9) & " : " & a_DIR(7,M_X))
' Next
' o_File.Close()
'End If
' Find out the starting SID for the short stream container and then read the short stream container
If s_SIDSSAT <> -2 Then
s_ShortStart = 0
s_ShortSize = 0
For M_X = 0 To MyArrayLen(a_Dir, 2) - 1
If InStr(UCase(a_Dir(1, M_X)), "ROOT ENTRY") > 0 Then
' Allocate the first sector of the short sector container stream
s_ShortStart = a_Dir(6, M_X)
s_ShortSize = a_Dir(7, M_X)
Exit For
End If
Next
M_Y = s_ShortStart
s_ShortSat = MySectorReader(s_SectSize, M_Y, s_fileName)
Do While True
M_Y = MyVBNumber(Mid(s_SAT, (M_Y * 4) + 1, 4))
If M_Y > 0 Then
s_ShortSat = s_ShortSat & MySectorReader(s_SectSize, M_Y, s_fileName)
End If
If Len(s_ShortSat) >= s_ShortSize Then
Exit Do
End If
Loop
End If
' Now lets re-read the DIRECTORY in the proper order as Outlook scrambles it
For M_X = 0 To MyArrayLen(a_Dir, 2) - 1
' Check for a root entry
If a_Dir(5, M_X) <> -1 Then
' Add to final array
ReDim Preserve a_Temp(8, MyArrayLen(a_Temp, 2) + 1)
a_Temp(0, MyArrayLen(a_Temp, 2) - 1) = a_Dir(0, M_X)
a_Temp(1, MyArrayLen(a_Temp, 2) - 1) = a_Dir(1, M_X)
a_Temp(2, MyArrayLen(a_Temp, 2) - 1) = a_Dir(2, M_X)
a_Temp(3, MyArrayLen(a_Temp, 2) - 1) = a_Dir(3, M_X)
a_Temp(4, MyArrayLen(a_Temp, 2) - 1) = a_Dir(4, M_X)
a_Temp(5, MyArrayLen(a_Temp, 2) - 1) = a_Dir(5, M_X)
a_Temp(6, MyArrayLen(a_Temp, 2) - 1) = a_Dir(6, M_X)
a_Temp(7, MyArrayLen(a_Temp, 2) - 1) = a_Dir(7, M_X)
MySubRead(a_Dir(5, M_X), -1, a_Dir, a_Temp)
End If
Next
' Temporary debug routine to write out the sorted DIRECTORY
' TO BE REMOVED
'If b_Debug Then
' o_File = o_FSO.CreateTextFile("DIRFINAL.TXT")
'o_File.WriteLine("DID" & Chr(9) & " : " & "Name" & String(30-Len("Name")," ") & " : " & "Type" & Chr(9) & " : " & "Left DID" & Chr(9) & " : " & "Right DID" & Chr(9) & " : " & "Root DID" & Chr(9) & " : " & "Start Sec" & Chr(9) & " : " & "Size")
' For M_X = 0 To MyArrayLen(a_Temp, 2) - 1
' o_File.WriteLine(a_Temp(0,M_X) & Chr(9) & " : " & a_Temp(1,M_X) & String(30-Len(a_Temp(1,M_X))," ") & " : " & a_Temp(2,M_X) & Chr(9) & Chr(9) & " : " & a_Temp(3,M_X) & Chr(9) & Chr(9) & " : " & a_Temp(4,M_X) & Chr(9) & Chr(9) & " : " & a_Temp(5,M_X) & Chr(9) & Chr(9) & " : " & a_Temp(6,M_X) & Chr(9) & Chr(9) & " : " & a_Temp(7,M_X))
' Next
' o_File.Close()
'End If
ReDim a_Dir(8, MyArrayLen(a_Temp, 2))
For M_X = 0 To MyArrayLen(a_Temp, 2) - 1
a_Dir(0, M_X) = a_Temp(0, M_X)
a_Dir(1, M_X) = a_Temp(1, M_X)
a_Dir(2, M_X) = a_Temp(2, M_X)
a_Dir(3, M_X) = a_Temp(3, M_X)
a_Dir(4, M_X) = a_Temp(4, M_X)
a_Dir(5, M_X) = a_Temp(5, M_X)
a_Dir(6, M_X) = a_Temp(6, M_X)
a_Dir(7, M_X) = a_Temp(7, M_X)
Next
' Now lets build the return strings and data
If InStr(s_Val, "SUBJECT,") > 0 Then
' Now get the directory entry for the subject
For M_X = 0 To MyArrayLen(a_Dir, 2) - 1
If InStr(UCase(a_Dir(1, M_X)), "__SUBSTG1.0_0037") > 0 And a_Dir(7, M_X) > 0 Then
' Check if in short stream
If a_Dir(7, M_X) < s_MinStream Then
s_Subject = Replace(MyShortSectorReader(s_ShortSectSize, a_Dir(6, M_X), a_Dir(7, M_X), a_SSAT, s_ShortSat), Chr(0), "")
Exit For
Else
s_Subject = MyLongSectorReader("VARIABLE", s_SectSize, a_Dir(6, M_X), a_Dir(7, M_X), s_fileName, s_SAT)
Exit For
End If
End If
Next
End If
' Now lets build the return strings and data
If InStr(s_Val, "REPLYTYPE,") > 0 Then
' Now get the directory entry for the subject
For M_X = 0 To MyArrayLen(a_Dir, 2) - 1
If InStr(UCase(a_Dir(1, M_X)), "__SUBSTG1.0_8003") > 0 And a_Dir(7, M_X) > 0 Then
' Check if in short stream
If a_Dir(7, M_X) < s_MinStream Then
s_ReplyType = Replace(MyShortSectorReader(s_ShortSectSize, a_Dir(6, M_X), a_Dir(7, M_X), a_SSAT, s_ShortSat), Chr(0), "")
Exit For
Else
s_ReplyType = MyLongSectorReader("VARIABLE", s_SectSize, a_Dir(6, M_X), a_Dir(7, M_X), s_fileName, s_SAT)
Exit For
End If
End If
Next
End If
If InStr(s_Val, "MESSAGEID,") > 0 Then
' Now get the directory entry for the message id
For M_X = 0 To MyArrayLen(a_Dir, 2) - 1
If InStr(UCase(a_Dir(1, M_X)), "__SUBSTG1.0_1035") > 0 And a_Dir(7, M_X) > 0 Then
' Check if in short stream
If a_Dir(7, M_X) < s_MinStream Then
s_MessageID = Replace(MyShortSectorReader(s_ShortSectSize, a_Dir(6, M_X), a_Dir(7, M_X), a_SSAT, s_ShortSat), Chr(0), "")
Exit For
Else
s_MessageID = MyLongSectorReader("VARIABLE", s_SectSize, a_Dir(6, M_X), a_Dir(7, M_X), s_fileName, s_SAT)
Exit For
End If
End If
Next
End If
If InStr(s_Val, "FROM,") > 0 Then
' Now get the directory entry for the from type to find out the source email address
For M_X = 0 To MyArrayLen(a_Dir, 2) - 1
' Check for SMTP
If InStr(UCase(a_Dir(1, M_X)), "__SUBSTG1.0_0065") > 0 And a_Dir(7, M_X) > 0 And s_From = "" Then
' Check if in short stream
If a_Dir(7, M_X) < s_MinStream Then
s_From = Replace(MyShortSectorReader(s_ShortSectSize, a_Dir(6, M_X), a_Dir(7, M_X), a_SSAT, s_ShortSat), Chr(0), "")
Else
s_From = MyLongSectorReader("VARIABLE", s_SectSize, a_Dir(6, M_X), a_Dir(7, M_X), s_fileName, s_SAT)
End If
End If
Next
' Check if valid SMTP address
If InStr(s_From, "@") = 0 Then
s_From = ""
Else
s_From = Replace(s_From, "<", "")
s_From = Replace(s_From, ">", "")
s_From = Replace(s_From, "'", "")
End If
For M_X = 0 To MyArrayLen(a_Dir, 2) - 1
' Check for return address
If InStr(UCase(a_Dir(1, M_X)), "__SUBSTG1.0_800A") > 0 And a_Dir(7, M_X) > 0 And s_From = "" Then
' Check if in short stream
If a_Dir(7, M_X) < s_MinStream Then
s_From = Replace(MyShortSectorReader(s_ShortSectSize, a_Dir(6, M_X), a_Dir(7, M_X), a_SSAT, s_ShortSat), Chr(0), "")
Exit For
Else
s_From = MyLongSectorReader("VARIABLE", s_SectSize, a_Dir(6, M_X), a_Dir(7, M_X), s_fileName, s_SAT)
Exit For
End If
End If
Next
' Check if valid SMTP address
If InStr(s_From, "@") = 0 Then
s_From = ""
Else
s_From = Replace(s_From, "<", "")
s_From = Replace(s_From, ">", "")
s_From = Replace(s_From, "'", "")
End If
For M_X = 0 To MyArrayLen(a_Dir, 2) - 1
' Check for return address
If InStr(UCase(a_Dir(1, M_X)), "__SUBSTG1.0_800B") > 0 And a_Dir(7, M_X) > 0 And s_From = "" Then
' Check if in short stream
If a_Dir(7, M_X) < s_MinStream Then
s_From = Replace(MyShortSectorReader(s_ShortSectSize, a_Dir(6, M_X), a_Dir(7, M_X), a_SSAT, s_ShortSat), Chr(0), "")
Exit For
Else
s_From = MyLongSectorReader("VARIABLE", s_SectSize, a_Dir(6, M_X), a_Dir(7, M_X), s_fileName, s_SAT)
Exit For
End If
End If
Next
' Check if valid SMTP address
If InStr(s_From, "@") = 0 Then
s_From = ""
Else
s_From = Replace(s_From, "<", "")
s_From = Replace(s_From, ">", "")
s_From = Replace(s_From, "'", "")
End If
' Now get the directory entry for the from type to find out the source email address
For M_X = 0 To MyArrayLen(a_Dir, 2) - 1
' Check for display name
If InStr(UCase(a_Dir(1, M_X)), "__SUBSTG1.0_0C1A") > 0 And a_Dir(7, M_X) > 0 And s_From = "" Then
' Check if in short stream
If a_Dir(7, M_X) < s_MinStream Then
s_From = Replace(MyShortSectorReader(s_ShortSectSize, a_Dir(6, M_X), a_Dir(7, M_X), a_SSAT, s_ShortSat), Chr(0), "")
Exit For
Else
s_From = MyLongSectorReader("VARIABLE", s_SectSize, a_Dir(6, M_X), a_Dir(7, M_X), s_fileName, s_SAT)
Exit For
End If
End If
Next
End If
If InStr(s_Val, "PREFIX,") > 0 Then
' Now get the directory entry for the message id
For M_X = 0 To MyArrayLen(a_Dir, 2) - 1
If InStr(UCase(a_Dir(1, M_X)), "__SUBSTG1.0_003D") > 0 And a_Dir(7, M_X) > 0 Then
' Check if in short stream
If a_Dir(7, M_X) < s_MinStream Then
s_Prefix = Replace(MyShortSectorReader(s_ShortSectSize, a_Dir(6, M_X), a_Dir(7, M_X), a_SSAT, s_ShortSat), Chr(0), "")
Exit For
Else
s_Prefix = MyLongSectorReader("VARIABLE", s_SectSize, a_Dir(6, M_X), a_Dir(7, M_X), s_fileName, s_SAT)
Exit For
End If
End If
Next
End If
If InStr(s_Val, "BODY,") > 0 Then
' Now get the directory entry for the message body
For M_X = 0 To MyArrayLen(a_Dir, 2) - 1
If InStr(UCase(a_Dir(1, M_X)), "__SUBSTG1.0_1000") > 0 And a_Dir(7, M_X) > 0 Then
' Check if in short stream
If a_Dir(7, M_X) < s_MinStream Then
s_Body = Replace(MyShortSectorReader(s_ShortSectSize, a_Dir(6, M_X), a_Dir(7, M_X), a_SSAT, s_ShortSat), Chr(0), "")
Exit For
Else
s_Body = MyLongSectorReader("VARIABLE", s_SectSize, a_Dir(6, M_X), a_Dir(7, M_X), s_fileName, s_SAT)
Exit For
End If
End If
Next
End If
If InStr(s_Val, "ATTACHMENTNUMBERS,") > 0 Then
' Now get the directory entry for the attachments
For M_X = 0 To MyArrayLen(a_Dir, 2) - 1
If InStr(UCase(a_Dir(1, M_X)), "__ATTACH_VERSION1.0_#") > 0 Then
' Total the number in the email
s_AttachNums = s_AttachNums + 1
End If
Next
End If
If InStr(s_Val, "ATTACHMENTNAMES,") > 0 Then
' Now get the directory entry for the attachments
For M_X = 0 To MyArrayLen(a_Dir, 2) - 1
' Check for attachment
If InStr(UCase(a_Dir(1, M_X)), "__ATTACH_VERSION1.0_#") > 0 Then
ReDim Preserve a_AttachNames(MyArrayLen(a_AttachNames, 1) + 1)
' Get attachment name
For M_Y = M_X + 1 To MyArrayLen(a_Dir, 2) - 1
' Check for attachment name
If InStr(UCase(a_Dir(1, M_Y)), "__ATTACH_VERSION1.0_#") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__RECIP_VERSION1.0_#") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__NAMEID_VERSION1.0") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__PROPERTIES_VERSION1.0") > 0 Then
Exit For
ElseIf InStr(UCase(a_Dir(1, M_Y)), "__SUBSTG1.0_3704") > 0 Then
' Check if in short stream
If a_Dir(7, M_Y) < s_MinStream Then
a_AttachNames(MyArrayLen(a_AttachNames, 1) - 1) = Replace(MyShortSectorReader(s_ShortSectSize, a_Dir(6, M_Y), a_Dir(7, M_Y), a_SSAT, s_ShortSat), Chr(0), "")
Else
a_AttachNames(MyArrayLen(a_AttachNames, 1) - 1) = MyLongSectorReader("VARIABLE", s_SectSize, a_Dir(6, M_Y), a_Dir(7, M_Y), s_fileName, s_SAT)
End If
ElseIf InStr(UCase(a_Dir(1, M_Y)), "__SUBSTG1.0_3707") > 0 Then
' Check if in short stream
If a_Dir(7, M_Y) < s_MinStream Then
a_AttachNames(MyArrayLen(a_AttachNames, 1) - 1) = Replace(MyShortSectorReader(s_ShortSectSize, a_Dir(6, M_Y), a_Dir(7, M_Y), a_SSAT, s_ShortSat), Chr(0), "")
Else
a_AttachNames(MyArrayLen(a_AttachNames, 1) - 1) = MyLongSectorReader("VARIABLE", s_SectSize, a_Dir(6, M_Y), a_Dir(7, M_Y), s_fileName, s_SAT)
End If
End If
Next
End If
Next
End If
If InStr(s_Val, "RECIPIENTS,") > 0 Then
' Now get the directory entry for the recipients
For M_X = 0 To MyArrayLen(a_Dir, 2) - 1
' Check for recipient
If InStr(UCase(a_Dir(1, M_X)), "__RECIP_VERSION1.0_#") > 0 Then
ReDim Preserve a_Recipients(MyArrayLen(a_Recipients, 1) + 1)
s_Temp = ""
' Get recipient name
For M_Y = M_X + 1 To MyArrayLen(a_Dir, 2) - 1
' Check for next recipient email
If InStr(UCase(a_Dir(1, M_Y)), "__ATTACH_VERSION1.0_#") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__RECIP_VERSION1.0_#") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__NAMEID_VERSION1.0") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__PROPERTIES_VERSION1.0") > 0 Then
Exit For
End If
If InStr(UCase(a_Dir(1, M_Y)), "__SUBSTG1.0_39FE") > 0 And a_Dir(7, M_Y) > 0 And s_Temp = "" Then
s_Temp = "1"
' Check if in short stream
s_String = ""
If a_Dir(7, M_Y) < s_MinStream Then
s_String = Replace(MyShortSectorReader(s_ShortSectSize, a_Dir(6, M_Y), a_Dir(7, M_Y), a_SSAT, s_ShortSat), Chr(0), "")
Else
s_String = MyLongSectorReader("VARIABLE", s_SectSize, a_Dir(6, M_Y), a_Dir(7, M_Y), s_fileName, s_SAT)
End If
' Check if valid SMTP address
If InStr(s_String, "@") <> 0 Then
s_String = Replace(s_String, "<", "")
s_String = Replace(s_String, ">", "")
s_String = Replace(s_String, "'", "")
End If
a_Recipients(MyArrayLen(a_Recipients, 1) - 1) = s_String
End If
Next
' Get org email
For M_Y = M_X + 1 To MyArrayLen(a_Dir, 2) - 1
' Check for next recipient email
If InStr(UCase(a_Dir(1, M_Y)), "__ATTACH_VERSION1.0_#") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__RECIP_VERSION1.0_#") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__NAMEID_VERSION1.0") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__PROPERTIES_VERSION1.0") > 0 Then
Exit For
End If
If InStr(UCase(a_Dir(1, M_Y)), "__SUBSTG1.0_403E") > 0 And a_Dir(7, M_Y) > 0 And s_Temp = "" Then
s_Temp = "1"
' Check if in short stream
s_String = ""
If a_Dir(7, M_Y) < s_MinStream Then
s_String = Replace(MyShortSectorReader(s_ShortSectSize, a_Dir(6, M_Y), a_Dir(7, M_Y), a_SSAT, s_ShortSat), Chr(0), "")
Else
s_String = MyLongSectorReader("VARIABLE", s_SectSize, a_Dir(6, M_Y), a_Dir(7, M_Y), s_fileName, s_SAT)
End If
' Check if valid SMTP address
If InStr(s_String, "@") <> 0 Then
s_String = Replace(s_String, "<", "")
s_String = Replace(s_String, ">", "")
s_String = Replace(s_String, "'", "")
End If
a_Recipients(MyArrayLen(a_Recipients, 1) - 1) = s_String
End If
Next
' Get recipient name
For M_Y = M_X + 1 To MyArrayLen(a_Dir, 2) - 1
' Check for next recipient display name
If InStr(UCase(a_Dir(1, M_Y)), "__ATTACH_VERSION1.0_#") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__RECIP_VERSION1.0_#") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__NAMEID_VERSION1.0") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__PROPERTIES_VERSION1.0") > 0 Then
Exit For
End If
If InStr(UCase(a_Dir(1, M_Y)), "__SUBSTG1.0_3001") > 0 And a_Dir(7, M_Y) > 0 And s_Temp = "" Then
s_Temp = "1"
' Check if in short stream
s_String = ""
If a_Dir(7, M_Y) < s_MinStream Then
s_String = Replace(MyShortSectorReader(s_ShortSectSize, a_Dir(6, M_Y), a_Dir(7, M_Y), a_SSAT, s_ShortSat), Chr(0), "")
Else
s_String = MyLongSectorReader("VARIABLE", s_SectSize, a_Dir(6, M_Y), a_Dir(7, M_Y), s_fileName, s_SAT)
End If
' Check if valid SMTP address
If InStr(s_String, "@") <> 0 Then
s_String = Replace(s_String, "<", "")
s_String = Replace(s_String, ">", "")
s_String = Replace(s_String, "'", "")
End If
a_Recipients(MyArrayLen(a_Recipients, 1) - 1) = s_String
End If
Next
End If
Next
End If
If InStr(s_Val, "RECIPIENTSTO,") > 0 Then
' Now get the directory entry for the recipients
For M_X = 0 To MyArrayLen(a_Dir, 2) - 1
' Check for recipient
If InStr(UCase(a_Dir(1, M_X)), "__RECIP_VERSION1.0_#") > 0 Then
ReDim Preserve a_RecipientsTo(MyArrayLen(a_RecipientsTo, 1) + 1)
s_Temp = ""
' Get recipient name
For M_Y = M_X + 1 To MyArrayLen(a_Dir, 2) - 1
' Check for recipient email
If InStr(UCase(a_Dir(1, M_Y)), "__ATTACH_VERSION1.0_#") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__RECIP_VERSION1.0_#") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__NAMEID_VERSION1.0") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__PROPERTIES_VERSION1.0") > 0 Then
Exit For
End If
If InStr(UCase(a_Dir(1, M_Y)), "__SUBSTG1.0_39FE") > 0 And a_Dir(7, M_Y) > 0 And s_Temp = "" Then
s_Temp = "1"
' Check if in short stream
s_String = ""
If a_Dir(7, M_Y) < s_MinStream Then
s_String = Replace(MyShortSectorReader(s_ShortSectSize, a_Dir(6, M_Y), a_Dir(7, M_Y), a_SSAT, s_ShortSat), Chr(0), "")
Else
s_String = MyLongSectorReader("VARIABLE", s_SectSize, a_Dir(6, M_Y), a_Dir(7, M_Y), s_fileName, s_SAT)
End If
' Check if valid SMTP address
If InStr(s_String, "@") <> 0 Then
s_String = Replace(s_String, "<", "")
s_String = Replace(s_String, ">", "")
s_String = Replace(s_String, "'", "")
End If
a_RecipientsTo(MyArrayLen(a_RecipientsTo, 1) - 1) = s_String
End If
Next
' Get org email
For M_Y = M_X + 1 To MyArrayLen(a_Dir, 2) - 1
' Check for recipient display name
If InStr(UCase(a_Dir(1, M_Y)), "__ATTACH_VERSION1.0_#") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__RECIP_VERSION1.0_#") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__NAMEID_VERSION1.0") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__PROPERTIES_VERSION1.0") > 0 Then
Exit For
End If
If InStr(UCase(a_Dir(1, M_Y)), "__SUBSTG1.0_403E") > 0 And a_Dir(7, M_Y) > 0 And s_Temp = "" Then
s_Temp = "1"
' Check if in short stream
s_String = ""
If a_Dir(7, M_Y) < s_MinStream Then
s_String = Replace(MyShortSectorReader(s_ShortSectSize, a_Dir(6, M_Y), a_Dir(7, M_Y), a_SSAT, s_ShortSat), Chr(0), "")
Else
s_String = MyLongSectorReader("VARIABLE", s_SectSize, a_Dir(6, M_Y), a_Dir(7, M_Y), s_fileName, s_SAT)
End If
' Check if valid SMTP address
If InStr(s_String, "@") <> 0 Then
s_String = Replace(s_String, "<", "")
s_String = Replace(s_String, ">", "")
s_String = Replace(s_String, "'", "")
End If
a_RecipientsTo(MyArrayLen(a_RecipientsTo, 1) - 1) = s_String
End If
Next
' Get recipient name
For M_Y = M_X + 1 To MyArrayLen(a_Dir, 2) - 1
' Check for recipient display name
If InStr(UCase(a_Dir(1, M_Y)), "__ATTACH_VERSION1.0_#") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__RECIP_VERSION1.0_#") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__NAMEID_VERSION1.0") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__PROPERTIES_VERSION1.0") > 0 Then
Exit For
End If
If InStr(UCase(a_Dir(1, M_Y)), "__SUBSTG1.0_3001") > 0 And a_Dir(7, M_Y) > 0 And s_Temp = "" Then
s_Temp = "1"
' Check if in short stream
s_String = ""
If a_Dir(7, M_Y) < s_MinStream Then
s_String = Replace(MyShortSectorReader(s_ShortSectSize, a_Dir(6, M_Y), a_Dir(7, M_Y), a_SSAT, s_ShortSat), Chr(0), "")
Else
s_String = MyLongSectorReader("VARIABLE", s_SectSize, a_Dir(6, M_Y), a_Dir(7, M_Y), s_fileName, s_SAT)
End If
' Check if valid SMTP address
If InStr(s_String, "@") <> 0 Then
s_String = Replace(s_String, "<", "")
s_String = Replace(s_String, ">", "")
s_String = Replace(s_String, "'", "")
End If
a_RecipientsTo(MyArrayLen(a_RecipientsTo, 1) - 1) = s_String
End If
Next
' Get recipient type and delete if wrong
For M_Y = M_X + 1 To MyArrayLen(a_Dir, 2) - 1
' Check if its in the TO list
If InStr(UCase(a_Dir(1, M_Y)), "__PROPERTIES_VERSION1.0") > 0 And a_Dir(7, M_Y) > 0 Then
' Check if in short stream
s_String = ""
If a_Dir(7, M_Y) < s_MinStream Then
s_String = MyShortSectorReader(s_ShortSectSize, a_Dir(6, M_Y), a_Dir(7, M_Y), a_SSAT, s_ShortSat)
Else
s_String = MyLongSectorReader("VARIABLE", s_SectSize, a_Dir(6, M_Y), a_Dir(7, M_Y), s_fileName, s_SAT)
End If
For M_Z = 1 To Len(s_String) Step 8
If Mid(s_String, M_Z, 4) = MyHexToHexCoded("0300150C") Then
If MyVBNumber(Mid(s_String, M_Z + 8, 1)) <> 1 And s_Temp <> "" Then
If MyArrayLen(a_RecipientsTo, 1) > 1 Then
ReDim Preserve a_RecipientsTo(MyArrayLen(a_RecipientsTo, 1) - 1)
Else
ReDim a_RecipientsTo(0)
End If
End If
End If
Next
End If
' Check for recipient email
If InStr(UCase(a_Dir(1, M_Y)), "__ATTACH_VERSION1.0_#") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__RECIP_VERSION1.0_#") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__NAMEID_VERSION1.0") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__PROPERTIES_VERSION1.0") > 0 Then
Exit For
End If
Next
End If
Next
End If
If InStr(s_Val, "RECIPIENTSCC,") > 0 Then
' Now get the directory entry for the recipients
For M_X = 0 To MyArrayLen(a_Dir, 2) - 1
' Check for recipient
If InStr(UCase(a_Dir(1, M_X)), "__RECIP_VERSION1.0_#") > 0 Then
ReDim Preserve a_RecipientsCC(MyArrayLen(a_RecipientsCC, 1) + 1)
s_Temp = ""
' Get recipient name
For M_Y = M_X + 1 To MyArrayLen(a_Dir, 2) - 1
' Check for recipient email
If InStr(UCase(a_Dir(1, M_Y)), "__ATTACH_VERSION1.0_#") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__RECIP_VERSION1.0_#") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__NAMEID_VERSION1.0") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__PROPERTIES_VERSION1.0") > 0 Then
Exit For
End If
If InStr(UCase(a_Dir(1, M_Y)), "__SUBSTG1.0_39FE") > 0 And a_Dir(7, M_Y) > 0 And s_Temp = "" Then
s_Temp = "1"
' Check if in short stream
s_String = ""
If a_Dir(7, M_Y) < s_MinStream Then
s_String = Replace(MyShortSectorReader(s_ShortSectSize, a_Dir(6, M_Y), a_Dir(7, M_Y), a_SSAT, s_ShortSat), Chr(0), "")
Else
s_String = MyLongSectorReader("VARIABLE", s_SectSize, a_Dir(6, M_Y), a_Dir(7, M_Y), s_fileName, s_SAT)
End If
' Check if valid SMTP address
If InStr(s_String, "@") <> 0 Then
s_String = Replace(s_String, "<", "")
s_String = Replace(s_String, ">", "")
s_String = Replace(s_String, "'", "")
End If
a_RecipientsCC(MyArrayLen(a_RecipientsCC, 1) - 1) = s_String
End If
Next
' Get org email
For M_Y = M_X + 1 To MyArrayLen(a_Dir, 2) - 1
' Check for recipient display name
If InStr(UCase(a_Dir(1, M_Y)), "__ATTACH_VERSION1.0_#") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__RECIP_VERSION1.0_#") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__NAMEID_VERSION1.0") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__PROPERTIES_VERSION1.0") > 0 Then
Exit For
End If
If InStr(UCase(a_Dir(1, M_Y)), "__SUBSTG1.0_403E") > 0 And a_Dir(7, M_Y) > 0 And s_Temp = "" Then
s_Temp = "1"
' Check if in short stream
s_String = ""
If a_Dir(7, M_Y) < s_MinStream Then
s_String = Replace(MyShortSectorReader(s_ShortSectSize, a_Dir(6, M_Y), a_Dir(7, M_Y), a_SSAT, s_ShortSat), Chr(0), "")
Else
s_String = MyLongSectorReader("VARIABLE", s_SectSize, a_Dir(6, M_Y), a_Dir(7, M_Y), s_fileName, s_SAT)
End If
' Check if valid SMTP address
If InStr(s_String, "@") <> 0 Then
s_String = Replace(s_String, "<", "")
s_String = Replace(s_String, ">", "")
s_String = Replace(s_String, "'", "")
End If
a_RecipientsCC(MyArrayLen(a_RecipientsCC, 1) - 1) = s_String
End If
Next
' Get recipient name
For M_Y = M_X + 1 To MyArrayLen(a_Dir, 2) - 1
' Check for recipient display name
If InStr(UCase(a_Dir(1, M_Y)), "__ATTACH_VERSION1.0_#") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__RECIP_VERSION1.0_#") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__NAMEID_VERSION1.0") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__PROPERTIES_VERSION1.0") > 0 Then
Exit For
End If
If InStr(UCase(a_Dir(1, M_Y)), "__SUBSTG1.0_3001") > 0 And a_Dir(7, M_Y) > 0 And s_Temp = "" Then
s_Temp = "1"
' Check if in short stream
s_String = ""
If a_Dir(7, M_Y) < s_MinStream Then
s_String = Replace(MyShortSectorReader(s_ShortSectSize, a_Dir(6, M_Y), a_Dir(7, M_Y), a_SSAT, s_ShortSat), Chr(0), "")
Else
s_String = MyLongSectorReader("VARIABLE", s_SectSize, a_Dir(6, M_Y), a_Dir(7, M_Y), s_fileName, s_SAT)
End If
' Check if valid SMTP address
If InStr(s_String, "@") <> 0 Then
s_String = Replace(s_String, "<", "")
s_String = Replace(s_String, ">", "")
s_String = Replace(s_String, "'", "")
End If
a_RecipientsCC(MyArrayLen(a_RecipientsCC, 1) - 1) = s_String
End If
Next
' Get recipient type and delete if wrong
For M_Y = M_X + 1 To MyArrayLen(a_Dir, 2) - 1
' Check if its in the TO list
If InStr(UCase(a_Dir(1, M_Y)), "__PROPERTIES_VERSION1.0") > 0 And a_Dir(7, M_Y) > 0 Then
' Check if in short stream
s_String = ""
If a_Dir(7, M_Y) < s_MinStream Then
s_String = MyShortSectorReader(s_ShortSectSize, a_Dir(6, M_Y), a_Dir(7, M_Y), a_SSAT, s_ShortSat)
Else
s_String = MyLongSectorReader("VARIABLE", s_SectSize, a_Dir(6, M_Y), a_Dir(7, M_Y), s_fileName, s_SAT)
End If
For M_Z = 1 To Len(s_String) Step 8
If Mid(s_String, M_Z, 4) = MyHexToHexCoded("0300150C") Then
If MyVBNumber(Mid(s_String, M_Z + 8, 1)) <> 2 And s_Temp <> "" Then
If MyArrayLen(a_RecipientsCC, 1) > 1 Then
ReDim Preserve a_RecipientsCC(MyArrayLen(a_RecipientsCC, 1) - 1)
Else
ReDim a_RecipientsCC(0)
End If
End If
End If
Next
End If
' Check for recipient email
If InStr(UCase(a_Dir(1, M_Y)), "__ATTACH_VERSION1.0_#") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__RECIP_VERSION1.0_#") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__NAMEID_VERSION1.0") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__PROPERTIES_VERSION1.0") > 0 Then
Exit For
End If
Next
End If
Next
End If
If InStr(s_Val, "RECIPIENTSBCC,") > 0 Then
' Now get the directory entry for the recipients
For M_X = 0 To MyArrayLen(a_Dir, 2) - 1
' Check for recipient
If InStr(UCase(a_Dir(1, M_X)), "__RECIP_VERSION1.0_#") > 0 Then
ReDim Preserve a_RecipientsBCC(MyArrayLen(a_RecipientsBCC, 1) + 1)
s_Temp = ""
' Get recipient name
For M_Y = M_X + 1 To MyArrayLen(a_Dir, 2) - 1
' Check for recipient email
If InStr(UCase(a_Dir(1, M_Y)), "__ATTACH_VERSION1.0_#") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__RECIP_VERSION1.0_#") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__NAMEID_VERSION1.0") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__PROPERTIES_VERSION1.0") > 0 Then
Exit For
End If
If InStr(UCase(a_Dir(1, M_Y)), "__SUBSTG1.0_39FE") > 0 And a_Dir(7, M_Y) > 0 And s_Temp = "" Then
s_Temp = "1"
' Check if in short stream
s_String = ""
If a_Dir(7, M_Y) < s_MinStream Then
s_String = Replace(MyShortSectorReader(s_ShortSectSize, a_Dir(6, M_Y), a_Dir(7, M_Y), a_SSAT, s_ShortSat), Chr(0), "")
Else
s_String = MyLongSectorReader("VARIABLE", s_SectSize, a_Dir(6, M_Y), a_Dir(7, M_Y), s_fileName, s_SAT)
End If
' Check if valid SMTP address
If InStr(s_String, "@") <> 0 Then
s_String = Replace(s_String, "<", "")
s_String = Replace(s_String, ">", "")
s_String = Replace(s_String, "'", "")
End If
a_RecipientsBCC(MyArrayLen(a_RecipientsBCC, 1) - 1) = s_String
End If
Next
' Get org email
For M_Y = M_X + 1 To MyArrayLen(a_Dir, 2) - 1
' Check for recipient display name
If InStr(UCase(a_Dir(1, M_Y)), "__ATTACH_VERSION1.0_#") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__RECIP_VERSION1.0_#") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__NAMEID_VERSION1.0") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__PROPERTIES_VERSION1.0") > 0 Then
Exit For
End If
If InStr(UCase(a_Dir(1, M_Y)), "__SUBSTG1.0_403E") > 0 And a_Dir(7, M_Y) > 0 And s_Temp = "" Then
s_Temp = "1"
' Check if in short stream
s_String = ""
If a_Dir(7, M_Y) < s_MinStream Then
s_String = Replace(MyShortSectorReader(s_ShortSectSize, a_Dir(6, M_Y), a_Dir(7, M_Y), a_SSAT, s_ShortSat), Chr(0), "")
Else
s_String = MyLongSectorReader("VARIABLE", s_SectSize, a_Dir(6, M_Y), a_Dir(7, M_Y), s_fileName, s_SAT)
End If
' Check if valid SMTP address
If InStr(s_String, "@") <> 0 Then
s_String = Replace(s_String, "<", "")
s_String = Replace(s_String, ">", "")
s_String = Replace(s_String, "'", "")
End If
a_RecipientsBCC(MyArrayLen(a_RecipientsBCC, 1) - 1) = s_String
End If
Next
' Get recipient name
For M_Y = M_X + 1 To MyArrayLen(a_Dir, 2) - 1
' Check for recipient display name
If InStr(UCase(a_Dir(1, M_Y)), "__ATTACH_VERSION1.0_#") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__RECIP_VERSION1.0_#") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__NAMEID_VERSION1.0") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__PROPERTIES_VERSION1.0") > 0 Then
Exit For
End If
If InStr(UCase(a_Dir(1, M_Y)), "__SUBSTG1.0_3001") > 0 And a_Dir(7, M_Y) > 0 And s_Temp = "" Then
s_Temp = "1"
' Check if in short stream
s_String = ""
If a_Dir(7, M_Y) < s_MinStream Then
s_String = Replace(MyShortSectorReader(s_ShortSectSize, a_Dir(6, M_Y), a_Dir(7, M_Y), a_SSAT, s_ShortSat), Chr(0), "")
Else
s_String = MyLongSectorReader("VARIABLE", s_SectSize, a_Dir(6, M_Y), a_Dir(7, M_Y), s_fileName, s_SAT)
End If
' Check if valid SMTP address
If InStr(s_String, "@") <> 0 Then
s_String = Replace(s_String, "<", "")
s_String = Replace(s_String, ">", "")
s_String = Replace(s_String, "'", "")
End If
a_RecipientsBCC(MyArrayLen(a_RecipientsBCC, 1) - 1) = s_String
End If
Next
' Get recipient type and delete if wrong
For M_Y = M_X + 1 To MyArrayLen(a_Dir, 2) - 1
' Check if its in the TO list
If InStr(UCase(a_Dir(1, M_Y)), "__PROPERTIES_VERSION1.0") > 0 And a_Dir(7, M_Y) > 0 Then
' Check if in short stream
s_String = ""
If a_Dir(7, M_Y) < s_MinStream Then
s_String = MyShortSectorReader(s_ShortSectSize, a_Dir(6, M_Y), a_Dir(7, M_Y), a_SSAT, s_ShortSat)
Else
s_String = MyLongSectorReader("VARIABLE", s_SectSize, a_Dir(6, M_Y), a_Dir(7, M_Y), s_fileName, s_SAT)
End If
For M_Z = 1 To Len(s_String) Step 8
If Mid(s_String, M_Z, 4) = MyHexToHexCoded("0300150C") Then
If MyVBNumber(Mid(s_String, M_Z + 8, 1)) <> 3 And s_Temp <> "" Then
If MyArrayLen(a_RecipientsBCC, 1) > 1 Then
ReDim Preserve a_RecipientsBCC(MyArrayLen(a_RecipientsBCC, 1) - 1)
Else
ReDim a_RecipientsBCC(0)
End If
End If
End If
Next
End If
' Check for recipient email
If InStr(UCase(a_Dir(1, M_Y)), "__ATTACH_VERSION1.0_#") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__RECIP_VERSION1.0_#") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__NAMEID_VERSION1.0") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__PROPERTIES_VERSION1.0") > 0 Then
Exit For
End If
Next
End If
Next
End If
If InStr(s_Val, "ATTACHMENTEXTRACT,") > 0 Then
' Now get the directory entry for the attachments
For M_X = 0 To MyArrayLen(a_Dir, 2) - 1
' Check for attachment
If InStr(UCase(a_Dir(1, M_X)), "__ATTACH_VERSION1.0_#") > 0 Then
ReDim Preserve a_Attachments(MyArrayLen(a_Attachments, 1) + 1)
ReDim Preserve a_Attachments2(MyArrayLen(a_Attachments2, 1) + 1)
' Get attachment name
For M_Y = M_X + 1 To MyArrayLen(a_Dir, 2) - 1
' Check for attachment name
If InStr(UCase(a_Dir(1, M_Y)), "__ATTACH_VERSION1.0_#") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__RECIP_VERSION1.0_#") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__NAMEID_VERSION1.0") > 0 Or InStr(UCase(a_Dir(1, M_Y)), "__PROPERTIES_VERSION1.0") > 0 Then
Exit For
ElseIf InStr(UCase(a_Dir(1, M_Y)), "__SUBSTG1.0_3701") > 0 Then
' Check if in short stream
If a_Dir(7, M_Y) < s_MinStream Then
s_Temp = o_FSO.GetSpecialFolder(2) & o_FSO.GetTempName
o_File = o_FSO.CreateTextFile(s_Temp, True, False)
o_File.Write(MyShortSectorReader(s_ShortSectSize, a_Dir(6, M_Y), a_Dir(7, M_Y), a_SSAT, s_ShortSat))
a_Attachments(MyArrayLen(a_Attachments, 1) - 1) = s_Temp
o_File.Close()
Else
a_Attachments(MyArrayLen(a_Attachments, 1) - 1) = MyLongSectorReader("FILE", s_SectSize, a_Dir(6, M_Y), a_Dir(7, M_Y), s_fileName, s_SAT)
End If
ElseIf InStr(UCase(a_Dir(1, M_Y)), "__SUBSTG1.0_3704") > 0 Then
' Check if in short stream
If a_Dir(7, M_Y) < s_MinStream Then
a_Attachments2(MyArrayLen(a_Attachments2, 1) - 1) = Replace(MyShortSectorReader(s_ShortSectSize, a_Dir(6, M_Y), a_Dir(7, M_Y), a_SSAT, s_ShortSat), Chr(0), "")
Else
a_Attachments2(MyArrayLen(a_Attachments2, 1) - 1) = MyLongSectorReader("VARIABLE", s_SectSize, a_Dir(6, M_Y), a_Dir(7, M_Y), s_fileName, s_SAT)
End If
ElseIf InStr(UCase(a_Dir(1, M_Y)), "__SUBSTG1.0_3707") > 0 Then
' Check if in short stream
If a_Dir(7, M_Y) < s_MinStream Then
a_Attachments2(MyArrayLen(a_Attachments2, 1) - 1) = Replace(MyShortSectorReader(s_ShortSectSize, a_Dir(6, M_Y), a_Dir(7, M_Y), a_SSAT, s_ShortSat), Chr(0), "")
Else
a_Attachments2(MyArrayLen(a_Attachments2, 1) - 1) = MyLongSectorReader("VARIABLE", s_SectSize, a_Dir(6, M_Y), a_Dir(7, M_Y), s_fileName, s_SAT)
End If
End If
Next
End If
Next
' At this stage we have temporary filenames and an array of names
' We now need to:
' - Check for existing files
' - Rename the temporary files to the new names
' Delete files in temporary folder
For M_X = 0 To MyArrayLen(a_Attachments2, 1) - 1
' Check for existing files
If o_FSO.FileExists(o_FSO.GetSpecialFolder(2) & "\" & a_Attachments2(M_X)) Then
On Error Resume Next
o_FSO.DeleteFile(o_FSO.GetSpecialFolder(2) & "\" & a_Attachments2(M_X))
On Error GoTo 0
End If
Next
' Now rename attachments
For M_X = 0 To MyArrayLen(a_Attachments2, 1) - 1
' Check for existing files
If o_FSO.FileExists(o_FSO.GetSpecialFolder(2) & "\" & a_Attachments2(M_X)) Then
M_Y = 1
Do While o_FSO.FileExists(o_FSO.GetSpecialFolder(2) & "\" & M_Y & a_Attachments2(M_X))
M_Y = M_Y + 1
Loop
o_FSO.MoveFile(a_Attachments(M_X), o_FSO.GetSpecialFolder(2) & "\" & M_Y & a_Attachments2(M_X))
a_Attachments(M_X) = o_FSO.GetSpecialFolder(2) & "\" & M_Y & a_Attachments2(M_X)
Else
o_FSO.MoveFile(a_Attachments(M_X), o_FSO.GetSpecialFolder(2) & "\" & a_Attachments2(M_X))
a_Attachments(M_X) = o_FSO.GetSpecialFolder(2) & "\" & a_Attachments2(M_X)
End If
Next
End If
' The date sent
If InStr(s_Val, "DATESENT,") > 0 Then
s_Temp = ""
' Now get the directory entry for the first properties
For M_X = 0 To MyArrayLen(a_Dir, 2) - 1
If InStr(UCase(a_Dir(1, M_X)), "__PROPERTIES_VERSION1.0") > 0 And a_Dir(7, M_X) > 0 Then
' Check if in short stream
If a_Dir(7, M_X) < s_MinStream Then
s_Temp = MyShortSectorReader(s_ShortSectSize, a_Dir(6, M_X), a_Dir(7, M_X), a_SSAT, s_ShortSat)
Exit For
Else
s_Temp = MyLongSectorReader("VARIABLE", s_SectSize, a_Dir(6, M_X), a_Dir(7, M_X), s_fileName, s_SAT)
Exit For
End If
End If
Next
' Now we've got the properties lets read them
For M_X = 1 To Len(s_Temp) Step 16
If Mid(s_Temp, M_X, 4) = MyHexToHexCoded("40003900") Then
s_DateSent = MyGregorianDate(MyVBNumber(Mid(s_Temp, M_X + 8, 8)))
End If
Next
End If
' The date received
If InStr(s_Val, "DATERECEIVED,") > 0 Then
s_Temp = ""
' Now get the directory entry for the first properties
For M_X = 0 To MyArrayLen(a_Dir, 2) - 1
If InStr(UCase(a_Dir(1, M_X)), "__PROPERTIES_VERSION1.0") > 0 And a_Dir(7, M_X) > 0 Then
' Check if in short stream
If a_Dir(7, M_X) < s_MinStream Then
s_Temp = MyShortSectorReader(s_ShortSectSize, a_Dir(6, M_X), a_Dir(7, M_X), a_SSAT, s_ShortSat)
Exit For
Else
s_Temp = MyLongSectorReader("VARIABLE", s_SectSize, a_Dir(6, M_X), a_Dir(7, M_X), s_fileName, s_SAT)
Exit For
End If
End If
Next
' Now we've got the properties lets read them
s_DateReceived = ""
For M_X = 1 To Len(s_Temp) Step 16
If Mid(s_Temp, M_X, 4) = MyHexToHexCoded("4000060E") Then
s_DateReceived = MyGregorianDate(MyVBNumber(Mid(s_Temp, M_X + 8, 8)))
End If
Next
End If
' The date reply requested
If InStr(s_Val, "DATEREPLY,") > 0 Then
s_Temp = ""
' Now get the directory entry for the first properties
For M_X = 0 To MyArrayLen(a_Dir, 2) - 1
If InStr(UCase(a_Dir(1, M_X)), "__PROPERTIES_VERSION1.0") > 0 And a_Dir(7, M_X) > 0 Then
' Check if in short stream
If a_Dir(7, M_X) < s_MinStream Then
s_Temp = MyShortSectorReader(s_ShortSectSize, a_Dir(6, M_X), a_Dir(7, M_X), a_SSAT, s_ShortSat)
Exit For
Else
s_Temp = MyLongSectorReader("VARIABLE", s_SectSize, a_Dir(6, M_X), a_Dir(7, M_X), s_fileName, s_SAT)
Exit For
End If
End If
Next
' Now we've got the properties lets read them
s_DateReply = ""
For M_X = 1 To Len(s_Temp) Step 16
If Mid(s_Temp, M_X, 4) = MyHexToHexCoded("40003000") Then
s_DateReply = MyGregorianDate(MyVBNumber(Mid(s_Temp, M_X + 8, 8)))
End If
Next
End If
' Build the return string by checking what was asked for
a_Val = Split(s_Val, ",")
s_Return = ""
For M_X = 0 To MyArrayLen(a_Val, 1) - 1
If Len(Trim(a_Val(M_X))) <> 0 Then
If UCase(Trim(a_Val(M_X))) = "SUBJECT" Then
If s_Return = "" Then
If Len(s_Subject) > 0 Then
s_Return = s_Return & s_Subject
Else
s_Return = " "
End If
Else
s_Return = s_Return & "^" & s_Subject
End If
End If
If UCase(Trim(a_Val(M_X))) = "MESSAGEID" Then
If s_Return = "" Then
If Len(s_MessageID) > 0 Then
s_Return = s_Return & s_MessageID
Else
s_Return = " "
End If
Else
s_Return = s_Return & "^" & s_MessageID
End If
End If
If UCase(Trim(a_Val(M_X))) = "FROM" Then
If s_Return = "" Then
If Len(s_From) > 0 Then
s_Return = s_Return & s_From
Else
s_Return = " "
End If
Else
s_Return = s_Return & "^" & s_From
End If
End If
If UCase(Trim(a_Val(M_X))) = "PREFIX" Then
If s_Return = "" Then
If Len(s_Prefix) > 0 Then
s_Return = s_Return & s_Prefix
Else
s_Return = " "
End If
Else
s_Return = s_Return & "^" & s_Prefix
End If
End If
If UCase(Trim(a_Val(M_X))) = "BODY" Then
If s_Return = "" Then
If Len(s_Body) > 0 Then
s_Return = s_Return & s_Body
Else
s_Return = " "
End If
Else
s_Return = s_Return & "^" & s_Body
End If
End If
If UCase(Trim(a_Val(M_X))) = "ATTACHMENTNUMBERS" Then
If s_Return = "" Then
If Len(s_AttachNums) > 0 Then
s_Return = s_AttachNums
Else
s_Return = " "
End If
Else
s_Return = s_Return & "^" & s_AttachNums
End If
End If
If UCase(Trim(a_Val(M_X))) = "ATTACHMENTNAMES" Then
If s_Return = "" Then
For M_Y = 0 To MyArrayLen(a_AttachNames, 1) - 1
s_Return = s_Return & a_AttachNames(M_Y) & "|"
Next
If Len(s_Return) = 0 Then
s_Return = " "
End If
Else
s_Return = s_Return & "^"
For M_Y = 0 To MyArrayLen(a_AttachNames, 1) - 1
s_Return = s_Return & a_AttachNames(M_Y) & "|"
Next
End If
If Right(s_Return, 1) = "|" Then
s_Return = Left(s_Return, Len(s_Return) - 1)
End If
End If
If UCase(Trim(a_Val(M_X))) = "RECIPIENTS" Then
If s_Return = "" Then
For M_Y = 0 To MyArrayLen(a_Recipients, 1) - 1
s_Return = s_Return & a_Recipients(M_Y) & "|"
Next
If Len(s_Return) = 0 Then
s_Return = " "
End If
Else
s_Return = s_Return & "^"
For M_Y = 0 To MyArrayLen(a_Recipients, 1) - 1
s_Return = s_Return & a_Recipients(M_Y) & "|"
Next
End If
If Right(s_Return, 1) = "|" Then
s_Return = Left(s_Return, Len(s_Return) - 1)
End If
End If
If UCase(Trim(a_Val(M_X))) = "RECIPIENTSTO" Then
If s_Return = "" Then
For M_Y = 0 To MyArrayLen(a_RecipientsTo, 1) - 1
s_Return = s_Return & a_RecipientsTo(M_Y) & "|"
Next
If Len(s_Return) = 0 Then
s_Return = " "
End If
Else
s_Return = s_Return & "^"
For M_Y = 0 To MyArrayLen(a_RecipientsTo, 1) - 1
s_Return = s_Return & a_RecipientsTo(M_Y) & "|"
Next
End If
If Right(s_Return, 1) = "|" Then
s_Return = Left(s_Return, Len(s_Return) - 1)
End If
End If
If UCase(Trim(a_Val(M_X))) = "RECIPIENTSCC" Then
If s_Return = "" Then
For M_Y = 0 To MyArrayLen(a_RecipientsCC, 1) - 1
s_Return = s_Return & a_RecipientsCC(M_Y) & "|"
Next
If Len(s_Return) = 0 Then
s_Return = " "
End If
Else
s_Return = s_Return & "^"
For M_Y = 0 To MyArrayLen(a_RecipientsCC, 1) - 1
s_Return = s_Return & a_RecipientsCC(M_Y) & "|"
Next
End If
If Right(s_Return, 1) = "|" Then
s_Return = Left(s_Return, Len(s_Return) - 1)
End If
End If
If UCase(Trim(a_Val(M_X))) = "RECIPIENTSBCC" Then
If s_Return = "" Then
For M_Y = 0 To MyArrayLen(a_RecipientsBCC, 1) - 1
s_Return = s_Return & a_RecipientsBCC(M_Y) & "|"
Next
If Len(s_Return) = 0 Then
s_Return = " "
End If
Else
s_Return = s_Return & "^"
For M_Y = 0 To MyArrayLen(a_RecipientsBCC, 1) - 1
s_Return = s_Return & a_RecipientsBCC(M_Y) & "|"
Next
End If
If Right(s_Return, 1) = "|" Then
s_Return = Left(s_Return, Len(s_Return) - 1)
End If
End If
If UCase(Trim(a_Val(M_X))) = "ATTACHMENTEXTRACT" Then
If s_Return = "" Then
For M_Y = 0 To MyArrayLen(a_Attachments, 1) - 1
s_Return = s_Return & a_Attachments(M_Y) & "|"
Next
If Len(s_Return) = 0 Then
s_Return = " "
End If
Else
s_Return = s_Return & "^"
For M_Y = 0 To MyArrayLen(a_Attachments, 1) - 1
s_Return = s_Return & a_Attachments(M_Y) & "|"
Next
End If
If Right(s_Return, 1) = "|" Then
s_Return = Left(s_Return, Len(s_Return) - 1)
End If
End If
If UCase(Trim(a_Val(M_X))) = "DATESENT" Then
If s_Return = "" Then
s_Return = s_DateSent
If Len(s_Return) = 0 Then
s_Return = " "
End If
Else
s_Return = s_Return & "^" & s_DateSent
End If
End If
If UCase(Trim(a_Val(M_X))) = "DATERECEIVED" Then
If s_Return = "" Then
s_Return = s_DateReceived
If Len(s_Return) = 0 Then
s_Return = " "
End If
Else
s_Return = s_Return & "^" & s_DateReceived
End If
End If
If UCase(Trim(a_Val(M_X))) = "DATEREPLY" Then
If s_Return = "" Then
s_Return = s_DateReply
If Len(s_Return) = 0 Then
s_Return = " "
End If
Else
s_Return = s_Return & "^" & s_DateReply
End If
End If
If UCase(Trim(a_Val(M_X))) = "REPLYTYPE" Then
If s_Return = "" Then
s_Return = s_ReplyType
If Len(s_Return) = 0 Then
s_Return = " "
End If
Else
s_Return = s_Return & "^" & s_ReplyType
End If
End If
End If
Next
MsgGet = s_Return
o_File = Nothing
o_FSO = Nothing
End Function
Function MyHexToHexCoded(ByVal s_String)
' **********************************************************************************
' Description : Takes a string such as "D0CF" and returns a HEX string which can be
' compared with characters read from a file
' Created : 24/12/2005
' Version : 1.0
' **********************************************************************************
Dim M_X
Dim s_Temp
s_Temp = ""
For M_X = 1 To Len(s_String) Step 2
s_Temp = s_Temp & Chr(CLng("&H" & Mid(s_String, M_X, 2)))
Next
MyHexToHexCoded = s_Temp
End Function
Function MyVBNumber(ByVal s_String)
' **********************************************************************************
' Description : Takes chars read from file and converts to number
' Created : 24/12/2005
' Version : 1.0
' **********************************************************************************
MyVBNumber = 0
If Len(s_String) = 1 Then
If Asc(Mid(s_String, 1, 1)) = 255 Then
MyVBNumber = -1
ElseIf Asc(Mid(s_String, 1, 1)) = 254 Then
MyVBNumber = -1
ElseIf Asc(Mid(s_String, 1, 1)) = 253 Then
MyVBNumber = -2
ElseIf Asc(Mid(s_String, 1, 1)) = 252 Then
MyVBNumber = -3
ElseIf Asc(Mid(s_String, 1, 1)) = 251 Then
MyVBNumber = -4
Else
MyVBNumber = Asc(Mid(s_String, 1, 1))
End If
ElseIf Len(s_String) = 2 Then
If Asc(Mid(s_String, 1, 1)) = 255 And Asc(Mid(s_String, 2, 1)) = 255 Then
MyVBNumber = -1
ElseIf Asc(Mid(s_String, 1, 1)) = 254 And Asc(Mid(s_String, 2, 1)) = 255 Then
MyVBNumber = -1
ElseIf Asc(Mid(s_String, 1, 1)) = 253 And Asc(Mid(s_String, 2, 1)) = 255 Then
MyVBNumber = -2
ElseIf Asc(Mid(s_String, 1, 1)) = 252 And Asc(Mid(s_String, 2, 1)) = 255 Then
MyVBNumber = -3
ElseIf Asc(Mid(s_String, 1, 1)) = 251 And Asc(Mid(s_String, 2, 1)) = 255 Then
MyVBNumber = -4
Else
MyVBNumber = Asc(Mid(s_String, 1, 1)) + Asc(Mid(s_String, 2, 1)) * 256
End If
ElseIf Len(s_String) = 4 Then
If Asc(Mid(s_String, 1, 1)) = 255 And Asc(Mid(s_String, 2, 1)) = 255 And Asc(Mid(s_String, 3, 1)) = 255 And Asc(Mid(s_String, 4, 1)) = 255 Then
MyVBNumber = -1
ElseIf Asc(Mid(s_String, 1, 1)) = 254 And Asc(Mid(s_String, 2, 1)) = 255 And Asc(Mid(s_String, 3, 1)) = 255 And Asc(Mid(s_String, 4, 1)) = 255 Then
MyVBNumber = -1
ElseIf Asc(Mid(s_String, 1, 1)) = 253 And Asc(Mid(s_String, 2, 1)) = 255 And Asc(Mid(s_String, 3, 1)) = 255 And Asc(Mid(s_String, 4, 1)) = 255 Then
MyVBNumber = -2
ElseIf Asc(Mid(s_String, 1, 1)) = 252 And Asc(Mid(s_String, 2, 1)) = 255 And Asc(Mid(s_String, 3, 1)) = 255 And Asc(Mid(s_String, 4, 1)) = 255 Then
MyVBNumber = -3
ElseIf Asc(Mid(s_String, 1, 1)) = 251 And Asc(Mid(s_String, 2, 1)) = 255 And Asc(Mid(s_String, 3, 1)) = 255 And Asc(Mid(s_String, 4, 1)) = 255 Then
MyVBNumber = -4
Else
MyVBNumber = Asc(Mid(s_String, 1, 1)) + Asc(Mid(s_String, 2, 1)) * 256 + Asc(Mid(s_String, 3, 1)) * 65536 + Asc(Mid(s_String, 4, 1)) * 16777216
End If
ElseIf Len(s_String) = 8 Then
If Asc(Mid(s_String, 1, 1)) = 255 And Asc(Mid(s_String, 2, 1)) = 255 And Asc(Mid(s_String, 3, 1)) = 255 And Asc(Mid(s_String, 4, 1)) = 255 And Asc(Mid(s_String, 5, 1)) = 255 And Asc(Mid(s_String, 6, 1)) = 255 And Asc(Mid(s_String, 7, 1)) = 255 And Asc(Mid(s_String, 8, 1)) = 255 Then
MyVBNumber = -1
ElseIf Asc(Mid(s_String, 1, 1)) = 254 And Asc(Mid(s_String, 2, 1)) = 255 And Asc(Mid(s_String, 3, 1)) = 255 And Asc(Mid(s_String, 4, 1)) = 255 And Asc(Mid(s_String, 5, 1)) = 255 And Asc(Mid(s_String, 6, 1)) = 255 And Asc(Mid(s_String, 7, 1)) = 255 And Asc(Mid(s_String, 8, 1)) = 255 Then
MyVBNumber = -1
ElseIf Asc(Mid(s_String, 1, 1)) = 253 And Asc(Mid(s_String, 2, 1)) = 255 And Asc(Mid(s_String, 3, 1)) = 255 And Asc(Mid(s_String, 4, 1)) = 255 And Asc(Mid(s_String, 5, 1)) = 255 And Asc(Mid(s_String, 6, 1)) = 255 And Asc(Mid(s_String, 7, 1)) = 255 And Asc(Mid(s_String, 8, 1)) = 255 Then
MyVBNumber = -2
ElseIf Asc(Mid(s_String, 1, 1)) = 252 And Asc(Mid(s_String, 2, 1)) = 255 And Asc(Mid(s_String, 3, 1)) = 255 And Asc(Mid(s_String, 4, 1)) = 255 And Asc(Mid(s_String, 5, 1)) = 255 And Asc(Mid(s_String, 6, 1)) = 255 And Asc(Mid(s_String, 7, 1)) = 255 And Asc(Mid(s_String, 8, 1)) = 255 Then
MyVBNumber = -3
ElseIf Asc(Mid(s_String, 1, 1)) = 251 And Asc(Mid(s_String, 2, 1)) = 255 And Asc(Mid(s_String, 3, 1)) = 255 And Asc(Mid(s_String, 4, 1)) = 255 And Asc(Mid(s_String, 5, 1)) = 255 And Asc(Mid(s_String, 6, 1)) = 255 And Asc(Mid(s_String, 7, 1)) = 255 And Asc(Mid(s_String, 8, 1)) = 255 Then
MyVBNumber = -4
Else
MyVBNumber = Asc(Mid(s_String, 1, 1)) + Asc(Mid(s_String, 2, 1)) * 256 + Asc(Mid(s_String, 3, 1)) * 65536 + Asc(Mid(s_String, 4, 1)) * 16777216 + Asc(Mid(s_String, 5, 1)) * 4294967296 + Asc(Mid(s_String, 6, 1)) * 1099511627776 + Asc(Mid(s_String, 7, 1)) * 281474976710656 + Asc(Mid(s_String, 8, 1)) * 72057594037927900
End If
End If
End Function
Function MyArrayLen(ByVal MyArray, ByVal MyDim)
' *****************************************************************************
' Function : MyArrayLen
' Arguments : Array to get length of
' Dimension of array to test
' Returns : Length of array
' Description : Returns the length of an array even if it is null or not
' defined. UBound does not work on some types of variant array
' so discovered best to use For Each when dimension 1 and UBound
' for other dimensions.
' Created : 20/10/2001 S Currie
' *****************************************************************************
Dim MyLength
MyLength = 0
On Error Resume Next
MyLength = UBound(MyArray, MyDim)
If MyLength < 0 Then
MyLength = 0
End If
MyArrayLen = MyLength
End Function
Function MySectorReader(ByVal s_SectSize, ByVal s_SID, ByVal s_FileName)
' **********************************************************************************
' Description : Reads a number of characters from a particular sector in a file
' Arguments : The size of the sectors to be read
' The particluar sector to be read
' The filename which they are to be read from
' Created : 30/12/2005
' Version : 1.0
' **********************************************************************************
Dim o_FSO
Dim o_File
' Create object and get the file
o_FSO = My.Computer.FileSystem
If Not o_FSO.FileExists(s_FileName) Then
MySectorReader = ""
Exit Function
End If
If UCase(Right(s_FileName, 4)) <> ".MSG" Then
MySectorReader = ""
Exit Function
End If
o_File = o_FSO.OpenTextFile(s_FileName, 1, -1)
' Now read up to the sector
o_File.Skip((s_SID * s_SectSize) + s_SectSize)
' Now read the sector itself
On Error Resume Next
MySectorReader = o_File.Read(s_SectSize)
o_File.Close()
o_File = Nothing
o_FSO = Nothing
End Function
Function MyShortSectorReader(ByVal s_ShortSectSize, ByVal s_SID, ByVal s_Size, ByVal a_SSAT, ByVal s_ShortSat)
' **********************************************************************************
' Description : Reads a number of characters from the short sector container which
' is held in the memory variable s_ShortSat. The a_SSAT is a directory
' array which tell you how to access the s_ShortSat
' Arguments : The size of the sectors to be read
' The particluar sector to be read within s_ShortSat
' The size of the value to return
' The array which contains the details of how to
' access the s_ShortSat
' This is the short container stream read from
' the file
' Created : 31/12/2005
' Version : 1.0
' **********************************************************************************
Dim M_Y
Dim s_Temp
M_Y = s_SID
s_Temp = Mid(s_ShortSat, s_SID * s_ShortSectSize + 1, s_ShortSectSize)
Do While True
M_Y = a_SSAT(M_Y)
If M_Y > 0 Then
s_Temp = s_Temp & Mid(s_ShortSat, M_Y * s_ShortSectSize + 1, s_ShortSectSize)
End If
If Len(s_Temp) >= s_Size Then
Exit Do
End If
Loop
MyShortSectorReader = Mid(s_Temp, 1, s_Size)
End Function
Function MyLongSectorReader(ByVal s_ReturnType, ByVal s_SectSize, ByVal s_SID, ByVal s_Size, ByVal s_FileName, ByVal s_SAT)
' **********************************************************************************
' Description : Reads a number of characters from the short sector container which
' is held in the memory variable s_ShortSat. The a_SSAT is a directory
' array which tell you how to access the s_ShortSat
' Arguments : <
' The size of the sectors to be read
' The particluar sector to be read within s_ShortSat
' The size of the value to return
' The array which contains the details of how to
' access the s_ShortSat
' This is the short container stream read from
' the file
' Created : 31/12/2005
' Version : 1.0
' **********************************************************************************
Dim M_Y
Dim s_Temp = Nothing
Dim o_FSO
Dim o_File
Dim M_X
Dim s_Start
Dim s_Previous
Dim s_Sects
M_X = s_Size
MyLongSectorReader = ""
If s_ReturnType = "FILE" Then
' Create object and the file
o_FSO = My.Computer.FileSystem
s_Temp = o_FSO.GetSpecialFolder(2) & "\" & o_FSO.GetTempName
o_File = o_FSO.CreateTextFile(s_Temp, True, False)
M_Y = s_SID
o_File.Write(MySectorReader(s_SectSize, M_Y, s_FileName))
M_X = M_X - s_SectSize
s_Previous = -99
s_Sects = 0
s_Start = 0
Do While True
M_Y = MyVBNumber(Mid(s_SAT, (M_Y * 4) + 1, 4))
If s_Previous = M_Y - 1 Then
s_Previous = M_Y
s_Sects = s_Sects + 1
ElseIf s_Previous <> M_Y - 1 Then
If s_Sects > 0 Then
M_X = M_X - (s_SectSize * s_Sects)
o_File.Write(MyMultiSectorReader(s_SectSize, s_Start, s_FileName, s_Sects))
End If
s_Previous = M_Y
s_Sects = 1
s_Start = M_Y
End If
If M_X <= 0 Then
Exit Do
End If
Loop
o_File.Close()
ElseIf s_ReturnType = "VARIABLE" Then
M_Y = s_SID
s_Temp = MySectorReader(s_SectSize, M_Y, s_FileName)
Do While True
M_Y = MyVBNumber(Mid(s_SAT, (M_Y * 4) + 1, 4))
If M_Y > 0 Then
s_Temp = s_Temp & MySectorReader(s_SectSize, M_Y, s_FileName)
End If
If Len(s_Temp) >= s_Size Then
Exit Do
End If
Loop
s_Temp = Mid(s_Temp, 1, s_Size)
End If
MyLongSectorReader = s_Temp
End Function
Function MyMultiSectorReader(ByVal s_SectSize, ByVal s_SID, ByVal s_FileName, ByVal s_Number)
' **********************************************************************************
' Description : Reads a number of characters from a particular sector in a file
' Arguments : The size of the sectors to be read
' The particluar sector to be read
' The filename which they are to be read from
' The number of sectors to read
' Created : 01/01/2006
' Version : 1.0
' **********************************************************************************
Dim o_FSO
Dim o_File
' Create object and get the file
o_FSO = My.Computer.FileSystem
If Not o_FSO.FileExists(s_FileName) Then
MyMultiSectorReader = ""
Exit Function
End If
If UCase(Right(s_FileName, 4)) <> ".MSG" Then
MyMultiSectorReader = ""
Exit Function
End If
o_File = o_FSO.OpenTextFile(s_FileName, 1, -1)
' Now read up to the sector
o_File.Skip((s_SID * s_SectSize) + s_SectSize)
' Now read the sector itself
On Error Resume Next
MyMultiSectorReader = o_File.Read(s_SectSize * s_Number)
o_File.Close()
o_File = Nothing
o_FSO = Nothing
End Function
Function MyGregorianDate(ByVal l_Val)
' **********************************************************************************
' Description : Returns a date from a property tag in Outlook properties
' Arguments : The VB number to convert
' Created : 03/02/2007
' Version : 1.0
' **********************************************************************************
Dim l_FracSecs
Dim l_RemSecs
Dim l_Secs
Dim l_RemMins
Dim l_Mins
Dim l_RemHours
Dim l_Hours
Dim l_RemDays
Dim l_Year
Dim l_RemDays2
l_FracSecs = ((l_Val / 10000000) - Int(l_Val / 10000000)) * 10000000
l_RemSecs = l_Val / 10000000
l_Secs = Math.Round(((l_RemSecs / 60) - Int(l_RemSecs / 60)) * 60, 0)
l_RemMins = Int(l_RemSecs / 60)
l_Mins = Math.Round(((l_RemMins / 60) - Int(l_RemMins / 60)) * 60, 0)
l_RemHours = Int(l_RemMins / 60)
l_Hours = Math.Round(((l_RemHours / 24) - Int(l_RemHours / 24)) * 24, 0)
l_RemDays = Int(l_RemHours / 24)
l_Year = 1601 + Int(l_RemDays / 365)
'l_RemDays2 = 109572 + DateSerial(l_Year, 1, 1) - DateSerial(1901, 1, 1)
'MyGregorianDate = DateAdd("d", l_RemDays - l_RemDays2, "01/01/" & l_Year)
'MyGregorianDate = DateAdd("h", l_Hours, MyGregorianDate)
'MyGregorianDate = DateAdd("n", l_Mins, MyGregorianDate)
'MyGregorianDate = DateAdd("s", l_Secs, MyGregorianDate)
If Year(MyGregorianDate) < 1902 Then
MyGregorianDate = ""
End If
End Function
Function MySubRead(ByVal l_Left, ByVal l_Right, ByVal a_Dir, ByVal a_Temp)
MySubRead = Nothing
' **********************************************************************************
' Description : Reads a directory structure backwards and forwards
' Arguments : The directory entry
' Created : 23/02/2007
' Version : 1.0
' **********************************************************************************
Dim M_X
For M_X = 0 To MyArrayLen(a_Dir, 2) - 1
If a_Dir(0, M_X) = l_Left Then
If a_Dir(3, M_X) <> -1 Then
MySubRead(a_Dir(3, M_X), -1, a_Dir, a_Temp)
End If
If a_Dir(5, M_X) = -1 Then
' Add to final array
ReDim Preserve a_Temp(8, MyArrayLen(a_Temp, 2) + 1)
a_Temp(0, MyArrayLen(a_Temp, 2) - 1) = a_Dir(0, M_X)
a_Temp(1, MyArrayLen(a_Temp, 2) - 1) = a_Dir(1, M_X)
a_Temp(2, MyArrayLen(a_Temp, 2) - 1) = a_Dir(2, M_X)
a_Temp(3, MyArrayLen(a_Temp, 2) - 1) = a_Dir(3, M_X)
a_Temp(4, MyArrayLen(a_Temp, 2) - 1) = a_Dir(4, M_X)
a_Temp(5, MyArrayLen(a_Temp, 2) - 1) = a_Dir(5, M_X)
a_Temp(6, MyArrayLen(a_Temp, 2) - 1) = a_Dir(6, M_X)
a_Temp(7, MyArrayLen(a_Temp, 2) - 1) = a_Dir(7, M_X)
End If
End If
Next
For M_X = 0 To MyArrayLen(a_Dir, 2) - 1
If a_Dir(0, M_X) = l_Left Then
If a_Dir(4, M_X) <> -1 Then
MySubRead(-1, a_Dir(4, M_X), a_Dir, a_Temp)
End If
End If
Next
For M_X = 0 To MyArrayLen(a_Dir, 2) - 1
If a_Dir(0, M_X) = l_Right Then
If a_Dir(3, M_X) <> -1 Then
MySubRead(a_Dir(3, M_X), -1, a_Dir, a_Temp)
End If
If a_Dir(5, M_X) = -1 Then
' Add to final array
ReDim Preserve a_Temp(8, MyArrayLen(a_Temp, 2) + 1)
a_Temp(0, MyArrayLen(a_Temp, 2) - 1) = a_Dir(0, M_X)
a_Temp(1, MyArrayLen(a_Temp, 2) - 1) = a_Dir(1, M_X)
a_Temp(2, MyArrayLen(a_Temp, 2) - 1) = a_Dir(2, M_X)
a_Temp(3, MyArrayLen(a_Temp, 2) - 1) = a_Dir(3, M_X)
a_Temp(4, MyArrayLen(a_Temp, 2) - 1) = a_Dir(4, M_X)
a_Temp(5, MyArrayLen(a_Temp, 2) - 1) = a_Dir(5, M_X)
a_Temp(6, MyArrayLen(a_Temp, 2) - 1) = a_Dir(6, M_X)
a_Temp(7, MyArrayLen(a_Temp, 2) - 1) = a_Dir(7, M_X)
End If
End If
Next
For M_X = 0 To MyArrayLen(a_Dir, 2) - 1
If a_Dir(0, M_X) = l_Right Then
If a_Dir(4, M_X) <> -1 Then
MySubRead(-1, a_Dir(4, M_X), a_Dir, a_Temp)
End If
End If
Next
End Function
End Module
?>