Export d'un champ RichText en fichier RTF

[pandemonium]

Bonjour,

Je dois exporter un champ RichText en fichier RTF avez vous de la documentation là dessus ? Je ne trouve absolument rien et c'est un problème bloquant.

[amahi]

http://www.openntf.org/blogs/openntf.ns ... HEF-8U4B2X

[Fab2b]

Si tu n'est pas en XPages...

Un agent utilisé il ya qques années en partant d'une class récupérée sur le Web. De mémoire, export du body et du nom des PJ d'un mail dans un fichier RTF. Lancement du traitement à partir du "Memo" via un bouton. Le fichier RTF est formatté pour être réimporté ensuite dans un AS400. Je ne suis pas re-rentré dans le code pour te donner plus de détail.... il me semble que ca fonctionnait pas trop mal !!

Code : Tout sélectionner

Option Public
Option Declare
%INCLUDE "lsconst.lss"
Private Const TRAP_ERRORS = True

Public Const ERR_FIRST = 1000
Public Const ERR_LAST = ERR_FIRST + 2999
Public Const ERR_BASE_DB = ERR_FIRST ' Base code for database-specific errors
Public Const ERR_BASE_LS = ERR_FIRST + 1000' Base code for shared library errors.
Public Const ERR_ERROR = ERR_BASE_LS ' General error code.
Public Const ERR_NICE = ERR_LAST ' Causes an error handler such as ShowError to treat the error as a message.

Declare Function W32_ExportRTF Lib "NXRTF" Alias "ExportRTF" (Byval sTempFile As String, Byval flags As Long, hmod As Long, Byval altlibrary As String, Byval sRTFFile As String) As Integer
Declare Function W32_MailGetMessageBodyComposite Lib "NNOTES" Alias "MailGetMessageBodyComposite" (Byval hNT As Long, Byval N As String, Byval D As String, nD As Long) As Integer
Declare Function W32_GetTempPath Lib "KERNEL32" Alias "GetTempPathA" (Byval nBufferLength As Long, Byval lpBuffer As String) As Long
Declare Function W32_GetLongPathName Lib "KERNEL32" Alias "GetLongPathNameA" (Byval lpszShortPath As String, Byval lpszLongPath As String, Byval cchBuffer As Long) As Long

'Ajout du 22/07/2008
Declare Function ExportRTF Lib "nxrtf" Alias "ExportRTF" (Byval sTempFile As String, Byval    flags As Long, hmod As Long, Byval altlibrary As String, Byval sRTFFile As String) As Integer

'/**
' * base class from which all other classes are derived.
' */

Public Class BaseClass
   
      ' Members
   
   Private mSess As NotesSession ' Handle to the current NotesSession.
   Private mErrorInfo As String ' Additional information added to the error message.
   
      '/**
      ' * Constructor.
      ' */
   
   Public Sub New()
      
      Set mSess = New NotesSession()
      
   End Sub
   
   
      '/**
      ' * Throws an exception back to the caller.
      ' */
   
   Private Sub ThrowError()
      
      Dim arrErrors As Variant
      Dim strError As String
      Dim strMethod As String
      Dim strModule As String
      
            ' If the error code is ERR_NICE, just throw the error.
      If (Err = ERR_NICE) Then Error Err, Error$
      
            ' Field validataion errors cause code to halt but do not raise an error.
      If (Err = 4412) Then End
      
            ' Build the error message.
      strModule = Typename(Me) & mErrorInfo
      mErrorInfo = ""
      If (strModule <> "") Then strModule = strModule & "."
      strMethod = Getthreadinfo(LSI_THREAD_CALLPROC)
      strError = Error$
      If (Not StrContains(strError, StrNewline(1), True)) Then
         arrErrors = ArrayAdd(arrErrors, strError & " (" & Cstr(Err) & ")")
      Else
         arrErrors = StrExplode(strError, StrNewline(1))
      End If
      arrErrors = ArrayAdd(arrErrors, " on line " & Cstr(Erl) & " in " & strModule & strMethod)
      
            ' Print the error message.
      If (Not mSess.IsOnserver) Then Print arrErrors(0) & arrErrors(Ubound(arrErrors))
      
            ' Throw the error back to the calling proceedure.
      Error Err, ArrayImplode(arrErrors, StrNewline(1))
      
   End Sub
   
   
