Personal encryption / Crittografia personale

CrittografASCII.exe, the utility I implemented for me, is useful for everyone who want maintain secret its own texts. For it is based on two absolutely atypical algorithms, both different from all till now known, the encrypted texts are very difficult to be decrypted at least by people they don’t’ have this program (and the encryption code, of course).

The program can be downloaded from:

http://www.giannigiaccaglini.it/download/CrittografASCII.zip

How use it

After unzipping CrittografASCII.zip the CrittografASCII.exe can be launched in PCs with Vista/Win7 operating systems or at least Windows XP with Xpack 3.0. It is a windows Form similar to the following:


AMBA 12,35 (dodici,35) rabà ciccì coccò o coccù? 51.306,80 (cinquantunomilatrecentosei,80) 3 (tre) anzi 9 [nove] civette sul comù o comò? Boh... 38 --> 24 3,5 x 2 = 7 ! Tiè: 3,5 x 2 = 7 [sette]? ESATTO!! Perché no- ? 1) Quant'è bella giovinezza; 2) che si fugge tuttavia; 3) chi vuol esser lieto, sia! alla faccia di Budda 4) del diman non v'ha certezza. AMBA 12,35 (dodici,35) rabà ciccì coccò o coccù? 51.306,80 (cinquantunomilatrecentosei,80) 3 (tre) anzi 9 [nove] civette sul comù o comò? Boh... 38 --> 24 3,5 x 2 = 7 ! Tiè: 3,5 x 2 = 7 [sette]? ESATTO!! Perché no ? Boh 1) Quant'è bella giovinezza; 2) che si fugge tuttavia; 3) chi vuol esser lieto, sia! 4) del diman non v'ha certezza.
		Chiave
	dfG860kLMuwe123xabZoPq9fwgmfG
		n.b. NO blanks, digits o spec. char.)!
		(anyway code ignores them)
		Cripta

The (few) texts are in Italian, included the demo one in the multiline textbox on the left, which can be modified substituting it with every other text. Also very clear I the meaning of button ‘s text “Cripta” (Crypt it), witch becomes “Decripta”(Decrypt it) after encrypting operation.

Two word about algorytms I used

They are combined together. The former encrypts numeric characters in other numeric chars. So if an hypothetical powerful decrypting tool attempts to retrieve an original “D-day will be at 17-6 in 1234 site” from the “G-j#k p#c~ @p xy 30-2l s 2085 w§tf” my program encrypted it could find something like “D-day will be at çù?yj in èò$/% site “. Maybe a suspect arises on digit-to-digit translation? Yes but retrieving original number is about impossible, even with simple transliteration criteria used, because generally number meaning is neutral.

The latter criterion is applied to letters, by transliterations varying in pseudo-random sequence, because they depend not only by the encryption key but by the various lettere of the text itself, too.

FOR PEOPLE INTERESTED IN CUSTOMIZED VERSIONS AND/OR VB LISTING (FOR CHEAP CHARGE…):

Gianni Giaccaglini giannigiac@tin.it

?>

posted @ 12.38 | Feedback (0)

Bug inattesi per via della semantica

10324.aspx

I bachi inattesi? Colpa della Semantica, signori miei...

Questo post, frivolo nell’esemplificazione che darò, pretende in modo alquanto serioso di discutere su un problema che affligge l’Informatica e non solo. Parlo della Semantica, disciplina linguistica che si occupa del significato di un testo, meaning in inglese. Di sfuggita cito solo un interrogativo provocatorio (che riprendo – se non ricordo male - dal ponderoso trattato di Semiotica generale di Umberto Eco): The meaning of the meaning che diavolo è?

In due parole, alla buona, la faccenda ha a che fare - nella vita o peggio ancora nella giurisprudenza - coi molti fraintendimenti derivanti dalla più o meno evitabile divaricazione fra i significati letterali e quelli intenzionali (cosiddetti). In gergo semiotico si tenta una distinzione fra denotazione e connotazione di un messaggio.

Venendo allo specifico dell’Informatica sono noti i fallimenti di certi settori avanzati. Tipicamente l’Intelligenza Artificiale (IA) o un suo figliolo, la traduzione automatica. L’IA ogni tanto viene ri-chiamata in ballo ma oggi dei tanto celebrati Sistemi Esperti quasi nessuno parla più. La seconda da qualche tempo partorisce qualche topolino non del tutto privo di utilità, però ognuno di noi ha quotidianamente modo di ridacchiare di fronte a certi risultati del pur potente traduttore di Google...

Un test al volo, mentre scrivo queste noterelle. “Non tutto il male viene per nuocere” mi viene reso con “Every cloud has a silver lining”!!! Il buffo è che la traduzione inversa restituisce “Ogni nuvola ha un rivestimento d'argento”. Formalmente corretto, a parte la stramberia semantica e l’ancor più imbarazzante fatto che non ha nulla a che fare con l’originale.

Il frivolo esempio: ruotine eliminare cifre da una stringa

Appartiene all’autobiografia recente. Volevo una routinetta volta a eliminare i caratteri numerici da una stringa. Ed ecco una serie di tentativi infruttuosi di specifiche Sub, prima in VBA poi in Visual Basic 2008, che ho corredato con istruzioni messaggistiche opportune per facilitarne l’esecuzione passo dopo passo a chi legge.

Prima versione

Sub EliminaCifre()

Dim MiaStr As String, Car As String, i As Integer

MiaStr = "Amba12raba2345cicci178"

For i = 1 To Len(MiaStr)

Car = Mid(MiaStr, i, 1)

If IsNumeric(Car) Then

MiaStr = Replace(MiaStr, Car, "")

End If

MsgBox("i = " & i & vbLf & "Car = " _

& Car & vbLf & "MiaStr = " & MiaStr)

End Sub

Lanciando la procedurina si notano due stranezze inattese (per gente ingenua come molti di noi siamo):

non tutte le cifre vengono eliminate e l’MsgBox conclusivo proclama “Stringa finale: ambaraba34cicci8”;
il ciclo va avanti fino a i = 22 (la Len iniziale della stringa), indicando caratteri vuoti (blank) negli ultimi passaggi.