End Class


'/**
' * Exports rich test to a rich text file.
' */

Public Class RichTextExporter As BaseClass
   
      ' Members.
   
   Private mDocument As NotesDocument
   Private mItemName As String
   Private mIncludeAttachments As Boolean
   
   
      '/**
      ' * Gets or sets the IncludeAttachments option.
      ' */
   
   Public Property Get IncludeAttachments As Boolean
      
      IncludeAttachments = mIncludeAttachments
      
   End Property
   
   Public Property Set IncludeAttachments As Boolean
      
      mIncludeAttachments = IncludeAttachments
      
   End Property
   
   
      '/**
      ' * Attaches the class to an item or document.
      ' * <p></p>
      ' * If the class is attached to an item, the item is exported.  If the class is attached to a document, the entire document is exported.
      ' * @param source A handle to a NotesItem, NotesRichTextItem, or NotesDocument.
      ' */
   
   Public Sub Attach(source As Variant)
      
      If (TRAP_ERRORS) Then On Error Goto CATCH
      Select Case Typename(source)
         
      Case "NOTESITEM","NOTESRICHTEXTITEM"
         
                  ' Attach the exporter to the item.
         Set mDocument = source.Parent
         mItemName = source.Name
         
      Case "NOTESDOCUMENT"
         
                  ' Render the document to a temp item and attach the class to the temp item.
         Dim docTemp As NotesDocument
         Set docTemp = source.ParentDatabase.CreateDocument
         Set mDocument = docTemp
         
         Dim itmTemp As New NotesRichTextItem(docTemp, "tmp")
         Call source.RenderToRTItem(itmTemp)
         mItemName = itmTemp.Name
         
      Case Else
         
         Error 2000, "Source is not a valid object type."
         
      End Select
      Exit Sub
      
CATCH:
      
      On Error Goto THROW
      
THROW:
      
      Call Me.ThrowError()
      
   End Sub
   
      '/**
      ' * Exports to Rich text format.
      ' * @param filePath The full path to the destination file.
      ' */
   
   Public Sub Export(Byval filePath As String)
      
      Dim folderName As String
      Dim cdPath As String
      Dim dirSep As String
      
            ' Init
      If (TRAP_ERRORS) Then On Error Goto CATCH
      
            ' Ensure the destination folder exists,
      dirSep = StrDirSep("")
      folderName = Trim(Strleftback(filePath, dirSep)) & dirSep
      Call CreateDirectory(folderName)
      
            ' Export to a cd file.
      cdPath = Me.GetTempFileName()
      Call Me.ExportToCd(cdPath)
      
            ' Convert to an rtf file.
      'Call W32_ExportRTF(cdPath, 0, 0, "", filePath)
      Call ExportRTF(cdPath, 0, 0, "", filePath)
      
            ' Remove the temp file.
      Kill cdPath
      
            ' Export file attachments.
      If (mIncludeAttachments) Then
         
                  ' Extract any files.
         If (mDocument.HasEmbedded) Then
            
                        ' Export each file.
            Dim fileItem As NotesRichTextItem
            Set fileItem = mDocument.GetFirstItem(mItemName)
            On Error Resume Next
            Forall fileObject In fileItem.EmbeddedObjects
               Call fileObject.ExtractFile(folderName & fileObject.Name)
            End Forall
            On Error Goto 0
            
         End If
         
      End If
      Exit Sub
      
CATCH:
      
      On Error Goto THROW
      
THROW:
      
      Call Me.ThrowError()
      
   End Sub
   
      '/**
      ' * Exports to common data format.
      ' * @param filePath The full path to the destination file.
      ' */
   
   Private Sub ExportToCd(Byval filePath As String)
      
      Dim fileSize As Long
      Dim contentsPath As String
      Dim fontsPath As String
      
            ' Init
      If (TRAP_ERRORS) Then On Error Goto CATCH
      
            ' Export contents to a temp file.
      contentsPath = Me.GetTempFileName()
      Call W32_MailGetMessageBodyComposite(mDocument.handle , mItemName, contentsPath, fileSize)
      
            ' Export fonts to a temp file.
      fontsPath = Me.GetTempFileName()
      Call W32_MailGetMessageBodyComposite(mDocument.handle , "$Fonts", fontsPath, fileSize)
      
            ' Concatenate the contents and fonts files.
      Call Me.Concatenate (contentsPath, fontsPath, filePath)
      
            ' Remove temp files.
      Kill contentsPath
      Kill fontsPath
      Exit Sub
      
CATCH:
      
      On Error Goto THROW
      
THROW:
      
      Call Me.ThrowError()
      
   End Sub
   
   
      '/**
      ' * Takes two CD record format files and adds them into one file using binary file access.
      ' * @param fileIn1 The full path to the first source file.
      ' * @param fileIn2 The full path to the second source file.
      ' * @param fileOut1 The full path to the destination file.
      ' */
   
   Private Sub Concatenate(Byval fileIn1 As String, Byval fileIn2 As String, Byval fileOut1 As String)
      
           ' Note:  There is always an even number of bytes in CD-records so we can use Integer to transfer
           ' the data. (Function copied from notes.net.)
      
      Dim twoBytes As Integer
      Dim fileIn As Integer
      Dim fileOut As Integer
      
            ' Init
      If (TRAP_ERRORS) Then On Error Goto CATCH
      
            ' Create the destination file.
      fileOut = Freefile
      Open fileOut1 For Binary As #fileOut
      
            ' Write the first source file to the destination.
      fileIn = Freefile
      Open fileIn1 For Binary As #fileIn
      Do Until Eof (fileIn)
         Get #fileIn,,twoBytes
         Put #fileOut,, twoBytes
      Loop
      Close #fileIn
      
            ' Write the second source file to the destination.
      Open fileIn2 For Binary As #fileIn
      Seek #fileIn, 3 ' First two bytes (one word) of file is control character so this is stripped from second file.
      Do Until Eof (fileIn)
         Get #fileIn,,twoBytes
         Put #fileOut,, twoBytes
      Loop
      Close #fileIn
      Close #fileOut
      Exit Sub
      
CATCH:
      
      On Error Goto THROW
      
THROW:
      
      Call Me.ThrowError()
      
   End Sub
   
   
      '/**
       ' * Creates a temporary file name.
        ' */
   
   Private Function GetTempFileName() As String
      
      Dim tempPath As String * 256
      Dim strTempPath As String
      Dim dirSep As String
      
            ' Init
      If (TRAP_ERRORS) Then On Error Goto CATCH
      dirSep = StrDirSep("")
      Call W32_GetTempPath(256, tempPath)
      strTempPath = Left(tempPath, Instr(tempPath, Chr$(0)) - 1)
      strTempPath = GetLongPathName(strTempPath) & "LsFiles" & dirSep
      Call CreateDirectory(strTempPath)
      GetTempFileName = strTempPath & StrUnique(True)
      Exit Function
      
CATCH:
      
      On Error Goto THROW
      
THROW:
      
      Call Me.ThrowError()
      
   End Function
   
End Class