Dopo riflessione mi sono reso conto che il guaio deriva dal fatto che lunghezza della MiaStr diminuisce di un’unità ad ogni rimpiazzo di una cifra con “” (Replace(MiaStr, Car, “”). La pezza (patch) è presto trovata.

Seconda versione

Sub EliminaCifreBIS()

Dim MiaStr As String, Car As String, i As Integer

MiaStr = "Amba12raba2345cicci178"

For i = 1 To Len(MiaStr)

Car = Mid(MiaStr, i, 1)

If IsNumeric(Car) Then

MiaStr = Replace(MiaStr, Car, "")

i = i - 1

End If

MsgBox ("i = " & i & vbLf & "Car = " _

& Car & vbLf & "MiaStr = " & MiaStr)

End Sub

L’aggiunta, evidenziata in giallo, è semplicemente la correzione i = i - 1 ogni volta che una cifra è rimpiazzata. Ci potremmo accontentare, visto che il risultato ora è corretto, anche se resta la seconda anomalia.

Da queste come da altre esperienza si evince facilmente il principio enunciato in apertura, che nel caso del software, tradurrei nella legge seguente:

In Informatica è la Semantica lo scoglio in cui s’infrangono molti prodotti, a causa della discrasia non sempre evitabile fra l’intenzionalità dell’uomo e la fredda, inesorabile logica letterale della macchina.

Visual Studio 2008: mondo nuovo, altra sorpresa

In tale ambiente ho poi testato il precedente programmetto. Funzionava, ma poi pur non essendo un benpensante ho... ben pensato di sostituire Car As String con Car As Char (non supportato in VBA o VB6) più moderno e logico, visto che si tratta di un singolo carattere. Già che c’ero, ho approfittato della possibilità di accedere con un indice a ciascun carattere di una stringa, con Car = MiaStr(i).

Terza versione (VB 2008)

Sub EliminaCifre()

Dim MiaStr As String, Car As Char, i As Integer

MiaStr = "Amba12raba2345cicci178"

For i = 0 To Len(MiaStr) - 1

Car = MiaStr(i)

If IsNumeric(Car) Then

Mid(MiaStr, i, 1) = Replace(MiaStr, Car, "")

i -= 1

End If

MessageBox.Show("i = " & i & vbLf & "Car = " _

& Car & vbLf & "MiaStr = " & MiaStr)

End Sub

Tutto bene? Macché. L’illusione semantica stavolta naufraga in modo, come sempre, inatteso. Infatti non si procede con tutti i 22 giri del loop For i = 0 To Len(MiaStr) ... Next in quanto ahimè il programma si arresta per errore a run-time sulla tanto ammirata istruzione moderna Car = MiaStr(i), con indicazione di indice fuori dai limiti.

Riflettendo adeguatamente comprendiamo che:

il ciclo For... To Next del Visual Basic (a differenza di altri linguaggi, credo) valuta una tantum l’espressione all’inizio e ne mantiene il valore in tutto il suo corso (in altri casi questa è una virtù, ma qui ci crea un guaio);
Mid(MiaStr, i, 1) è permissivo al punto di non dare errore se l’indice va fuori della stringa (semplicemente restituisce un blank); al contrario di Car(i), che invece considera la stringa come un vettore di caratteri.

Nota. Stavolta potremmo anche prendersela con l’architetto del VB 2008 di Microsoft, ma dobbiamo rassegnarci e prendere atto della realtà.

Soluzione finale

Ne riporto il nocciolo, astenendomi dal commentare altre varianti “moderne”, dicendo solo che alla fine ho adottato un ciclo While ... End While (While... Wend in VBA/VB6) che è immune dalla persistenza della lunghezza imputabile a For... Next e, pertanto, fa sì che MiaStr.Length muti dinamicamente ad ogni giro dell’anello.

Dim i = 0

While i < MiaStr.Length

Car = MiaStr(i)

CodCar = Char.ConvertToUtf32(Car, 0)

If Not (CodCar < 48 Or CodCar > 57) Then

MiaStr = MiaStr.Replace(Car, "")

i -= 1

End If

i += 1

End While

?>

posted @ 17.04 | Feedback (0)

Il Ribbon personalizzabile di Office 2010 (con accesso a file PDF, da conservare)

Il Ribbon personalizzabile di Office 2010

Questa interessante novità si offre come alternativa per utenti “normali” rispetto al sistema di personalizzazione avanzata della barra multifunzione, che, ricordiamo, richiede la creazione a parte di appositi file customUI.xml.

Per consentirne lo studio ho preparato un file PDF, che si può scaricare da:

http://www.giannigiaccaglini.it/download/Nuovo%20Ribbon2010Personalizzabile.pdf

Buona lettura.

?>

posted @ 11.55 | Feedback (0)

Crittografia di fogli Excel: un bug sanato

Nell’articolo “Crittografia personale avanzata di fogli Excel” pubblicato sul mio blog in Shareoffice al link seguente

http://blog.shareoffice.it/giannigiaccaglini/articles/9983.aspx

ho per distrazione commesso un errore idiota, segnalatomi da un visitatore, da cui è afflitto il modello CriptografLaborAv.xls. Meglio tardi che mai. Ho corretto l’uno e l’altro e adesso il modello emendato si lascia scaricare da

http://www.giannigiaccaglini.it/download/CriptografLaborAv.xls

Dov’era il bug

In sostanza affliggeva la funzione (basilare, ahimè) CriptStr che falliva con le cifre 9 e 0 (zero). Ci ho messo una pezza che rimedia al difetto, anche se non è troppo bella. Appena ho tempo (quando? mah!) produrrò una versione più elegante. Per adesso ecco qua:

Function CriptStr(ByVal Str As String, Cript As Boolean, EstNum As Boolean, IndArr As Integer) As String
If Str = "" Then Exit Function
Dim i As Integer, L As Integer, m As Integer
'Trattamento cifre numeriche: restano TALI!
Dim Correz As Integer, Car As String
L = Len(Str)
If L = 1 Then
    If Cript Then
      CriptStr = IIf(Str < 9, Str + 1, 0)
    Else
      CriptStr = IIf(Str > 0, Str - 1, 9)
    End If
    Exit Function
End If
If EstNum Then
      For i = 1 To L
        k = k + 1 'La translitter.ne delle cifre
        'è sistematicamente progressiva (un criterio come un altro...)
        Correz = k Mod 9 - 1
        Car = Mid(Str, i, 1)
        If Not (Car = "," Or Car = ".") Then
          If Cript Then
            Car = Car + Correz
            If Car >= 9 Then Car = Car - 9
          Else
            Car = Car - Correz
            If Car <= 0 Then Car = Car + 9
          End If
        End If
        Mid(Str, i, 1) = Car
      Next
    CriptStr = Str
    Exit Function
End If
Dim NumAsc As Integer
VettChiavi = Array(Array(43, 12, 5, 14, 21, 33, 124, 3, 5, 89, 65), _
                     Array(35, 27, 7, 5, 45, 33, 32, 47, 65, 33, 42), _
                     Array(24, 12, 75, 48, 12, 68, 4, 5, 12, 35, 69))
m = UBound(VettChiavi(IndArr))
If k >= m Then k = 0 Else k = k + 1
For i = 1 To L
    Correz = VettChiavi(IndArr)(k) + (L Mod 256)
    If Not Cript Then Correz = -Correz
    NumAsc = Asc(Mid(Str, i, 1)) + Correz
    If Cript Then
      If NumAsc > 255 Then NumAsc = NumAsc - 255
    Else
      If NumAsc < 0 Then NumAsc = NumAsc + 255
    End If
    Car = Chr(NumAsc)
    Mid(Str, i, 1) = Car
    If k = m Then k = 0 Else k = k + 1
Next
CriptStr = Str
End Function

Se qualcuno trova di meglio…

Penso che comunque, a vecchi come a nuovi visitatori interessati al tema, convenga rileggersi l’articolo (emendato), come ripeto al seguente URL

http://blog.shareoffice.it/giannigiaccaglini/articles/9983.aspx

?>

posted @ 16.28 | Feedback (0)

Divagazioni di fine 2009, su antinomie e dintorni

Considerazioni fuori programma (rispetto alle macro e all'IT)

Sperando di non disturbare la suscettibilità o la commiserazione di chicchessia, mi permetto alcune osservazioni spicciole su tre celebri antinomie (senza pretesa di essere esaustivo né di aver fatto scoperte originali o peggio di non commettere errori).

Premetto che i vari casi mi paiono afflitti da un limite della logica, almeno “normale” (ossia degli Enunciati) quando pretende di considerare il tempo...

ACHILLE E LA TARTARUGA

Considerare unità di tempo piccole a piacere è legittimo, ma non lo è aggiungerne di sempre più piccole concludendo con MAI. Infatti nel primo caso, per quanto piccoli siano gl’intervalli temporali Achille supererà di certo la tartaruga in un numero finito di essi.

IL CRETESE

Non è possibile, per coerenza, che un perfetto mentitore dica “tutto quel che dico è falso”, potrà semmai affermare “tutto quel che dico è vero”. Dopo di che, sospettato ingiustamente di un delitto capitale risponderà sì alla domanda “Sei tu il colpevole?”, senza la soddisfazione di poter affermare, sul patibolo, “Muoio per amore della Menzogna!”. [O forse “Muoio per amore della verità” è un’antinomia? Boh].

IL BARBIERE

L’editto “Il barbiere deve radere tutti quelli che non si fanno la barba da soli” presenta almeno un’ambiguità: è lecito farsi radere da un altro? Immaginiamo che alla specifica richiesta di chiarimento – come sempre accade nelle norme giuridiche o assimilabili che richiedono interpretazioni “autentiche” sullo spirito di una legge – il Sovrano cambi la dizione in “Tutti gli abitanti si debbono radere da soli o farsi radere dal barbiere”, che, senza chiarire esplicitamente che cosa deve fare il barbiere, esclude la possibilità di ricorrere ad altri che non sia il barbiere. A parte il fatto che resta oscura e comunque ardua la possibilità di sanzione, esclusa la fragranza (ma se uno è sbarbato che si fa?), e tralasciando l’ipotesi di un barbiere eunuco o femmina, il punto a mio avviso è che il barbiere ha un duplice ruolo: cittadino e funzionario-barbitonsore (senza essere schizofrenico: tutti hanno ruoli molteplici in un consesso sociale). E scegliendo di radersi da solo, come cittadino, subito DOPO toglie a se stesso, cioè al barbiere, il compito di farlo.

CIRCUITI LOGICI SEQUENZIALI

Mi permetto di insistere coi Logici puri (che finora non mi hanno dato retta...). I circuiti logici sequenziali (elettronici o, persino, implementati con relè e contatti) hanno un comportamento che varia nel tempo, presentando cioè una isteresi appunto temporale. Ne sono esempi noti anche a chi ne ignora le connessioni (di tipo feedback) i circuiti memoria (come i flip-flop) o gli oscillatori. I tecnici per descriverli e progettarli adottano una particolare – ma semplice nei casi elementari - Algebra booleana, in cui sono in gioco NEGAZIONI delle uscite riportate in input. Ad esempio con un X = not Y ove X e Y sono, rispettivamente l’input e l’output si ottiene sulla carta ma anche di fatto un oscillatore di periodo pari al tempo che separa Y e X.

Dunque “in natura” le antinomie sono di fatto risolte. O no?

Buon 2010 !

P.S. – Aggiungo che l’astrattezza della logica rispetto alla lebenswelt (mondo della vita) si fa sentire anche in altri contesti ove siano in gioco verbi riflessivi. Provare per ridere, con “sputarsi” o, peggio, con “masturbarsi”. O, in genere, con verbi che ammettono solo forma riflessiva...

?>

posted @ 17.58 | Feedback (0)

Nasce Wpfitalia, dedicato alla nuova tecnologia WPF

Nasce Wpfitalia.it, dedicato all’affascinante tecnologia WPF

Dedicare un intero sito a una particolare tecnologia del vasto mondo Visual Studio .NET è senz’altro una scommessa. La compie con una certa dose di temerarietà un gruppo di amici Renato Marzaro, Antonio Catucci e Alessandro Del Sole, noto MVP Microsoft autore di molti libri su vari ambienti .NET (in particolare su LINQ, altra tecnologia emergente di Microsoft per accesso “dichiarativo” in stile SQL-like alle più varie fonti dati, relazionali o XML) nonché animatore e leader del popolare sito Visual Basic Tips & Tricks (www.visual-basic.it ).

Anche il neonato www.wpfitalia.it ne è figlio, tant’è vero che il suo nome esteso è guarda caso WPF Italia Tips & Tricks, e nasce per così dire con la camicia, ricco come si presenta da subito di chiari articoli e video dedicati.

WPF in due parole

WPF ovvero Windows Presentation Foundation è una speciale tecnologia creata da Microsoft, che in soldoni consente di implementare l’equivalente multimediale delle classiche finestre di dialogo (Windows Form) che a regime rischiano l’obsolescenza a vantaggio del nuovo WPF, dato il suo aspetto decisamente più accattivante esteticamente e, a un tempo, più agevole da personalizzare.

Prima di illustrarne i caratteri salienti va detto che non si tratta di una novità assoluta, visto che WPF è già supportato in Visual Studio 2008. Il fatto è che il mercato come spesso capita con le novità rivoluzionarie non ha fin qui aderito come merita al nuovo verbo. Ma – assicura lo scommettitore Alessandro – vi sono segnali incoraggianti di un interesse crescente, inoltre l’imminente versione 2010 ha potenziato in modo significativo WPF (con riferimento anche all’ultimo sistema operativo Windows 7).

Tornando a bomba, con WPF si possono creare applicazioni dall'interfaccia grafica avanzata, con utilizzo efficace e, insieme, relativamente semplice di ogni tipo di componenti multimediali: immagini anche 3D, grafica business, animazioni a iosa.

Le applicazioni ottenibili sono di ogni genere, sia gestionali (trattamento di dati o documenti), che di intrattenimento. La base è data dalle librerie grafiche DirectX di Microsoft, incluse la grafica 3D e la grafica vettoriale nonché molte innovazioni specifiche di Windows Vista e Windows 7.

Primi passi in WPF. Il linguaggio XAML

Entrare nel nuovo mondo è immediato. Come al solito, basta nell’IDE Visual Studio dare un clic sull’icona specifica Applicazione WPF per rendersi subito conto della novità architetturale più rilevante:

Figura 1

Sono subito evidenti due parti. Si tratta, in verità, di due finestre distinte che per default sono esibite sovrapposte, data la loro stretta correlazione. Nella prima, che corrisponde grossomodo a una normale Windows Form, si possono inserire persino controlli tradizionali ma anche, e più vantaggiosamente, elementi moderni di tipo multimediale anche spinto. Agli uni e agli altri si possono associare routine d’evento tradizionali (più o meno? Scopritelo gente...) come Click, DoubleClick e quant’altro.

Più rilevante, concettualmente, la parte inferiore. Scritta nel nuovo linguaggio di markup XAML (eXtensible Application Markup Language), un derivato dello standard XML creato interamente da Microsoft, permette di descrivere nei minimi dettagli l’aspetto della finestra soprastante, inclusi i vari oggetti incorporati e altri aspetti come una griglia che ne definisce la suddivisione.

Detto en passant, si fa apprezzare una particolare, razionale struttura “a stack” dei vari componenti.

L’idea alla base corrisponde appieno al moderno principio di separare l’aspetto descrittivo da quello esecutivo, affidando il lavoro almeno nei casi più avanzati a due attori distinti: il designer e l’informatico. Anche il secondo, che ha l’esclusiva del codice, nelle situazioni ordinarie può disporre di nuovi strumenti che passa il convento .NET (a partire da un efficace intellisense nella sezione XAML e non solo) mentre il “creativo” può lavorare con più variegati tool artistici.

Come si comprende è un salto di qualità rispetto al modus operandi con le Windows Form, ove tutto è affidato allo sviluppatore tramite codice, anche per quanto riguarda gli aspetti grafici. I più bravi, e pazienti!, se la cavano con grande fatica, ma la maggioranza produce finestre alquanto grigie se non anonime.

La figura seguente (tratta, come la precedente dal primo tutorial su Wpfitalia di A. Del Sole) illustra un primo frutto semplice ma eloquente delle potenzialità di WPF, ottenuto da Alessandro con pochi clic.

Figura 2

Ma risultati davvero eclatanti si possono ottenere con questa tecnologia. Per averne un’idea si provi ad accedere alla British Library on-line

http://ttpdownload.bl.uk/app_files/xbap/BrowserApp.xbap

che la sfrutta davvero efficacemente, come mostra la figura che da lì abbiamo rubato:

Figura 3

Ma questa è solo una recensione, pertanto ci fermiamo qui. D’altronde gl’interessati all’approfondimento non hanno che da visitare Wpfitalia.it ove i contributi tutoriali abbondano fin d’ora (e anche su MSDN sono tutt’altro che scarsi).

Interessante infine, per i visitatori di Shareoffice che se ne occupano, il fatto che anche nelle applicazioni VSTO (Visual Studio Tools per Office) è possibile fruire di queste nuove interfacce anziché delle solite Windows Form. Non c’era da dubitarne, comunque segnaliamo due post di A. Del Sole a ciò dedicati:

http://community.visual-basic.it/alessandro/archive/2009/01/12/24583.aspx

http://community.visual-basic.it/alessandro/archive/2008/02/18/22010.aspx

Un utile libro introduttivo

Alessandro del Sole ha svolto opera di pioniere, parlando di WPF in corposi capitoli del seguente manuale, relativo a Visual Studio 2005/2008:

Alessandro Del Sole

PROGRAMMARE CON .NET FRAMEWORK 3.X

Ed. FAG Milano

http://www.fag.it/scheda.aspx?ID=21753

Pensiamo di raccomandarlo a quanti sono desiderosi di intraprendere l’affascinante avventura WPF.

?>

posted @ 12.27 | Feedback (0)

Novità Office 2010 su VBA e Ribbon personalizzabile

ANNUNCIO AI LETTORI CHE NON LO TROVAVANO PIU':

Il libro EXCEL E OFFICE VBA è stato ristampato: http://www.hoepli.it/libro/excel-office-vba.asp?ib=9788820335373&pc=00002200

Novità Office 2010 su VBA e Ribbon personalizzabile

E ahimè perdura il BUG di FileSearch (v. in fondo al post)

Una domanda un po’ angosciante che ci poniamo tutti noi che amiamo le macro è la seguente: il linguaggio VBA verrà mantenuto? La risposta, a quanto ho potuto constatare sulla BETA che ho scaricat, è affermativa, garantendo così la compatibilità con gli attuali modelli dotati di macro. Invece si direbbe dubbia l’idea che il VBA possa essere migliorato e potenziato, magari in accordo col Visual Basic .NET...

In attesa di notizie più precise riferisco qui la curiosa avventura di un beta tester di Office 2010 (inglese), che inizia con una scoperta preoccupante, che però poi termina con un lieto fine. In due parole, il nostro amico dapprima non riesce a trovare la scheda (tab in inglese) relativa alle macro (Sviluppo, in Office 2007, peraltro anch’essa da visualizzare esplicitamente anche nel vecchio mondo) né a zompare nell’Editor Visual Basic con la familiare scorciatoia Alt+F11 [Ma qui il ns. amico si sbaglia! G.G.].

Ma niente paura!, la buona notizia è che ora la barra multifunzione (Ribbon) è personalizzabile con semplici mosse direttamente dal Ribbon stesso, col lieto fine di riscoprire la tab relativa alle macro.

Ed ecco le manovre necessarie:

Clic destro in qualunque punto del Ribbon, che apre varie opzioni come le precedenti Aggiungi alla barra di Accesso rapido, Riduci a icona la barra multifunzione ecc. più la nuova Personalizza la barra mutifunzione (Customize the Ribbon);
Scegliere quest’ultima, che a sua volta apre un elenco che comprende tutte le tab standar e pulsanti vari tra cui quelli per Aggiungere una nuova Tab, Aggiungere un nuovo Gruppo, Rinominare;
Le tab vecchie e nuove sono raffigurate in modo gerarchico (arborescente con icone “+“, cliccando sulle quali si aprono altri sottomenu relativi ai singoli comandi;
In particolare l’opzione che più interessa l’autore (e molti di noi) è Sviluppo (Developer).

Scegliendolo si ottiene, perlomeno in prima battuta, la visualizzazione della scheda Sviluppo solo un po’ diversa da quella attuale.

A questo punto qualcuno dirà “niente di nuovo sotto il sole Office...”. Così descritta la storia infatti rassomiglia molto a quella che si vive in Office 2007, agendo nelle Opzioni di Word o di Excel > Personalizzazioni... per cui la novità sembra consistere solo nella comodità del clic destro direttamente sul Ribbon. Non mi sbilancio del tutto, ma sono propenso a scommettere che si tratti di inedite possibilità di modifica in precedenza scomode se non impossibili.

La questione si può dirimere dal vivo, per farsene un’idea diretta, sulla beta di Office 2010 pro, scaricabile dai link seguenti, entrambi finora relativi all'edizione inglese:

www.microsoft.com/office/2010/en/default.aspx

www.microsoft.com/italy/office2010/index.aspx

Aggiungo ora una MIA impressione iniziale sulla beta testè caricata. Il layout del Ribbon è un po' cambiato, direi razionalizzato. In particolare l'icona Office è sparita e al suo posto si ha un (più classico) menu File. Per il resto, i comandi sembrano identici anche se a volte diversamente dislocati e raffigurati. Anche nel resto non si riscontrano innovazioni, a parte un accresciuto numero di librerie in VBA (quelle attivabili con Strumenti > Riferimenti...) quelle che, diciamolo francamente, solo utenti ultraesperti adottano. Le opzioni classiche sembrerebbero immutate - tabelle, font, cornici, forme e clipArt, classi e numero di funzioni - tutto (o quasi?) come prima...

Ma è presto per parlare di delusione, anzi penso di sbagliare.

IL PERDURANTE BUG DI FILESEARCH

L'ho subito segnalato su http://connect.microsoft.com scoprendo di averlo già fatto un paio di anni fa (ve n'è traccia su tale sito, con risposte che rimandano la palla a un altro team...). Non è successo nulla, visto che tale bug rimane pure in Office 2010. Ma ecco di che si tratta:

L’utile comando VBA Application.FileSearch per la ricerca di archivi, presente in Office 2003, è scomparso in Office 2007 e 2010 (beta). Con aspetti imbarazzanti se non grotteschi:

- Se si digita “Application.” “FileSearch” non compare nella lista dell’intelliusense;

- se si insiste con Application.FileSearch e relativi metodi/proprietà tutto sembra accettato ma a run-time si ha ERRORE, pertanto FileSearch non si può utilizzare e falliscono precedenti modelli creati con Office 2003.

Ecco un esempio del genere:

Sub Cercafiles()

cartella = Range("A1").Value

nome = Range("B1").Value

este = Range("C1").Value

Dim nomefile As String

With Application.FileSearch

.NewSearch

.LookIn = cartella & ""

.SearchSubFolders = True

.Filename = "" & nome & "." & este & ""

If .Execute(SortBy:=msoSortByFileName, _

SortOrder:=msoSortOrderAscending) > 0 Then

MsgBox "Ci sono " & .FoundFiles.Count & " file(s) trovati."

For i = 1 To .FoundFiles.Count

nomefile = .FoundFiles(I)

ActiveCell(i) = nomefile

Next i

Else

MsgBox "File(s) non trovato."

End If

End With

End Sub

Utile, no? Però funziona solo con Office 2003.

La cosa imbarazzante...

... se non ridicola è che non solo tutte le keyword predette vengono regolarmente tradotte con le maiuscole al posto giusto (es. “fiLesEArCH” => “FileSearch”, “neWseaRCh” => “NewSearch”) ma la Guida riporta una gran copia di esempi specifici, NESSUNO dei quali funziona, dopo Office 2003.

L’utile comando VBA Application.FileSearch per la ricerca di archivi, presente in Office 2003, è scomparso in Office 2007 e 2010 (beta). Con aspetti imbarazzanti se non grotteschi:

- Se si digita “Application.” “FileSearch” non compare nella lista dell’intelliusense;

- se si insiste con Application.FileSearch e relativi metodi/proprietà tutto sembra accettato ma a run-time si ha ERRORE, pertanto FileSearch non si può utilizzare e falliscono precedenti modelli creati con Office 2003.

Ecco un esempio del genere:

Sub Cercafiles()

cartella = Range("A1").Value

nome = Range("B1").Value

este = Range("C1").Value

Dim nomefile As String

With Application.FileSearch

.NewSearch

.LookIn = cartella & ""

.SearchSubFolders = True

.Filename = "" & nome & "." & este & ""

If .Execute(SortBy:=msoSortByFileName, _

SortOrder:=msoSortOrderAscending) > 0 Then

MsgBox "Ci sono " & .FoundFiles.Count & " file(s) trovati."

For i = 1 To .FoundFiles.Count

nomefile = .FoundFiles(I)

ActiveCell(i) = nomefile

Next i

Else

MsgBox "File(s) non trovato."

End If

End With

End Sub

Utile, no? Però funziona solo con Office 2003.

La cosa imbarazzante...

... se non ridicola è che non solo tutte le keyword predette vengono regolarmente tradotte con le maiuscole al posto giusto (es. “fiLesEArCH” => “FileSearch”, “neWseaRCh” => “NewSearch”) ma la Guida riporta una gran copia di esempi specifici, NESSUNO dei quali funziona, dopo Office 2003.

?>

posted @ 14.15 | Feedback (0)

Input condizionato, con e senza macro

N.B. Da www.microsoft.com/office/2010/en/default.aspx oppure www.microsoft.com/italy/office2010/index.aspx si può scaricare la beta di Office 2010 (professionale), sempre in edizione inglese.

Input condizionato, con e senza macro

L’adozione in un intervallo ad hoc di un foglio di lavoro Excel per l’immissione di dati può essere interessante, specie se tali valori sono molti e li si vuole assoggettare a successive elaborazioni. Un’esigenza che in tali casi sovente si presenta è l’aderenza dell’input a determinate condizioni. Facile a dirsi e anche a farsi, con opportuno codice macro, ma un tale, al riguardo, mi ha espresso il timore che l’utente finale, succube del terrorismo contro i macro virus possa aver disabilitato le macro.

Per farla breve, ho studiato il problema sviluppando il modellino esemplificativo seguente, ove Zalva vuol raffigurare un pulsante ActiveX.

	A	B	C	D	E	F	G
1	Zona input:
2	5	2	7	<== immettere valori tra 5 e 10 (compresi)
3	3	8	10	(Valori fuori limiti: celle BIANCHE)
4	6	4	9
5	7	5	11
6
7	Zona verifica:				Salva
8	VERO	FALSO	VERO
9	FALSO	VERO	VERO		Num. input OK:
10	VERO	FALSO	VERO		8
11	VERO	VERO	FALSO		4 celle fuori limiti!
12
13
14

Lo si può scaricare dal link seguente:

http://www.giannigiaccaglini.it/download/ZonaInputCondizionata.xls

Si sappia inoltre che vanno assegnati i nomi di zona seguenti (tra parentesi le coordinate):

Zona_Input (A2:C5)

Data_Salva (E6, celata da pulsante Salva)

Nota. È poi opportuno che le celle di Zona_Input non siano bloccate, ricordandosi di fissare la protezione del foglio. In tal modo l’end user può operare solo nell’intervallo dedicato (che potrebbe essere una maschera di celle anche non contigue).

Soluzioni senza macro VBA

La cosa che sarà subito venuta in mente a molti è l’adozione della formattazione condizionale, le cui manovre do per note. Nel modellino, per estrema semplicità, ho previsto la condizione TRA, con minimo e massimo pari a 5 e 10 inclusi. Di conseguenza le celle OK si colorano automaticamente. Se l’utente non è del tutto sprovveduto dovrebbe bastare. Comunque per i palati più esigenti ho previsto l’intervallo A8:C11 sottostante Zona_Input, contenente formule booleane di cui riporto solo quella nella cella d’angolo A8:

=E(A2>=5;A2<=10)

Nota. Ricordo ai principianti che scritta tale formula in A8 si può inserirla, previa selezione di A8:C11 premendo Ctrl+Invio simultaneamente.

Tali formule creano dei valori logici VERO in tutte e sole le celle “gemelle “ di quelle in Zona_Input che soddisfano la predetta condizione. A questo punto non resta che esaminare le formule seguenti, che recano a sinistra del segno = l’indirizzo della cella di appartenenza:

E10=CONTA.SE(A8:C11;VERO)

E11=SE(E10=CONTA.VALORI(A8:C11);"Tutte celle OK";(CONTA.VALORI(A8:C11)-E10)&" celle fuori limiti!")

Come spero sia a tutti chiaro, la prima dà il numero di input corretti, la seconda messaggi alternativi di limpida semantica.

Soluzione VBA

Il clou consiste nella routine seguente, relativa all’evento BeforeSave che si scatena prima del salvataggio della cartella di lavoro, comunque effettuato, tramite il pulsante Salva o a mano. È ospitata nel modulo ThisWorkbook:

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

Dim c As Range

For Each c In Foglio1.Range("Zona_Input")

'If c.Interior.ColorIndex = 3 Then ' NON VA!!!

If c < 5 Or c > 10 Then

MsgBox "Valori fuori limiti!"

Cancel = True

Exit Sub

End If

End Sub

Commenti ultrarapidi.

C’è poco da dire, almeno a chi mastica un poco il VBA, dico solo a chi non lo sapesse che l’argomento booleano Cancel, per default uguale a False, con Cancel = True inibisce il salvataggio. Quando invece l’utente si comporta bene Range(“Data_Salva”) = Date inserisce nella cella denominata Data_Salva la data corrente. Tale finezza (non del tutto perfetta, a dirla tutta) mira a permettere ad un eventuale controllore di constatare se il VBA è stato o meno disabilitato. Nel qual caso Data_Salva dovrebbe essere vuota. Chiaro?

Nota. Come si constaterà, in fase di modifica, anche del VBA la Sub dell’evento BeforeSave impedisce il salvataggio se la zona di input non è corretta. In tali casi, volendo salvare la miglioria, è giocoforza disabilitare il VBA.

Dimenticavo una cosa, che però non sorprenderà nessuno. Al pulsante Salva è abbinata questa macro:

Private Sub btnSalva_Click()

ThisWorkbook.Save

End Sub

Infine si potrebbe agire anche sull’evento Close, comunque si constata che la pur noiosa domanda “Salvare le modifiche?...” è di fatto ininfluente ai nostri scopi.

?>

posted @ 13.53 | Feedback (0)

Un alibi (quasi?) perfetto con una macro Word [ + una chicca Excel su Fibonacci/Sezione aurea ]

Un alibi (quasi?) perfetto con una macro Word [ + una chicca Excel ]

Questa ipotesi audace trae ispirazione da un noto caso giudiziario attuale, ove i periti, informatici, hanno scagionato l’indagato avendo constatato che un documento al quale stava lavorando risultava ripetutamente salvato nel periodo in cui il crimine fu perpetrato.

La mia opinione è che tale perizia costituisca un alibi inoppugnabile... E tuttavia, lavorando di fantasia, ipotizzo una possibilità alternativa, beninteso da parte di una mente diabolica-ma-non-troppo. Dicendo “ma-non-troppo” ho in mente l’ideatore di un delitto perfetto o quasi basato sulla macro VBA seguente, incorporata nel documento .doc in questione:

Sub Alibi()

' k = 1 'Usato per debug

While True

MsgBox "Passaggio numero " & k 'Usato per debug

' k = k + 1 'Usato per debug

With Selection.Find

.Text = "Rossini"

.Replacement.Text = "####"

.Execute Replace:=wdReplaceAll

End With

' Pausa... (soluzione rudimentale)

' For i = 1 To 200000000

' Next

Attesa t:=Rnd * 50 ' In fase debug: 10 o 5

With Selection.Find

.Text = "####"

.Replacement.Text = "Rossini"

.Execute Replace:=wdReplaceAll

End With

ThisDocument.Save

Wend

End Sub

Sub Attesa(t As Double)

Dim QuestiSec As Double

QuestiSec = Timer

While Timer < QuestiSec + t

Wend

End Sub

Tale macro per ipotesi lavora in un documento che inizia come segue:

Tesi con alibi

By Gioacchino Rossini

ecc. ecc.

Inizialmente ho previsto 4 passaggi (con indice k), ciascuno composto di due fasi che prevedono la sostituzione di “Rossini” con 4 cancelletti e, rispettivamente, il ripristino di “Rossini”, quindi il salvataggio del file (di fatto immutato, ma – si badi bene – non credo che ciò non lasci traccia). Ogni ciclo di indice k termina con una pausa rozzamente emulata con un i che varia da 1 a 200000000.

Successivamente ho sostituito il (rozzo) ciclo di indice k con un loop senza fine While True... Wend inserendo un ritardo di durata casuale che sfrutta la routine Attesa a sua volta basata sul codice Timer. In tal modo si evita che i periti si insospettiscano constatando salvataggi a periodi fissi.

La macro non merita altri commenti se non quelli inseriti, comunque funziona. L’ipotetico criminale per sfruttarla dovrebbe:

1. Lanciarla prima di uscire;

2. Compiere la nefandezza (non cruenta, si spera!);

3. Tornare a casa;

4. Bloccare la macro con Ctrl+Break;

5. Eliminarla (!!!);

6. Proseguire con modifiche e salvataggi manuali per un tempo adeguato.

Un amico cui ho sottoposto la cosa mi ha obiettato che forse cancellando la macro, ne resterebbe traccia, chiedendomi se c'e un modo per far girare la macro su chiavetta USB.

Ecco cosa gli ho risposto:

Sulla seconda ipotesi non ho al momento elementi (ci penserò); comunque, ripeto, la macro fa parte del documento ma si trova nell'Editor Visual Basic, inoltre non penso che le tracce sul disco contengano le versioni integrali precedenti ma solo, appunto, tracce sintetiche del documento (che ovviamente è salvato come .doc in conformità all'ultimo salvataggio effettuato). Se ora, al ritorno dal delitto il delinquente non solo elimina la macro nell'Editor VBA ma compie ripetuti salvataggi a mano del documento, è perlomeno difficile che periti non dotati di qualità extrasensoriali possano recuperare il codice criminale...

Se qualcuno s’intende di tracce si faccia vivo.

La chicca per Excel (un modellino didattico)

Tutti o quasi conoscono la serie dei conigli immortali dell’estroso matematico pisano Fibonacci, perciò mi limito a ricordare che partendo con una coppia di ... conigli, pardon!, numeri 1 e 1 ogni successivo numero si ricava sommando i due precedenti. Ottenerla con formule su un foglio elettronico è un gioco da ragazzi.

Forse però non tutti sanno che dividendo ciascun membro della serie per il successivo si ottiene un’approssimazione sempre più precisa della sezione aura, un numero “magico” che a sua volta ricorre in molti campi (v. Wikipedia) espresso dalla formula che do senz’altro in stile excelliano:

=(RADQ(5)-1)/2

In soldoni, limitandosi alle cifre significative che Excel fornisce, trattasi di
0,618033988749895

Nel modellino didattico che propongo si scelgano due celle a piacere ma diciamo in cima alle colonne D ed E denominandole SezioneAura e, rispettivamente, Epsilon. Va da sé che la prima conterrà la formula o il valore omonimi, mentre nella seconda ospiterà un numero molto piccolo, diciamo 0,00000000001 (stiamo sempre, per forza di cose, nei limiti imposti da Excel).

Ciò fatto, inseriamo nelle colonne A, B e C formulette opportune, ottenendo risultati del genere seguente:

A

B

C

1

1

2

1

3

2

0,5

FALSO

4

3

0,666666667

FALSO

5

5

0,6

FALSO

6

8

0,625

FALSO

7

13

0,615384615

FALSO

8

21

0,619047619

FALSO

9

34

0,617647059

FALSO

10

55

0,618181818

FALSO

11

89

0,617977528

FALSO

12

144

0,618055556

FALSO

13

233

0,618025751

FALSO

14

377

0,618037135

FALSO

15

610

0,618032787

FALSO

16

987

0,618034448

FALSO

17

1597

0,618033813

FALSO

18

2584

0,618034056

FALSO

19

4181

0,618033963

FALSO

20

6765

0,618033999

FALSO

21

10946

0,618033985

FALSO

22

17711

0,61803399

FALSO

23

28657

0,618033988

FALSO

24

46368

0,618033989

FALSO

Le formule nelle prime due colonne, ovviamente da introdurre a partire dalla riga 3 sono a questo punto scontate, comunque fornisco la prima coppia, che va more solito ricopiata verso il basso:

A3: =A1+A2

B3: =A2/A3

E la formula che parte in C3? I più accorti se ne saranno... accorti da soli. Ad ogni buon conto mi voglio rovinare, offrendo le prime tre:

C3: =ASS(B3-SezioneAura) <=Epsilon

C4: =ASS(B4-SezioneAura) <=Epsilon

C5: =ASS(B5-SezioneAura) <=Epsilon

Palesemente, danno una sfilza di valori logici FALSO nelle prime 27 celle, ma a partire dalla 28.ma comincia a spuntare il sospirato VERO:

A

B

C

24

46368

0,618033989

FALSO

25

75025

0,618033989

FALSO

26

121393

0,618033989

FALSO

27

196418

0,618033989

FALSO

28

317811

0,618033989

VERO

29

514229

0,618033989

VERO

30

832040

0,618033989

VERO

Formattazione condizionale

Sicuramente tutti avranno notato gli sfondi colorati che evidenziano viepiù l’agognato raggiungimento dell’approssimazione della dorata sezione. Sono stati ottenuti sfruttando la formattazione indicata nel titolo. Lascio per esercizio l’impostazione de formato condizionato di colonna C, mentre descrivo i passi per ottenere quella in colonna B.

1. Selezionare l’intero intervallo, diciamo C3:C40 (ex abundantia);

2. Attivare il comando Formattazione condizionali;

3. Opzione Nuova regola poi Utilizza una formula;

4. Nella susseguente casella ad hoc inserire la seguente formula:
=ASS($B3-$D$2)<=$E$2

5. Meditare, gente...

?>

posted @ 15.10 | Feedback (0)

Ricerca filtrata di mail: richiesta di aiuto...

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

?>

posted @ 17.44 | Feedback (0)

	A	B	C
1	1
2	1
3	2	0,5	FALSO
4	3	0,666666667	FALSO
5	5	0,6	FALSO
6	8	0,625	FALSO
7	13	0,615384615	FALSO
8	21	0,619047619	FALSO
9	34	0,617647059	FALSO
10	55	0,618181818	FALSO
11	89	0,617977528	FALSO
12	144	0,618055556	FALSO
13	233	0,618025751	FALSO
14	377	0,618037135	FALSO
15	610	0,618032787	FALSO
16	987	0,618034448	FALSO
17	1597	0,618033813	FALSO
18	2584	0,618034056	FALSO
19	4181	0,618033963	FALSO
20	6765	0,618033999	FALSO
21	10946	0,618033985	FALSO
22	17711	0,61803399	FALSO
23	28657	0,618033988	FALSO
24	46368	0,618033989	FALSO

My Links

News

Categorie Post

Categorie Articoli

Archivio

Immagini

Blog Stats

Personal encryption / Crittografia personale

How use it

Two word about algorytms I used

LEGGETE ANCHE GLI ARTICOLI!!! L’ultimo al link: http://blog.shareoffice.it/giannigiaccaglini/articles/10324.aspx

LEGGETE ANCHE GLI ARTICOLI!!! L’ultimo al link:

I bachi inattesi? Colpa della Semantica, signori miei...

Il frivolo esempio: ruotine eliminare cifre da una stringa

Visual Studio 2008: mondo nuovo, altra sorpresa

Il Ribbon personalizzabile di Office 2010

Crittografia di fogli Excel: un bug sanato

Dov’era il bug

Nasce Wpfitalia.it, dedicato all’affascinante tecnologia WPF

WPF in due parole

Primi passi in WPF. Il linguaggio XAML

Un utile libro introduttivo

ANNUNCIO AI LETTORI CHE NON LO TROVAVANO PIU':

Il libro EXCEL E OFFICE VBA è stato ristampato: http://www.hoepli.it/libro/excel-office-vba.asp?ib=9788820335373&pc=00002200

Novità Office 2010 su VBA e Ribbon personalizzabile

N.B. Da www.microsoft.com/office/2010/en/default.aspx oppure www.microsoft.com/italy/office2010/index.aspx si può scaricare la beta di Office 2010 (professionale), sempre in edizione inglese. Input condizionato, con e senza macro

Soluzioni senza macro VBA

Soluzione VBA

Un alibi (quasi?) perfetto con una macro Word [ + una chicca Excel ]

Tesi con alibi

La chicca per Excel (un modellino didattico)

Formattazione condizionale

Ricerca filtrata di mail: richiesta a chi-sa-parli

LEGGETE ANCHE GLI ARTICOLI!!! L’ultimo al link:

http://blog.shareoffice.it/giannigiaccaglini/articles/10324.aspx

N.B. Da www.microsoft.com/office/2010/en/default.aspx oppure www.microsoft.com/italy/office2010/index.aspx si può scaricare la beta di Office 2010 (professionale), sempre in edizione inglese.

Input condizionato, con e senza macro