Sub Initialize
   
   'Permet d'exporter auformat RTF un document complet ou bien un champ
   
   Dim ItemBody As NotesRichTextItem   
   Dim Collec As NotesDocumentCollection
   Dim db As NotesDatabase
   
   Dim ws As New NotesUIWorkspace()
   Dim doc As NotesDocument
   
   Dim exporter As New RichTextExporter()   
   Dim session As New notessession   
   
   
   Dim DocMail As NotesDocument
   Dim f As Integer
   Dim NomFichier As String
   Dim NomFichierRTF As String
   
   Dim Expediteur As String
   Dim Destinataire As String
   Dim DestinataireCC As String
   Dim Sujet As String
   
   Dim IdNsf As Variant
   Dim Recu As Variant
   Dim DateHeure As String   
   Dim Hhmmss As String
   Dim Hh As String
   Dim Mn As String
   Dim Ss As String
   Dim Heure As String
   Dim Pjoint As String
   Dim FicRef As String
   
   'Dim ItemBody As NotesRichTextItem
   Dim IDDoc As String
   Dim LecteurReseau As String
   Dim LecteurReseau2 As String
   Dim reference As String
   
   Dim TxtBody As String
   
   On Error Goto Erreur
   
   '**********************************************LECTEUR RESEAU***********************************
   'LecteurReseau = "Y:\"
   'LecteurReseau = "\\theopar1\data\testnotes\"
   
   'Réel ->M =  \extranet\web\@m\
   'L = \extranet\web\upload\notes\
   'LecteurReseau ="M:\"
   'LecteurReseau2 ="L:\"
   
   LecteurReseau ="C:\temp\"
   LecteurReseau2 ="C:\temp\"
   'Pour test
   'LecteurReseau = "D:\notes\"
   'Si DetachFile vers un autre répertoire
   'LecteurReseau2 = "D:\notes_c\"
   '**********************************************LECTEUR RESEAU***********************************
   
   Set Db = Session.currentdatabase
   
   Dim workspace As New NotesUIWorkspace
   Dim DocUI As NotesUIDocument
   
   Set DocUI = workspace.CurrentDocument   
   
   Set DocMail = DocUI.Document
   
   If Not DocMail Is Nothing Then
      
      Reference = Inputbox( "Client=6 chiffres/Police=20 caractères maxi/Sinistre=10 caractères", "Veuillez saisir un N° de client OU un N° de police OU un N° sinistre","")
      If reference = "" Or Len(Reference) > 23 Then
         Msgbox "La saisie du N° de Client/Police/Sinistre est obligatoire et ne doit pas dépasser les références de Gestassur", 16+0, "Arret de l'opération"
         Exit Sub
      End If
      
      'Recup des infos du mail
      IdDoc = DocMail.UniversalID
      Expediteur = DocMail.From(0)
      'DestinataireCC = DocMail.CopyTo(0)
      'Destinataire = DocMail.SendTo(0)
      
      'Ajout FSI - 2008-06-30
      Dim ItemDest As NotesItem
      Set ItemDest = DocMail.GetFirstItem("SendTo")
      If Not ItemDest Is Nothing Then
         Forall V In ItemDest.values
            Destinataire = Destinataire + V +","
         End Forall
      End If
      
      Dim ItemDestCC As NotesItem
      Set ItemDestCC = DocMail.GetFirstItem("CopyTo")
      If Not ItemDestCC Is Nothing Then
         Forall V In ItemDestCC.values
            DestinataireCC = DestinataireCC + V + ","
         End Forall
      End If
      'Ajout FSI - 2008-06-30
      
      Sujet = DocMail.Subject(0)
      Recu = DocMail.Created
      IdNsf=db.filename
      Set ItemBody = DocMail.GetFirstItem("Body")
      TxtBody = ItemBody.Text
      
      DateHeure=Date$()+"_"+Time$()
      Hhmmss=Time$()
      Hh=Left$(Hhmmss,2)
      Mn=Right$(Left$(Hhmmss,5),2)
      Ss=Right$(Left$(Hhmmss,8),2)
      Heure=Hh+Mn+Ss
      
      'Le nom du fichier
      'NomFichier = LecteurReseau + IdDoc+ reference+".txt"
      'NomFichierRTF = LecteurReseau + IdDoc+ reference+".rtf"
      NomFichier = LecteurReseau + reference+Heure+".txt"
      NomFichierRTF = LecteurReseau + reference+Heure+".rtf"
      
      'Detachement des PJ
      Call DetachePj(DocMail,LecteurReseau2+reference+Heure,Pjoint)         
      
      f = Freefile()
      
      Open NomFichier For Output As f
      
      Dim cpteur As Integer
      cpteur = 7
      
      'Les 4 premeieres lignes, l'expediteur, le destinataire, le sujet
      Print #f, IdDoc + reference + "|1" + Expediteur +"|"
      Print #f, IdDoc + reference + "|2" + Destinataire +"|"
      Print #f, IdDoc + reference + "|3" + DestinataireCC +"|"
      Print #f, IdDoc + reference + "|4" + Sujet +"|"
      Print #f, IdDoc + reference + "|5" + Recu +"|"
      Print #f, IdDoc + reference + "|6" + Pjoint +"|"
      
      Close f%
      
      Call exporter.Attach(ItemBody) ' You can also attach to a NotesRichTextItem to export a single field!
      Call exporter.Export(NomFichierRTF)
      
      'Ecriture dans fichier , la  reference exportée
      FicRef = LecteurReseau + "Reference.txt"
      f = Freefile()      
      Open FicRef For Append As f
      Print #f, reference + Heure + "|" + IdNsf + "|" + IdDoc + "|" + DateHeure
      Close f%
      
   End If
   
   'docMail.subject = docMail.subject(0) + " "
   'Call docMail.save(True,True,False)
   
   
   Exit Sub
   
   
Erreur:
   Messagebox "----------------------- Erreur Agen ExportAS400RTF" & Str(Err) & ": " & Error$ & "Ligne " & Erl
   
   Exit Sub
   
   
   
   
End Sub
Public Function StrUnique(createKey As Integer) As String
   
      '/**
      ' * Creates a unique string.
      ' * @param createKey (Bolean) If true, the result contains user and time info.  Otherwise, the result is the same as the @Unique function.
      ' * @return A unique text string.
      ' */
   
   Dim unique As Variant
   Dim result As String
   
   unique = Evaluate({@Unique})
   result = unique(0)
   
   If (createKey) Then
      
      Dim soundex As Variant
      Dim codes As String
      Dim codeLength As Integer
      
      soundex = Evaluate({@Right(@Soundex(@Left(@Name([CN]; @UserName);" ")); 3)} & _
      { + @Right(@Soundex(@Right(@Name([CN]; @UserName);" ")); 3)})
      codes = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
      codeLength = Len(codes)
      
            ' Remove the users initials.
      result = Strright(result, "-")
      
            ' Concatenate the soundex, unique, and datetime values.
      result = soundex(0) & "-" & result & "-" & Mid(codes, (Year(Now) Mod codeLength)+1, 1) & _
      Mid(codes, Month(Now)+1, 1) & Mid(codes, Day(Now)+1, 1) & _
      Mid(codes, Hour(Now)+1, 1) & Mid(codes, (Minute(Now) Mod codeLength)+1, 1) & _
      Mid(codes, (Second(Now) Mod codeLength)+1, 1)
      
   End If
   
   StrUnique = result
   
End Function
Function GetLongPathName(Byval strShortPathName As String) As String
   
      '/**
      ' * Converts a short path name to a long path name.
      ' * @param strShortPathName A string containing the short path name.
      ' * @return The long path name.
      ' */
   
   Dim strBuffer As String * 300
   Dim status As Long
   
   status = W32_GetLongPathName(strShortPathName, strBuffer, 300)
   If (status = 0) Then Error ERR_ERROR, "File Not Found"
   GetLongPathName = Left$(strBuffer, status)
   
End Function
Public Function StrDirSep(Byval platform As String) As String
   
      '/**
      ' * Returns the directory separator for a specific (or current) platform.
      ' * @param platform (Keyword) The platform to query.  Specify the NULL string for the current platform.  Possible values: "Macintosh", "UNIX", "Linux".  All other keywords default to "DOS".
      ' * @return A string containing the character(s) used to separate directories in a file path.
      ' */
   
   platform = Trim(platform)
   If (platform = "") Then
      Dim sess As New NotesSession
      platform = sess.Platform
   End If
   
   Select Case platform
      
   Case "Macintosh"
      StrDirSep = ":"
      
   Case "UNIX","Linux"
      StrDirSep = "/"
      
   Case Else
      StrDirSep = "\"
      
   End Select
   
End Function
Public Function StrNewline(Byval count As Integer) As String
   
      '/**
      ' * Builds a string consisting of newline charachters.
      ' * @param count The number of charachters to include in the string.
      ' * @return A string containing newline charachters.
      ' */
   
   StrNewLine = String$(count, Chr(10))
   
End Function
Public Function ArrayAdd(source As Variant, values As Variant) As Variant
   
      '/**
      ' * Appends an element to an array.
      ' * @param source The source array.
      ' * @param values The value or values to append to the array.
      ' * @return A new array containing all elements from <i>source</i> and <i>values</i>.
      ' */
   
   Dim tempArray1 As Variant
   Dim tempArray2 As Variant
   Dim tempData1 As Variant
   Dim tempData2 As Variant
   
      ' Check for empty arrays.
   If (ArrayElements(values) = 0) Then
      Redim tempArray1(0)
      If (Isobject(source)) Then
         Set tempArray1(0) = source
      Elseif (Isarray(source)) Then
         tempArray1 = source
      Else
         tempArray1(0) = source
      End If
      ArrayAdd = tempArray1
      Exit Function
   End If
   
   If (ArrayElements(source) = 0) Then
      Redim tempArray2(0)
      If (Isobject(values)) Then
         Set tempArray2(0) = values
      Elseif (Isarray(values)) Then
         tempArray2 = values
      Else
         tempArray2(0) = values
      End If
      ArrayAdd = tempArray2
      Exit Function
   End If
   
      ' Check for scalar values and objects.
   If (Isarray(source)) Then
      
      tempArray1 = source
      
   Else
      
      If (Isobject(source)) Then Set tempData1= source _
      Else tempData1= source
      Redim tempArray1(0)
      If (Isobject(tempData1)) Then Set tempArray1(0) = tempData1 _
      Else tempArray1(0) = tempData1
      
   End If
   
   If (Isarray(values)) Then
      
      tempArray2 = values
      
   Else
      
      If (Isobject(values)) Then Set tempData2= values _
      Else tempData2= values
      Redim tempArray2(0)
      If (Isobject(tempData2)) Then Set tempArray2(0) = tempData2 _
      Else tempArray2(0) = tempData2
      
   End If
   
      ' All parameters should now be acceptable for Arrayappend function.
   ArrayAdd = Arrayappend(tempArray1, tempArray2)
   
End Function
Public Function DirectoryExists(dirName As String) As Variant
   
      '/**
      ' * Determines whether a directory exists.
      ' * @param dirName The path of the directory to check.
      ' * @return True if the directory exists.
      ' */
   
   On Error Goto DONE
   DirectoryExists = False
   If (Dir$(dirName, ATTR_DIRECTORY) <> "") Then DirectoryExists = True
   
DONE:
   
      ' The following lines addresses a bug where the Dir function keeps an open handle to the last directory accessed.
      ' This forces the open handle to be the Notes Data directory which should not pose any problems.
   Dim temp As String
   temp = Dir$(GetDataDirectory(), ATTR_DIRECTORY)
   
   Exit Function
   
End Function
Sub DetachePJ(doc As NotesDocument, CheminFichier As String,Piecej As String)
   
   
   Dim RtItem As NotesRichTextItem
   Dim Objet As NotesEmbeddedObject
   Dim objectName As String
   
   
   Set rtitem = doc.GetFirstItem( "Body" )
   If ( rtitem.Type = RICHTEXT ) Then
      If Not Isempty (rtitem.EmbeddedObjects) Then
         Forall o In rtitem.EmbeddedObjects            
               'On le detache et on le supprime
            If Not o Is Nothing Then
               objectName = o.Name
               Call O.ExtractFile(CheminFichier +"."+objectName)      
               Piecej=Piecej+"|"+objectName
            End If         
            
            
         End Forall
      End If   
      
   End If    
End Sub
Public Function GetDataDirectory() As String
   
      '/**
      ' * Determines the location of the Notes/Domino Data directory.
      ' */
   
   Dim sess As New NotesSession
   GetDataDirectory = sess.GetEnvironmentString("Directory", True)
   GetDataDirectory = StrFixEnd(GetDataDirectory, StrDirsep(""))
   
End Function
Public Function StrContains(Byval sourceString As String, Byval subString As String, Byval caseSensitive As Integer) As Integer
   
      '/**
      ' * Determines whether a string contains a specific substring.
      ' * @param sourceString The string to search.
      ' * @param subString The string to search for.
      ' * @param caseSensitive (Boolean) Indicates whether the string matching should be case sensitive.
      ' * @return If the substring is found within the source string, the return value is True.  Otherwise, the return value is False.
      ' */
   
   Dim compMethod As Integer
   StrContains = False
   If (sourceString = "") Then Exit Function
   If (subString = "") Then Exit Function
   If (caseSensitive) Then compMethod = 0 Else compMethod = 1
   If (Instr(1, sourceString, subString, compMethod) = 0) Then Exit Function
   StrContains = True
   
End Function
Public Function StrExplode(Byval source As String, Byval delimeter As String) As Variant
   
      '/**
      ' * Returns a text array composed of the elements of a text string.
      ' * @param source A string containing the text to expand.
      ' * @param delimeter The text to use to split the source text.
      ' * @return A text array composed of the elements of a text string.
      ' */
   
   Dim numElements As Integer
   Dim currentIndex As Integer
   Dim prevIndex As Integer
   Dim delimLen As Integer
   
      ' Init
   If (delimeter = "") Then delimeter = " "
   delimLen = Len(delimeter)
   prevIndex = 1
   If (delimLen > Len(source)) Then
      StrExplode = ArrayAdd(StrExplode, source)
      Exit Function
   End If
   
      ' Split the source string
   currentIndex = Instr(source, delimeter)
   If (currentIndex > 0) Then
      numElements = 0
      Do While (currentIndex > 0)
         numElements = numElements + 1
         Redim Preserve arrResult(0 To numElements) As String
         arrResult(numElements - 1) = Mid$(source, prevIndex, currentIndex - prevIndex)
         prevIndex = currentIndex + delimLen
         currentIndex = Instr(prevIndex, source, delimeter)
      Loop
      arrResult(numElements) = Right$(source, Len (source) - (prevIndex - 1))
      StrExplode = arrResult
   Else
      StrExplode = ArrayAdd(StrExplode, source)
   End If
   
End Function
Public Function ArrayElements(source As Variant) As Integer
   
      '/**
      ' * Determines the number of elements in an array.
      ' * @param source The array to check.
      ' */
   
   Select Case Datatype(source)
      
   Case V_EMPTY, V_NULL
      
      ArrayElements = 0
      Exit Function
      
   Case V_INTEGER, V_LONG, V_SINGLE, V_DOUBLE, V_CURRENCY, V_DATE, V_STRING, V_LSOBJ, V_PRODOBJ
      
      ArrayElements = 1
      Exit Function
      
   Case V_BYTE, V_BOOLEAN
      
      ArrayElements = 1
      Exit Function
      
   Case Else
      
            ' Check for empty array.
      If Isempty(source) Then
         
         ArrayElements = 0
         Exit Function
         
      Else
         
         ArrayElements = Ubound(source) - Lbound(source) + 1
         
      End If
      
            ' Handle special cases.
      If (ArrayElements = 1) Then
         
         Select Case Datatype(source(Lbound(source)))
            
         Case V_EMPTY, V_NULL
            
            ArrayElements = 0
            
         Case V_LSOBJ, V_PRODOBJ
            
            If (source(Lbound(source)) Is Nothing) Then ArrayElements = 0
            
         End Select
      End If
      
   End Select
   
End Function
Public Sub CreateDirectory(Byval filePath As String)
   
      '/**
      ' * Creates a directory.
      ' * @param filePath A string containing the directory to create.  If filePath contains a path with nested directories that do not exist, this function will create all directories in the path.
      ' */
   
   Dim pathArray As Variant
   Dim dirSep As String
   Dim temp As String
   
      ' Init
   dirSep = StrDirSep("")
   
      ' Convert the file path to an array of directories..
   pathArray = ArrayCreate(StrExplode(filePath, dirSep))
   
      ' Look through the directory array to create the full path.
   Forall vElement In pathArray
      temp = temp & Cstr(vElement) & dirSep
      If (Not DirectoryExists(temp)) Then Mkdir temp
   End Forall
   
End Sub
Public Function ArrayCreate(source As Variant) As Variant
   
      '/**
      ' * Creates an array from the source.
      ' * @param source An array or string containing a list of array elements separated by a comma.
      ' * @return A new array containing the elements found in the source.
      ' */
   
   Dim result(0) As Variant
   
   If (Isarray(source)) Then
      
      ArrayCreate = source
      
   Elseif (Isobject(source)) Then
      
      Set result(0) = source
      ArrayCreate = result
      
   Elseif (StrContains(source, ",", True)) Then
      
      ArrayCreate = StrExplode(source, ",")
      
   Else
      
      result(0) = source
      ArrayCreate = result
      
   End If
   
End Function
Public Function StrFixEnd(Byval strSource As String, Byval strEnd As String) As String
   
      '/**
      ' * Returns a string that is garanteed to end with a specific string.
      ' * @param strSource The string to check.
      ' * @param strEnd The string that must occur at the end of strSource
      ' * @return A new string that ends with strEnd.
      ' */
   
   Dim retval As String
   If (Len(strSource) < Len(strEnd)) Then
      retval = strSource & strEnd
   Elseif(Lcase(Right(strSource, Len(strEnd))) <> Lcase(strEnd)) Then
      retval = strSource & strEnd
   Else
      retval = strSource
   End If
   StrFixEnd = retval
   
End Function
Public Function ArrayImplode(source As Variant, delimiter As String) As String
   
      '/**
      ' * Concatenates all members of an array and returns a text string.
      ' * @param source The source array.
      ' * @param delimiter The text to use to separate each element in the array.
      ' * @return A string containing all elements of the specified array separated by the specified delimiter.
      ' */
   
   Dim result As String
   Dim index As Integer
   
      ' Init
   result = ""
   index = 0
   
   If (Not Isarray(source)) Then
      ArrayImplode = Cstr(source)
      Exit Function
   End If
   
   Forall v In source
      
            ' Append delimiter after first iteration
      If (index <> 0) Then result = result & delimiter
      
            ' Convert item to a string value.
      Select Case Datatype(v)
         
      Case V_LSOBJ, V_PRODOBJ
         
         result = result & Typename(v)
         
      Case Else
         
         result = result & Cstr(v)
         
      End Select
      
      index = index + 1
      
   End Forall
   
      ' Return result.
   ArrayImplode = result
   
End Function