Attribute VB_Name = "mod_Email"
Option Explicit

Public Const CPY_BUFFER = 10240

Public CurrentFolder As String
Public HeadOffset As Long
Public MessageID As Long
Public HTMLMessage As String
Public TEXTMessage As String
Public HEADERMessage As String


Public HTMLReply As String
Public HTMLTo As String
Public HTMLSubject As String

Public tmpAttachments As Long
Public tmpTEXT As String
Public tmpHTML As String
Public InboxDir As String
Public MailDir As String
Public OutBoxDir As String
Public SentItemsDir As String
Public DeletedDir As String
Public defIn As String
Public defOut As String
Public defSnd As String
Public defDel As String
Public EmailBut1 As String
Public EmailBut2 As String
Public EmailBut3 As String
Public EmailBut4 As String
Public EmailBut5 As String
Public EmailBut6 As String
Public EmailBut7 As String


Global g_EmailAddr As String
Global g_UserName As String

Private Sub Email_CreateTD_Attachments(DB As Database)
    Dim TD As TableDef
    Dim FLD As Field
    Dim IDX As Index
    Set TD = DB.CreateTableDef("Attachments")
        TD.Attributes = 0
        TD.Connect = ""
        TD.SourceTableName = ""
        TD.ValidationRule = ""
        TD.ValidationText = ""
        ' Field ID
        Set FLD = TD.CreateField("ID", 4, 4)
            FLD.Attributes = 1
            FLD.DefaultValue = ""
            FLD.OrdinalPosition = 0
            FLD.Required = False
            FLD.ValidationRule = ""
            FLD.ValidationText = ""
        TD.Fields.Append FLD
        ' Field Filename
        Set FLD = TD.CreateField("Filename", 10, 255)
            FLD.AllowZeroLength = True
            FLD.Attributes = 2
            FLD.DefaultValue = ""
            FLD.OrdinalPosition = 1
            FLD.Required = False
            FLD.ValidationRule = ""
            FLD.ValidationText = ""
        TD.Fields.Append FLD
        ' Field Data
        Set FLD = TD.CreateField("Data", 12, 0)
            FLD.Attributes = 2
            FLD.DefaultValue = ""
            FLD.OrdinalPosition = 1
            FLD.Required = False
            FLD.ValidationRule = ""
            FLD.ValidationText = ""
        TD.Fields.Append FLD
        ' Index ID
        Set IDX = TD.CreateIndex("ID")
            IDX.Clustered = False
            IDX.Primary = False
            IDX.Unique = False
            IDX.Required = True
            IDX.IgnoreNulls = False
            ' Field ID
            Set FLD = IDX.CreateField("ID")
                FLD.Attributes = 0
            IDX.Fields.Append FLD
        TD.Indexes.Append IDX
    DB.TableDefs.Append TD
End Sub

Private Sub Email_CreateTD_Index(DB As Database)
    Dim TD As TableDef
    Dim FLD As Field
    Dim IDX As Index

    Set TD = DB.CreateTableDef("Index")
        TD.Attributes = 0
        TD.Connect = ""
        TD.SourceTableName = ""
        TD.ValidationRule = ""
        TD.ValidationText = ""
        ' Field ID
        Set FLD = TD.CreateField("ID", 4, 4)
            FLD.Attributes = 17
            FLD.DefaultValue = ""
            FLD.OrdinalPosition = 0
            FLD.Required = False
            FLD.ValidationRule = ""
            FLD.ValidationText = ""
        TD.Fields.Append FLD
        ' Field Subject
        Set FLD = TD.CreateField("Subject", 10, 255)
            FLD.AllowZeroLength = True
            FLD.Attributes = 2
            FLD.DefaultValue = ""
            FLD.OrdinalPosition = 1
            FLD.Required = False
            FLD.ValidationRule = ""
            FLD.ValidationText = ""
        TD.Fields.Append FLD
        ' Field From
        Set FLD = TD.CreateField("From", 10, 255)
            FLD.AllowZeroLength = True
            FLD.Attributes = 2
            FLD.DefaultValue = ""
            FLD.OrdinalPosition = 2
            FLD.Required = False
            FLD.ValidationRule = ""
            FLD.ValidationText = ""
        TD.Fields.Append FLD
        ' Field Date
        Set FLD = TD.CreateField("Date", 10, 255)
            FLD.AllowZeroLength = True
            FLD.Attributes = 2
            FLD.DefaultValue = ""
            FLD.OrdinalPosition = 3
            FLD.Required = False
            FLD.ValidationRule = ""
            FLD.ValidationText = ""
        TD.Fields.Append FLD
        ' Field To
        Set FLD = TD.CreateField("To", 10, 255)
            FLD.AllowZeroLength = True
            FLD.Attributes = 2
            FLD.DefaultValue = ""
            FLD.OrdinalPosition = 4
            FLD.Required = False
            FLD.ValidationRule = ""
            FLD.ValidationText = ""
        TD.Fields.Append FLD
        ' Field Attachments
        Set FLD = TD.CreateField("Attachments", 4, 4)
            FLD.Attributes = 1
            FLD.DefaultValue = "0"
            FLD.OrdinalPosition = 5
            FLD.Required = False
            FLD.ValidationRule = ""
            FLD.ValidationText = ""
        TD.Fields.Append FLD
        ' Field Readed
        Set FLD = TD.CreateField("Readed", 3, 2)
            FLD.Attributes = 1
            FLD.DefaultValue = "0"
            FLD.OrdinalPosition = 6
            FLD.Required = False
            FLD.ValidationRule = ""
            FLD.ValidationText = ""
        TD.Fields.Append FLD
        ' Field RealDate
        Set FLD = TD.CreateField("RealDate", 8, 8)
            FLD.Attributes = 1
            FLD.DefaultValue = ""
            FLD.OrdinalPosition = 7
            FLD.Required = False
            FLD.ValidationRule = ""
            FLD.ValidationText = ""
        TD.Fields.Append FLD
        ' Index ID
        Set IDX = TD.CreateIndex("ID")
            IDX.Clustered = False
            IDX.Primary = True
            IDX.Unique = True
            IDX.Required = True
            IDX.IgnoreNulls = False
            ' Field ID
            Set FLD = IDX.CreateField("ID")
                FLD.Attributes = 0
            IDX.Fields.Append FLD
        TD.Indexes.Append IDX
        ' Index RealDate
        Set IDX = TD.CreateIndex("RealDate")
            IDX.Clustered = False
            IDX.Primary = False
            IDX.Unique = False
            IDX.Required = False
            IDX.IgnoreNulls = True
            ' Field RealDate
            Set FLD = IDX.CreateField("RealDate")
                FLD.Attributes = 0
            IDX.Fields.Append FLD
        TD.Indexes.Append IDX
    DB.TableDefs.Append TD
End Sub

Private Sub Email_CreateTD_Message(DB As Database)
    Dim TD As TableDef
    Dim FLD As Field
    Dim IDX As Index

    Set TD = DB.CreateTableDef("Message")
        TD.Attributes = 0
        TD.Connect = ""
        TD.SourceTableName = ""
        TD.ValidationRule = ""
        TD.ValidationText = ""
        ' Field ID
        Set FLD = TD.CreateField("ID", 4, 4)
            FLD.Attributes = 1
            FLD.DefaultValue = ""
            FLD.OrdinalPosition = 0
            FLD.Required = True
            FLD.ValidationRule = ""
            FLD.ValidationText = ""
        TD.Fields.Append FLD
        ' Field Text
        Set FLD = TD.CreateField("Text", 12, 0)
            FLD.Attributes = 2
            FLD.DefaultValue = ""
            FLD.OrdinalPosition = 1
            FLD.Required = False
            FLD.ValidationRule = ""
            FLD.ValidationText = ""
        TD.Fields.Append FLD
        ' Field HTML
        Set FLD = TD.CreateField("Html", 12, 0)
            FLD.Attributes = 2
            FLD.DefaultValue = ""
            FLD.OrdinalPosition = 2
            FLD.Required = False
            FLD.ValidationRule = ""
            FLD.ValidationText = ""
        TD.Fields.Append FLD
        ' Field Headers
        Set FLD = TD.CreateField("Headers", 12, 0)
            FLD.Attributes = 2
            FLD.DefaultValue = ""
            FLD.OrdinalPosition = 3
            FLD.Required = False
            FLD.ValidationRule = ""
            FLD.ValidationText = ""
        TD.Fields.Append FLD
        ' Index ID
        Set IDX = TD.CreateIndex("ID")
            IDX.Clustered = False
            IDX.Primary = True
            IDX.Unique = True
            IDX.Required = True
            IDX.IgnoreNulls = False
            ' Field ID
            Set FLD = IDX.CreateField("ID")
                FLD.Attributes = 0
            IDX.Fields.Append FLD
        TD.Indexes.Append IDX
    DB.TableDefs.Append TD
End Sub

Public Sub Email_DeleteMessage(fileDir As String, ID As Long)
    Dim DMesWorkspace As Workspace
    Dim DMesDatabase As Database
    Dim DMesTable As Recordset
    Dim DMesQuery As QueryDef
    Dim sqlString As String

    Set DMesWorkspace = Workspaces(0)
    'Wis de index!
    Set DMesDatabase = DMesWorkspace.OpenDatabase(MailDir + fileDir + "\index.mdb")
    Set DMesTable = DMesDatabase.OpenRecordset("index", dbOpenTable)
    DMesTable.Index = "ID"
    DMesTable.Seek "=", ID
    If Not DMesTable.NoMatch Then
        DMesTable.Delete
    End If
    DMesTable.Close
    DMesDatabase.Close
    
    Set DMesDatabase = DMesWorkspace.OpenDatabase(MailDir + fileDir + "\data.mdb")
    Set DMesTable = DMesDatabase.OpenRecordset("Message", dbOpenTable)
    DMesTable.Index = "ID"
    DMesTable.Seek "=", ID
    If Not DMesTable.NoMatch Then
        DMesTable.Delete
    End If
    DMesTable.Close
    DMesDatabase.Close

    Set DMesDatabase = DMesWorkspace.OpenDatabase(MailDir + fileDir + "\attachments.mdb")
    Set DMesQuery = DMesDatabase.CreateQueryDef("")
    sqlString = "SELECT * FROM attachments where ID=" + CStr(ID) + " "
    With DMesQuery
        .SQL = sqlString
        Set DMesTable = .OpenRecordset()
    End With
    
    Do While Not DMesTable.EOF
        DMesTable.Delete
        DMesTable.MoveNext
    Loop
    DMesTable.Close
    DMesDatabase.Close

End Sub

Public Sub Email_DisplayMessage(fileDir As String, ID As Long)
    Dim RMesWorkspace As Workspace
    Dim RMesDatabase As Database
    Dim RMesTable As Recordset
    Dim RMesQuery As QueryDef
    Dim sqlString As String
    
    Dim tmpFrom As String
    Dim tmpto As String
    Dim tmpSubject As String
    Dim tmpDate As String
    Dim tmpAttachments As Long

    TEXTMessage = ""
    HTMLMessage = ""
    HEADERMessage = ""
    tmpFrom = ""
    tmpto = ""
    tmpSubject = ""
    tmpDate = ""
    tmpAttachments = 0
    
    Set RMesWorkspace = Workspaces(0)
    Set RMesDatabase = RMesWorkspace.OpenDatabase(MailDir + fileDir + "\data.mdb")
    Set RMesQuery = RMesDatabase.CreateQueryDef("")
    sqlString = "SELECT * FROM message where ID=" + CStr(ID) + " "
    With RMesQuery
        .SQL = sqlString
        Set RMesTable = .OpenRecordset()
    End With
    'Even kijken of er iets gevonden is
    If Not RMesTable.EOF Then
        If RMesTable.Fields("text").Value <> "" Then TEXTMessage = RMesTable.Fields("text").Value
        If RMesTable.Fields("html").Value <> "" Then HTMLMessage = RMesTable.Fields("html").Value
        If RMesTable.Fields("headers").Value <> "" Then HEADERMessage = RMesTable.Fields("headers").Value
    End If
    RMesTable.Close
    RMesDatabase.Close

    tmpAttachments = 0

    'Set de readed flag op gelezen!
    Set RMesDatabase = RMesWorkspace.OpenDatabase(MailDir + fileDir + "\index.mdb")
    Set RMesQuery = RMesDatabase.CreateQueryDef("")
    sqlString = "SELECT * FROM index where ID=" + CStr(ID) + " "
    With RMesQuery
        .SQL = sqlString
        Set RMesTable = .OpenRecordset()
    End With
    'Even kijken of er iets gevonden is
    If Not RMesTable.EOF Then
        RMesTable.Edit
        RMesTable.Fields("Readed").Value = 1
        If (RMesTable.Fields("from").Value <> "") Then tmpFrom = RMesTable.Fields("from").Value
        If (RMesTable.Fields("date").Value <> "") Then tmpDate = RMesTable.Fields("date").Value
        If (RMesTable.Fields("to").Value <> "") Then tmpto = RMesTable.Fields("to").Value
        If (RMesTable.Fields("subject").Value <> "") Then tmpSubject = RMesTable.Fields("subject").Value
        If (RMesTable.Fields("Attachments").Value <> "") Then tmpAttachments = RMesTable.Fields("Attachments").Value
        RMesTable.Update
    End If
    RMesTable.Close
    RMesDatabase.Close
    
    
    
    Dim bodystart As Long
    Dim bodyend As Long
    Dim fptr
    Dim fontString As String
    Dim fontStart As Long
    Dim fontEnd As Long
    Dim fontColor As Long
    Dim bstart As Long
    Dim btext As String
    Dim bconvert As Long
    
    '
    ' Empty text box, suspend redraws, load message into textbox
    '
    
    frmMain.rtfEmail.Text = "a"
    frmMain.rtfEmail.SelStart = 0
    frmMain.rtfEmail.SelLength = 1
    frmMain.rtfEmail.SelColor = frmMain.rtfEmail.Tag 'vbWhite ' myColors.White
    frmMain.rtfEmail.Text = ""
    frmMain.RichTextBox1.Text = "From:" + Chr(9) + Chr(9) + tmpFrom + vbCrLf
    frmMain.RichTextBox1.Text = frmMain.RichTextBox1.Text + "To: " + Chr(9) + Chr(9) + tmpto + vbCrLf
    frmMain.RichTextBox1.Text = frmMain.RichTextBox1.Text + "Subject:" + Chr(9) + Chr(9) + tmpSubject + vbCrLf
    frmMain.RichTextBox1.Text = frmMain.RichTextBox1.Text + "Date:" + Chr(9) + Chr(9) + tmpDate + vbCrLf
    frmMain.RichTextBox1.Text = frmMain.RichTextBox1.Text + " " + vbCrLf
    
    If TEXTMessage <> "" Then
        frmMain.rtfEmail.Text = TEXTMessage
    End If
    If HTMLMessage <> "" Then
        bodystart = InStr(UCase(HTMLMessage), "<BODY")
        If (bodystart > 1) Then
            HTMLMessage = "<HTML><HEAD><base target=_blank></HEAD>" & Mid(HTMLMessage, bodystart)
            bodystart = InStr(UCase(HTMLMessage), "<BODY")
            bconvert = 1
            bodyend = InStr(bodystart + 4, HTMLMessage, ">")
            btext = Mid(UCase(HTMLMessage), bodystart, bodyend - bodystart)
            bstart = InStr(btext, "BGCOLOR=")
            If bstart > 1 Then
                btext = Mid(btext, bstart + 8)
                If Left(btext, 1) = Chr(34) Then
                    btext = Mid(btext, 2)
                End If
                If Left(btext, 7) = "#000000" Then
                    bconvert = 0
                End If
            End If
            If bconvert = 1 Then
                HTMLMessage = Mid(HTMLMessage, 1, bodystart) & "BODY BGCOLOR=#000000 TEXT=#FFFFFF" & Mid(HTMLMessage, bodyend)
                bodystart = InStr(bodyend + 1, UCase(HTMLMessage), "<FONT")
                Do While bodystart > 1
                    bodyend = InStr(bodystart + 4, HTMLMessage, ">")
                    fontString = Mid(HTMLMessage, bodystart, bodyend - bodystart + 1)
                    fontStart = InStr(fontString, "#")
                    If fontStart > 1 Then
                        'Red
                        fontColor = (Email_HexToDec(Mid(fontString, fontStart + 1, 1)) * 16)
                        fontColor = fontColor + (Email_HexToDec(Mid(fontString, fontStart + 2, 1)))
                        'Green
                        fontColor = fontColor + (Email_HexToDec(Mid(fontString, fontStart + 3, 1)) * 16 * 256)
                        fontColor = fontColor + (Email_HexToDec(Mid(fontString, fontStart + 4, 1)) * 256)
                        'Blue
                        fontColor = fontColor + (Email_HexToDec(Mid(fontString, fontStart + 5, 1)) * 16 * 256 * 256)
                        fontColor = fontColor + (Email_HexToDec(Mid(fontString, fontStart + 6, 1)) * 256 * 256)
    
                        If fontColor = 0 Then
                            HTMLMessage = Mid(HTMLMessage, 1, bodystart + fontStart - 1) & "FFFFFF" & Mid(HTMLMessage, bodystart + fontStart + 6)
                        End If
                    End If
                    bodystart = InStr(bodystart + 5, UCase(HTMLMessage), "<FONT")
                Loop
            End If
        End If
        If InStr(UCase(HTMLMessage), "</HTML") > 0 And InStr(UCase(HTMLMessage), "</HTML>") < 1 Then
            bodystart = InStr(UCase(HTMLMessage), "</HTML")
            HTMLMessage = Left(HTMLMessage, bodystart + 5) & ">" & Mid(HTMLMessage, bodystart + 6)
        End If
        If InStr(UCase(HTMLMessage), "</HTM") > 0 And InStr(UCase(HTMLMessage), "</HTML>") < 1 Then
            bodystart = InStr(UCase(HTMLMessage), "</HTM")
            HTMLMessage = Left(HTMLMessage, bodystart + 4) & "L>" & Mid(HTMLMessage, bodystart + 5)
        End If
        If InStr(UCase(HTMLMessage), "</HT") > 0 And InStr(UCase(HTMLMessage), "</HTML>") < 1 Then
            bodystart = InStr(UCase(HTMLMessage), "</HT")
            HTMLMessage = Left(HTMLMessage, bodystart + 3) & "ML>" & Mid(HTMLMessage, bodystart + 4)
        End If
    Else
        'Hier moet mijn eigen text to html converter!
        sqlString = "<HTML><HEAD><TITLE></TITLE></HEAD><BODY BGCOLOR=#000000 TEXT=#FFFFFF>"
        sqlString = sqlString & TEXTMessage
        sqlString = sqlString & "</BODY></HTML>"
        For bodystart = 1 To Len(sqlString)
            fontString = Mid(sqlString, bodystart, 1)
            If fontString = Chr(10) Then
                HTMLMessage = HTMLMessage & "<BR>"
            End If
            HTMLMessage = HTMLMessage & fontString
        Next
        bodystart = InStr(UCase(HTMLMessage), "HTTP://")
        Do While bodystart > 0
            For bodyend = bodystart To Len(HTMLMessage)
                fontString = Mid(HTMLMessage, bodyend, 1)
                If fontString = Chr(10) Or fontString = Chr(13) Or fontString = "<" Or fontString = " " Then
                    Exit For
                End If
            Next
            'bodyend = InStr(bodystart, HTMLMessage, " ")
            fontString = Mid(HTMLMessage, bodystart, bodyend - bodystart)
'Debug.Print "|" & fontString & "|"
            HTMLMessage = Mid(HTMLMessage, 1, bodystart - 1) & "<A TARGET=" & Chr(34) & "_blank" & Chr(34) & " HREF=" & Chr(34) & fontString & Chr(34) & ">" & fontString & "</a>" & Mid(HTMLMessage, bodyend)
            bodystart = bodystart + Len(fontString) + 31
            bodystart = InStr(bodystart, UCase(HTMLMessage), "HTTP://")
        Loop
    End If
    
    fptr = freefile
    Open MailDir & "tmp.html" For Output As #fptr
    Print #fptr, HTMLMessage
    Close #fptr
    
    frmMain.wbEmail.Navigate MailDir & "tmp.html"
    'TextBody.SelLength = 0
    
    
    
    frmMain.RichTextBox1.Text = frmMain.RichTextBox1.Text & frmMain.rtfEmail.Text & vbCrLf & vbCrLf
    
    frmMain.lvAttachments.ListItems.Clear
    If tmpAttachments > 0 Then
        frmMain.RichTextBox1.Text = frmMain.RichTextBox1.Text & "Attachments:" & vbCrLf
        Set RMesDatabase = RMesWorkspace.OpenDatabase(MailDir + fileDir + "\attachments.mdb")
        Set RMesQuery = RMesDatabase.CreateQueryDef("")
        sqlString = "SELECT * FROM attachments where ID=" + CStr(ID) + " "
        With RMesQuery
            .SQL = sqlString
            Set RMesTable = .OpenRecordset()
        End With
        'Even kijken of er iets gevonden is
        Do While Not RMesTable.EOF
            tmpFrom = RMesTable.Fields("filename")
            If (InStr(tmpFrom, Chr(34))) Then
                tmpFrom = Mid(tmpFrom, InStr(tmpFrom, Chr(34)) + 1)
                tmpFrom = Mid(tmpFrom, 1, InStr(tmpFrom, Chr(34)) - 1)
            End If
            tmpto = tmpFrom
            If Len(tmpFrom) > 12 Then
                tmpFrom = Left(tmpFrom, 12)
            End If
            frmMain.lvAttachments.ListItems.Add , , tmpFrom, 1, 1
            frmMain.lvAttachments.ListItems.Item(frmMain.lvAttachments.ListItems.Count).ToolTipText = tmpto
            frmMain.RichTextBox1.Text = frmMain.RichTextBox1.Text & tmpto & vbCrLf
            RMesTable.MoveNext
        Loop
        RMesTable.Close
        RMesDatabase.Close
    End If
    
    Email_MailDir_DisplayMessage
End Sub

Public Sub Email_DisplaySource()
    'TEXTMessage = HEADERMessage & vbCrLf & TEXTMessage
    HTMLMessage = ""
    frmMain.rtfEmail.Text = "a"
    frmMain.rtfEmail.SelStart = 0
    frmMain.rtfEmail.SelLength = 1
    frmMain.rtfEmail.SelColor = frmMain.rtfEmail.Tag 'vbWhite ' myColors.White
    frmMain.rtfEmail.Text = ""
    frmMain.rtfEmail.Text = HEADERMessage
    
    Email_MailDir_DisplayMessage

End Sub

Public Function Email_GetNewFileID(DirName As String) As Long
    Dim i As Integer
    Dim freefile As Long
    Dim myname As String
    Dim highestID As Long
    
    myname = Dir(DirName + "*.msg", vbNormal)
    highestID = 1
    Do While myname <> ""
        If myname <> "." And myname <> ".." Then
            If (GetAttr(DirName & myname) And vbNormal) = vbNormal Then
                If highestID < (val(myname) + 1) Then
                    highestID = val(myname) + 1
                End If
            End If
        End If
        myname = Dir
    Loop
    Email_GetNewFileID = highestID
End Function

Public Sub Email_GetOutMail(lstBox As ListBox)
    Dim myname As String
    
    Dim GOutWorkspace As Workspace
    Dim GOutDatabase As Database
    Dim GOutTable As Recordset
    Dim GOutQuery As QueryDef
    Dim sqlString As String

    Set GOutWorkspace = Workspaces(0)
    Set GOutDatabase = GOutWorkspace.OpenDatabase(OutBoxDir + "index.mdb")
    
    Set GOutQuery = GOutDatabase.CreateQueryDef("")

    sqlString = "SELECT * FROM index "
    With GOutQuery
        .SQL = sqlString
        Set GOutTable = .OpenRecordset()
    End With

    'Even kijken of er iets gevonden is
    Do While Not GOutTable.EOF
        lstBox.AddItem CStr(GOutTable.Fields("From")) & "|" & CStr(GOutTable.Fields("ID"))
        GOutTable.MoveNext
    Loop
    GOutTable.Close
    GOutDatabase.Close
End Sub

Public Function Email_HexToDec(hIn As String)
    Select Case UCase(hIn)
        Case "A"
            Email_HexToDec = 10
        Case "B"
            Email_HexToDec = 11
        Case "C"
            Email_HexToDec = 12
        Case "D"
            Email_HexToDec = 13
        Case "E"
            Email_HexToDec = 14
        Case "F"
            Email_HexToDec = 15
        Case Else
            Email_HexToDec = val(hIn)
    End Select
End Function

Public Sub Email_Init()
    Dim fptr
    Dim lngLoop As Long
    Dim BooIni As Boolean
    
    MailDir = strProgramdir & "\Email\"
    InboxDir = strProgramdir & "\Email\0\"
    OutBoxDir = strProgramdir & "\Email\1\"
    SentItemsDir = strProgramdir & "\Email\2\"
    DeletedDir = strProgramdir & "\Email\3\"
    On Error Resume Next
    MkDir strProgramdir & "\EmailTemp"
    If FileLen(MailDir & "0\data.mdb") = 0 Then
        MkDir strProgramdir & "\Email"
        MkDir strProgramdir & "\Email\0"
        Email_NewData ("0")
        Email_NewIndex ("0")
        Email_NewAttachments ("0")
    End If
    If FileLen(MailDir & "1\data.mdb") = 0 Then
        MkDir strProgramdir & "\Email"
        MkDir strProgramdir & "\Email\1"
        Email_NewData ("1")
        Email_NewIndex ("1")
        Email_NewAttachments ("1")
    End If
    If FileLen(MailDir & "2\data.mdb") = 0 Then
        MkDir strProgramdir & "\Email"
        MkDir strProgramdir & "\Email\2"
        Email_NewData ("2")
        Email_NewIndex ("2")
        Email_NewAttachments ("2")
    End If
    If FileLen(MailDir & "3\data.mdb") = 0 Then
        MkDir strProgramdir & "\Email"
        MkDir strProgramdir & "\Email\3"
        Email_NewData ("3")
        Email_NewIndex ("3")
        Email_NewAttachments ("3")
    End If
    On Error GoTo 0
    
    If Right(MailDir, 1) <> "\" Then
        MailDir = MailDir & "\"
    End If
    If Right(InboxDir, 1) <> "\" Then
        InboxDir = InboxDir & "\"
    End If
    
    fptr = freefile
    Open MailDir & "lcars-terminal.html" For Output As #fptr
    Print #fptr, "<HTML><HEAD><TITLE>LCARS Terminal - PADD</TITLE></HEAD><BODY BGCOLOR=#000000></BODY></HTML>"
    Close #fptr
    
    frmMain.wbEmail.Navigate MailDir & "lcars-terminal.html"

    frmMain.MLmessages.ColDelimiter = Chr(9)
    frmMain.MLmessages.Columns.Add 0
    frmMain.MLmessages.Columns.Add 1
    frmMain.MLmessages.Columns.Add 2
    frmMain.MLmessages.Columns.Add 4
    frmMain.MLmessages.Columns.Add 5
    frmMain.MLmessages.Columns.Add 6
    frmMain.MLmessages.Columns.Add 7
    frmMain.MLmessages.Columns.Add 8

    frmMain.lstEmailAccounts.Clear
    'kijk of er oude logs zijn en converteer die naar de nieuwe!
    lngLoop = 0
    BooIni = INI_GetKey("Email", "0", strProgramdir & "\email\accounts.ini")
    Do While (BooIni = True)
        frmMain.lstEmailAccounts.AddItem Database_Decrypt(iniValue)
        lngLoop = lngLoop + 1
        BooIni = INI_GetKey("Email", CStr(lngLoop), strProgramdir & "\email\accounts.ini")
    Loop
    
End Sub

Public Sub Email_MailDir_DisplayMessage()
    frmMain.imgBut(EmailBut1).Visible = True
    frmMain.imgBut(EmailBut2).Visible = True
    frmMain.imgBut(EmailBut3).Visible = True
    frmMain.imgBut(EmailBut4).Visible = True
    frmMain.imgBut(EmailBut5).Visible = True
    frmMain.imgBut(EmailBut6).Visible = True
    frmMain.imgBut(EmailBut7).Visible = True
    
    If HTMLMessage <> "" Then
        frmMain.wbEmail.Visible = True
        frmMain.webPic.Visible = True
        frmMain.rtfEmail.Visible = False
    Else
        frmMain.rtfEmail.Visible = True
        frmMain.webPic.Visible = False
        frmMain.wbEmail.Visible = False
    End If
    frmMain.lvAttachments.Visible = True
    'frmMain.cmdFake.SetFocus
End Sub
    
Public Sub Email_MailDir_HideMessage()
    frmMain.lvAttachments.Visible = False
    frmMain.webPic.Visible = False
    frmMain.wbEmail.Navigate MailDir & "lcars-terminal.html"
    frmMain.wbEmail.Visible = False
    frmMain.rtfEmail.Visible = False
    frmMain.imgBut(EmailBut1).Visible = False
    frmMain.imgBut(EmailBut2).Visible = False
    frmMain.imgBut(EmailBut3).Visible = False
    frmMain.imgBut(EmailBut4).Visible = False
    frmMain.imgBut(EmailBut5).Visible = False
    frmMain.imgBut(EmailBut6).Visible = False
    frmMain.imgBut(EmailBut7).Visible = False
End Sub

Public Sub Email_MoveMessage(fileDir As String, filedirO As String, ID As Long)
    'Bericht moet worden ingelezen en dan weer worden
    'weggeschreven he!
    Dim MMesWorkspace As Workspace
    Dim MMesDatabase As Database
    Dim MMesTable As Recordset
    Dim MMesQuery As QueryDef
    Dim MnMesWorkspace As Workspace
    Dim MnMesDatabase As Database
    Dim MnMesTable As Recordset
    Dim newID As Long
    Dim tmpattachements As Long
    Dim sqlString As String

    Set MMesWorkspace = Workspaces(0)
    Set MnMesWorkspace = Workspaces(0)
    'Move de index!
    Set MMesDatabase = MMesWorkspace.OpenDatabase(MailDir + fileDir + "\index.mdb")
    Set MnMesDatabase = MnMesWorkspace.OpenDatabase(MailDir + filedirO + "\index.mdb")
    Set MMesTable = MMesDatabase.OpenRecordset("index", dbOpenTable)
    Set MnMesTable = MnMesDatabase.OpenRecordset("index", dbOpenTable)
    MMesTable.Index = "ID"
    MMesTable.Seek "=", ID
    If Not MMesTable.NoMatch Then
        MnMesTable.AddNew
        MnMesTable.Fields("Subject").Value = MMesTable.Fields("Subject").Value
        MnMesTable.Fields("From").Value = MMesTable.Fields("From").Value
        MnMesTable.Fields("Date").Value = MMesTable.Fields("Date").Value
        MnMesTable.Fields("To").Value = MMesTable.Fields("To").Value
        MnMesTable.Fields("Attachments").Value = MMesTable.Fields("Attachments").Value
        tmpAttachments = MMesTable.Fields("Attachments").Value
        MnMesTable.Fields("Readed").Value = MMesTable.Fields("Readed").Value
        MnMesTable.Fields("RealDate").Value = MMesTable.Fields("RealDate").Value
        newID = MnMesTable.Fields("ID").Value
        MnMesTable.Update
        MMesTable.Delete
    End If
    MMesTable.Close
    MnMesTable.Close
    MMesDatabase.Close
    MnMesDatabase.Close
    
    'Move de DATA
    Set MMesDatabase = MMesWorkspace.OpenDatabase(MailDir + fileDir + "\data.mdb")
    Set MnMesDatabase = MnMesWorkspace.OpenDatabase(MailDir + filedirO + "\data.mdb")
    Set MMesTable = MMesDatabase.OpenRecordset("message", dbOpenTable)
    Set MnMesTable = MnMesDatabase.OpenRecordset("message", dbOpenTable)
    MMesTable.Index = "ID"
    MMesTable.Seek "=", ID
    If Not MMesTable.NoMatch Then
        MnMesTable.AddNew
        MnMesTable.Fields("ID").Value = newID
        MnMesTable.Fields("text").Value = MMesTable.Fields("text").Value
        MnMesTable.Fields("html").Value = MMesTable.Fields("html").Value
        MnMesTable.Fields("headers").Value = MMesTable.Fields("headers").Value
        MnMesTable.Update
        MMesTable.Delete
    End If
    MMesTable.Close
    MnMesTable.Close
    MMesDatabase.Close
    MnMesDatabase.Close
    
    'Move de Attachments
    Set MMesDatabase = MMesWorkspace.OpenDatabase(MailDir + fileDir + "\attachments.mdb")
    Set MnMesDatabase = MnMesWorkspace.OpenDatabase(MailDir + filedirO + "\attachments.mdb")
    Set MMesQuery = MMesDatabase.CreateQueryDef("")
    sqlString = "SELECT * FROM attachments where ID=" + CStr(ID) + " "
    With MMesQuery
        .SQL = sqlString
        Set MMesTable = .OpenRecordset()
    End With
    Set MnMesTable = MnMesDatabase.OpenRecordset("attachments", dbOpenTable)
    
    Do While Not MMesTable.EOF
        MnMesTable.AddNew
        MnMesTable.Fields("ID").Value = newID
        MnMesTable.Fields("data").Value = MMesTable.Fields("data").Value
        MnMesTable.Fields("filename").Value = MMesTable.Fields("filename").Value
        MnMesTable.Update
        MMesTable.Delete
        MMesTable.MoveNext
    Loop
    MMesTable.Close
    MnMesTable.Close
    MMesDatabase.Close
    MnMesDatabase.Close
    
End Sub

Public Sub Email_NewAttachments(Ndir As String)
    Dim WS As Workspace
    Dim DB As Database

    On Error Resume Next
    If FileLen(MailDir & Ndir & "\attachments.mdb") = 0 Then
        Set WS = DBEngine.Workspaces(0)
        Set DB = WS.CreateDatabase(MailDir & Ndir & "\" & "attachments.mdb", dbLangGeneral)
        Email_CreateTD_Attachments DB
        DB.Close
    End If
End Sub

Public Sub Email_NewData(Ndir As String)
    Dim WS As Workspace
    Dim DB As Database

    On Error Resume Next
    If FileLen(MailDir & Ndir & "\data.mdb") = 0 Then
        Set WS = DBEngine.Workspaces(0)
        Set DB = WS.CreateDatabase(MailDir & Ndir & "\" & "data.mdb", dbLangGeneral)
        Email_CreateTD_Message DB
        DB.Close
    End If
End Sub

Public Sub Email_NewIndex(Ndir As String)
    Dim WS As Workspace
    Dim DB As Database

    On Error Resume Next
    If FileLen(MailDir & Ndir & "\index.mdb") = 0 Then
        Set WS = DBEngine.Workspaces(0)
        Set DB = WS.CreateDatabase(MailDir & Ndir & "\" & "index.mdb", dbLangGeneral)
        Email_CreateTD_Index DB
        DB.Close
    End If
End Sub

Public Sub Email_ReadIndex(RIndlistbox As ListBox, fileDir As String)
    Dim RIndWorkspace As Workspace
    Dim RIndDatabase As Database
    Dim RIndTable As Recordset
    Dim RIndID As Long
    Dim RIndQuery As QueryDef
    Dim sqlString As String

    Set RIndWorkspace = Workspaces(0)
    Set RIndDatabase = RIndWorkspace.OpenDatabase(strProgramdir + "\Email\" + fileDir + "\index.mdb")
    
    Set RIndQuery = RIndDatabase.CreateQueryDef("")

    sqlString = "SELECT * FROM index ORDER BY realdate desc "
    With RIndQuery
        .SQL = sqlString
        Set RIndTable = .OpenRecordset()
    End With

    RIndlistbox.Clear
    'Even kijken of er iets gevonden is
    Do While Not RIndTable.EOF
        'ListMessages.AddItem CStr(Mail1.Parts) & stab & Mail1.Subject & stab & Mail1.From & stab & Mail1.Date & stab & Mail1.To
        RIndlistbox.AddItem CStr(RIndTable.Fields("ID")) & Chr$(9) & CStr(RIndTable.Fields("Readed")) & Chr$(9) & CStr(RIndTable.Fields("Attachments")) & Chr$(9) & RIndTable.Fields("Subject") & Chr$(9) & RIndTable.Fields("From") & Chr$(9) & RIndTable.Fields("Date") & Chr$(9) & RIndTable.Fields("To")
        RIndTable.MoveNext
    Loop
    RIndTable.Close
    RIndDatabase.Close

    'frmMain.cmdFake.SetFocus
End Sub

Public Sub Email_ReadMessage(mailOCX As mMail, fileDir As String, ID As Long)
    Dim RMesWorkspace As Workspace
    Dim RMesDatabase As Database
    Dim RMesTable As Recordset
    Dim RMesQuery As QueryDef
    Dim sqlString As String
    Dim tmpFrom As String
    Dim tmpto As String
    Dim tmpSubject As String
    Dim tmpDate As String
    Dim tmpAttachments As Long
    Dim tmpHTML As String
    Dim tmpTEXT As String
    Dim tmpHeaders As String
    Dim Boundary As Double
    Dim tmpFilename As String

    Dim FileString
    Dim sizeOfFile As Long
    Dim sFileString
    Dim iDNr As Integer
    Dim dRest As Double
    Dim sTemp As String
    Dim dCount As Double
    Dim i As Long
    Dim aCount As Long


    tmpFrom = ""
    tmpto = ""
    tmpSubject = ""
    tmpDate = ""
    tmpAttachments = 0
    tmpHTML = ""
    tmpTEXT = ""
    tmpHeaders = ""

    Set RMesWorkspace = Workspaces(0)
    
    'Set de readed flag op gelezen!
    Set RMesDatabase = RMesWorkspace.OpenDatabase(MailDir + fileDir + "\index.mdb")
    Set RMesQuery = RMesDatabase.CreateQueryDef("")
    sqlString = "SELECT * FROM index where ID=" + CStr(ID) + " "
    With RMesQuery
        .SQL = sqlString
        Set RMesTable = .OpenRecordset()
    End With
    'Even kijken of er iets gevonden is
    If Not RMesTable.EOF Then
        If (RMesTable.Fields("from").Value <> "") Then tmpFrom = RMesTable.Fields("from").Value
        If (RMesTable.Fields("date").Value <> "") Then tmpDate = RMesTable.Fields("date").Value
        If (RMesTable.Fields("to").Value <> "") Then tmpto = RMesTable.Fields("to").Value
        If (RMesTable.Fields("subject").Value <> "") Then tmpSubject = RMesTable.Fields("subject").Value
        If (RMesTable.Fields("Attachments").Value <> "") Then tmpAttachments = RMesTable.Fields("Attachments").Value
    End If
    RMesTable.Close
    RMesDatabase.Close
    
    
    
    Set RMesDatabase = RMesWorkspace.OpenDatabase(MailDir + fileDir + "\data.mdb")
    Set RMesQuery = RMesDatabase.CreateQueryDef("")
    sqlString = "SELECT * FROM message where ID=" + CStr(ID) + " "
    With RMesQuery
        .SQL = sqlString
        Set RMesTable = .OpenRecordset()
    End With
    'Even kijken of er iets gevonden is
    If Not RMesTable.EOF Then
        If (RMesTable.Fields("text").Value <> "") Then tmpTEXT = RMesTable.Fields("text").Value
        If (RMesTable.Fields("html").Value <> "") Then tmpHTML = RMesTable.Fields("html").Value
        If (RMesTable.Fields("headers").Value <> "") Then tmpHeaders = RMesTable.Fields("headers").Value
    End If
    RMesTable.Close
    RMesDatabase.Close

    mailOCX.Action = MailActionNewMessage
    
    Boundary = Fix(Rnd * 100000000000#)
    mailOCX.ContentType = "multipart"
    mailOCX.ContentSubtype = "mixed"
    mailOCX.ContentSubtypeParameters = "boundary=" & CStr(Boundary) & "_boundary"
    mailOCX.MultipartBoundary = CStr(Boundary) & "_boundary"
    
    
    If tmpAttachments > 0 Then
        aCount = 0
        Set RMesDatabase = RMesWorkspace.OpenDatabase(MailDir + fileDir + "\attachments.mdb")
        Set RMesQuery = RMesDatabase.CreateQueryDef("")
        sqlString = "SELECT * FROM attachments where ID=" + CStr(ID) + " "
        With RMesQuery
            .SQL = sqlString
            Set RMesTable = .OpenRecordset()
        End With
        'Even kijken of er iets gevonden is
        Do While Not RMesTable.EOF
            tmpFilename = RMesTable.Fields("filename").Value
            If (InStr(tmpFilename, Chr(34))) Then
                tmpFilename = Mid(tmpFilename, InStr(tmpFilename, Chr(34)) + 1)
                tmpFilename = Mid(tmpFilename, 1, InStr(tmpFilename, Chr(34)) - 1)
            End If
            'tmpto = tmpFrom
            'If Len(tmpFrom) > 12 Then
            '    tmpFrom = Left(tmpFrom, 12)
            'End If
            'frmMain.lvAttachments.ListItems.Add , , tmpFrom, 1, 1
            'frmMain.lvAttachments.ListItems.Item(frmMain.lvAttachments.ListItems.Count).ToolTipText = tmpto
            'frmMain.RichTextBox1.Text = frmMain.RichTextBox1.Text & tmpto & vbCrLf
            
            'This is the Attachements part
            mailOCX.Action = MailActionCreatePart
            mailOCX.Action = MailActionDescend
            mailOCX.ContentTransferEncoding = "base64"
            Select Case LCase(Mid(tmpFrom, InStrRev(tmpFilename, ".")))
                Case ".zip"
                    mailOCX.ContentType = "application"
                    mailOCX.ContentSubtype = "x-zip-compressed"
                    mailOCX.ContentSubtypeParameters = "name=" & Chr(34) & tmpFilename & Chr(34)
                    mailOCX.ContentDisposition = "attachment; filename=" & Chr(34) & tmpFilename & Chr(34)
                    'fEncode = True
                Case ".gif", ".bmp", ".jpg"
                    mailOCX.ContentType = "image"
                    mailOCX.ContentSubtype = LCase(Mid(tmpFrom, InStrRev(tmpFilename, ".") + 1))
                    mailOCX.ContentDisposition = "inline; filename=" & Chr(34) & tmpFilename & Chr(34)
                    'fEncode = True
                Case Else
                    mailOCX.ContentType = "application"
                    mailOCX.ContentSubtype = "octet-stream"
                    mailOCX.ContentDisposition = "attachment; filename=" & Chr(34) & tmpFilename & Chr(34)
                    'fEncode = True
            End Select
            mailOCX.Flags = MailSrcIsFile Or MailDstIsBody
            FileString = RMesTable.Fields("data").Value
            sizeOfFile = Len(FileString)
            sFileString = ""
            sFileString = Space$(sizeOfFile)
            sFileString = RMesTable.Fields("data").Value
            If Len(sFileString) = 0 Then
                Exit Sub
            End If
            iDNr = freefile
            Open strProgramdir & "\email\temp" & aCount & ".data" For Binary As iDNr
                dRest = Len(RMesTable.Fields("data").Value)
                If dRest > CPY_BUFFER Then
                    sTemp = Space(CPY_BUFFER)
                    dCount = Int(dRest / CPY_BUFFER)
                    dRest = Int(dRest - (CPY_BUFFER * dCount))
                    For i = 1 To dCount
                        DoEvents
                        sTemp = Left(sFileString, CPY_BUFFER)
                        sFileString = Mid(sFileString, CPY_BUFFER + 1)
                        'dRest = dRest - CPY_BUFFER
                        Put iDNr, , sTemp
                    Next i
                    sTemp = String(dRest, " ")
                    sTemp = Left(sFileString, dRest)
                    Put iDNr, , sTemp
                Else
                    sTemp = Space(dRest)
                    sTemp = Left(sFileString, dRest)
                    Put iDNr, , sTemp
                End If
                sTemp = Empty
            Close iDNr
            mailOCX.SrcFilename = strProgramdir & "\email\temp" & aCount & ".data"
            mailOCX.Action = MailActionEncode
            mailOCX.Action = MailActionAscend
            RMesTable.MoveNext
            Kill strProgramdir & "\email\temp" & aCount & ".data"
            'aCount = aCount + 1
        Loop
        RMesTable.Close
        RMesDatabase.Close
    End If
    
    
    mailOCX.Date = tmpDate
    mailOCX.From = tmpFrom
    mailOCX.EMailAddress = g_EmailAddr
    mailOCX.To = tmpto
    mailOCX.Subject = tmpSubject
    
    
    'this is the plain text 'part'
    mailOCX.Action = MailActionCreatePart
    mailOCX.Action = MailActionDescend
    mailOCX.ContentType = "text"
    mailOCX.ContentSubtype = "plain"
    mailOCX.ContentSubtypeParameters = "charset=us-ascii"
    mailOCX.ContentTransferEncoding = "7bit"
    mailOCX.Body(0) = tmpTEXT
    mailOCX.Action = MailActionAscend
    
    'HTML PART:
    mailOCX.Action = MailActionCreatePart
    mailOCX.Action = MailActionDescend
    mailOCX.ContentType = "text"
    mailOCX.ContentSubtype = "html"
    mailOCX.ContentSubtypeParameters = "charset=" & Chr$(34) & "iso-8859-1" & Chr$(34)
    mailOCX.ContentTransferEncoding = "quoted-printable"
    mailOCX.Flags = MailSrcIsBuffer Or MailDstIsBody
    mailOCX.Buffer = tmpHTML '& " " & vbCrLf & " " & vbCrLf
    mailOCX.Action = MailActionEncode
    mailOCX.Action = MailActionAscend





    'Set de readed flag op gelezen!
    Set RMesDatabase = RMesWorkspace.OpenDatabase(MailDir + fileDir + "\index.mdb")
    Set RMesQuery = RMesDatabase.CreateQueryDef("")
    sqlString = "SELECT * FROM index where ID=" + CStr(ID) + " "
    With RMesQuery
        .SQL = sqlString
        Set RMesTable = .OpenRecordset()
    End With
    'Even kijken of er iets gevonden is
    If Not RMesTable.EOF Then
        RMesTable.Edit
        RMesTable.Fields("Readed").Value = 1
        RMesTable.Update
    End If
    RMesTable.Close
    RMesDatabase.Close
    
End Sub

Public Sub Email_SaveMessage(strHTML As String, strTEXT As String, strTo As String, strFrom As String, strSubject As String, strCC As String, strBCC As String, strDate As String, fileDir As String)
    Dim WMesWorkspace As Workspace
    Dim WMesDatabase As Database
    Dim WMesTable As Recordset
    Dim WMesQuery As QueryDef
    Dim wMesID As Long
    Dim sqlString As String
    Dim filePTR
    Dim fileBuffer
    Dim lngLoop As Long
    Dim fileSize As Long
    
    Dim tmpHeaders As String
    Dim Part As Long
    Dim PartSub As Long
    Dim strTemp As String
    
    Set WMesWorkspace = Workspaces(0)
    
    strTemp = strTo
    lngLoop = InStr(strTemp, ";")
    Do While lngLoop > 0
        strTemp = Mid(strTemp, 1, lngLoop - 1) & "," & Mid(strTemp, lngLoop + 1)
        lngLoop = InStr(strTemp, ";")
    Loop
    
    
    Set WMesDatabase = WMesWorkspace.OpenDatabase(MailDir + fileDir + "\index.mdb")
    Set WMesTable = WMesDatabase.OpenRecordset("index", dbOpenTable)
    WMesTable.AddNew
    If strSubject <> "" Then
        WMesTable.Fields("Subject").Value = strSubject
    End If
    If strFrom <> "" Then
        WMesTable.Fields("From").Value = strFrom
    End If
    If strDate <> "" Then
        WMesTable.Fields("Date").Value = strDate
    End If
    If strTo <> "" Then
        WMesTable.Fields("To").Value = strTemp
    End If
    WMesTable.Fields("Attachments").Value = 0
    'Tijdelijk de datum van NU!!!
    WMesTable.Fields("RealDate").Value = Now
    wMesID = WMesTable.Fields("ID").Value
    WMesTable.Update
    WMesTable.Close
    WMesDatabase.Close
    
    
    tmpHeaders = ""
    If strCC <> "" Then tmpHeaders = tmpHeaders & "CC: " & strCC & vbCrLf
    If strBCC <> "" Then tmpHeaders = tmpHeaders & "BCC: " & strBCC & vbCrLf
    tmpHeaders = tmpHeaders & "X-Mailer: LCARS Terminal PADD v2.0" & vbCrLf
    
    'Schrijf de data van het bericht weg als Text/Html/Headers
    Set WMesDatabase = WMesWorkspace.OpenDatabase(MailDir + fileDir + "\data.mdb")
    Set WMesTable = WMesDatabase.OpenRecordset("message", dbOpenTable)
    WMesTable.AddNew
    WMesTable.Fields("ID").Value = wMesID
    If strTEXT <> "" Then WMesTable.Fields("text").Value = strTEXT
    If strHTML <> "" Then WMesTable.Fields("html").Value = strHTML
    If tmpHeaders <> "" Then WMesTable.Fields("headers").Value = tmpHeaders
    WMesTable.Update
    WMesTable.Close
    WMesDatabase.Close
   
   
   
    tmpAttachments = 0
    For lngLoop = 1 To frmEmail.lvAttachments.ListItems.Count
        Set WMesDatabase = WMesWorkspace.OpenDatabase(MailDir + fileDir + "\attachments.mdb")
        Set WMesTable = WMesDatabase.OpenRecordset("attachments", dbOpenTable)
            WMesTable.AddNew
            WMesTable.Fields("ID").Value = wMesID
            fileBuffer = ""
            filePTR = freefile
            sqlString = frmEmail.lvAttachments.ListItems(lngLoop).ToolTipText
            fileSize = FileLen(sqlString)
            Open sqlString For Binary Access Read As #filePTR
            'Do While Not EOF(filePTR)
            '    fileBuffer = fileBuffer & Input(1024, #filePTR)
            'Loop
            fileBuffer = Input(fileSize, #filePTR)
            Close #filePTR
            WMesTable.Fields("data").Value = fileBuffer
            If InStr(sqlString, "\") > 0 Then
                sqlString = Mid(sqlString, InStrRev(sqlString, "\") + 1)
            End If
            WMesTable.Fields("filename").Value = "name=" & Chr(34) & sqlString & Chr(34)
            WMesTable.Update
        WMesTable.Close
        WMesDatabase.Close
        tmpAttachments = tmpAttachments + 1
    Next
   
    If tmpAttachments > 0 Then
        'Set de readed flag op gelezen!
        Set WMesDatabase = WMesWorkspace.OpenDatabase(MailDir + fileDir + "\index.mdb")
        Set WMesQuery = WMesDatabase.CreateQueryDef("")
        sqlString = "SELECT * FROM index where ID=" + CStr(wMesID) + " "
        With WMesQuery
            .SQL = sqlString
            Set WMesTable = .OpenRecordset()
        End With
        'Even kijken of er iets gevonden is
        If Not WMesTable.EOF Then
            WMesTable.Edit
            WMesTable.Fields("Attachments").Value = tmpAttachments
            WMesTable.Update
        End If
        WMesTable.Close
        WMesDatabase.Close
    End If
End Sub

Public Sub Email_ShowHeaders()
    Dim lngLoop As Long

    Dim t_Temp As String
    Dim t_Readed As Integer
    Dim t_Atachments As String
    Dim t_From As String
    Dim t_Subject As String
    Dim t_To As String
    Dim t_Date As String
    Dim k As Long
    Dim l_From As Long
    Dim l_Subject As Long
    Dim l_Date As Long
    Dim l_To As Long

    frmMain.MLmessages.Clear
    
    frmMain.MLmessages.Columns(0).Width = 10        'Attachments
    frmMain.MLmessages.Columns(1).Width = 5
    frmMain.MLmessages.Columns(2).Width = Int((frmMain.MLmessages.Width - 30) / 4)
    frmMain.MLmessages.Columns(3).Width = 5
    frmMain.MLmessages.Columns(4).Width = Int((frmMain.MLmessages.Width - 30) / 4)
    frmMain.MLmessages.Columns(5).Width = 5
    frmMain.MLmessages.Columns(6).Width = Int((frmMain.MLmessages.Width - 30) / 4)
    frmMain.MLmessages.Columns(7).Width = 5
    frmMain.MLmessages.Columns(8).Width = Int((frmMain.MLmessages.Width - 30) / 4)
    
    'frmMain.lblEmail.Left = 15
    'frmMain.lblEmail.FontName = "Haettenschweiler"
    'frmMain.lblEmail.FontSize = "12"
    'frmMain.lblEmail.Width = frmMain.picBox3.Width
    'frmMain.lblEmail.Height = Int(frmMain.picBox3.Height / 2)
    'frmMain.lblEmail.Top = 0
    'Select Case CurrentFolder
    '    Case "Inbox"
    '        t_Temp = myText.textT
    '    Case "Outbox"
    '        t_Temp = myText.textU
    '    Case "Sent Items"
    '        t_Temp = myText.textV
    '    Case "Deleted Items"
    '        t_Temp = myText.textW
    '    Case Else
    '        t_Temp = CurrentFolder
    'End Select
    'frmMain.lblEmail.Caption = t_Temp
    'frmMain.lblEmail.Visible = True
    
    'frmMain.lblFrom.Left = frmMain.MLmessages.Columns(0).Width + frmMain.MLmessages.Columns(1).Width
    'frmMain.lblFrom.FontName = "Haettenschweiler"
    'frmMain.lblFrom.FontSize = "12"
    'frmMain.lblFrom.Width = frmMain.MLmessages.Columns(2).Width
    'frmMain.lblFrom.Height = 18
    'frmMain.lblFrom.Top = frmMain.picBox3.Height - frmMain.lblFrom.Height
    'frmMain.lblFrom.Caption = myText.textA
    'frmMain.lblFrom.Visible = True
    'frmMain.lblSubject.Left = frmMain.lblFrom.Left + frmMain.MLmessages.Columns(2).Width + frmMain.MLmessages.Columns(3).Width
    'frmMain.lblSubject.FontName = "Haettenschweiler"
    'frmMain.lblSubject.FontSize = "12"
    'frmMain.lblSubject.Width = frmMain.MLmessages.Columns(4).Width
    'frmMain.lblSubject.Height = frmMain.lblFrom.Height
    'frmMain.lblSubject.Top = frmMain.picBox3.Height - frmMain.lblFrom.Height
    'frmMain.lblSubject.Caption = myText.textB
    'frmMain.lblSubject.Visible = True
    'frmMain.lblDate.Left = frmMain.lblSubject.Left + frmMain.MLmessages.Columns(4).Width + frmMain.MLmessages.Columns(5).Width
    'frmMain.lblDate.FontName = "Haettenschweiler"
    'frmMain.lblDate.FontSize = "12"
    'frmMain.lblDate.Width = frmMain.MLmessages.Columns(6).Width
    'frmMain.lblDate.Height = frmMain.lblFrom.Height
    'frmMain.lblDate.Top = frmMain.picBox3.Height - frmMain.lblFrom.Height
    'frmMain.lblDate.Caption = myText.textE
    'frmMain.lblDate.Visible = True
    'frmMain.lblTo.Left = frmMain.lblDate.Left + frmMain.MLmessages.Columns(6).Width + frmMain.MLmessages.Columns(7).Width
    'frmMain.lblTo.FontName = "Haettenschweiler"
    'frmMain.lblTo.FontSize = "12"
    'frmMain.lblTo.Width = frmMain.MLmessages.Columns(8).Width
    'frmMain.lblTo.Height = frmMain.lblFrom.Height
    'frmMain.lblTo.Top = frmMain.picBox3.Height - frmMain.lblFrom.Height
    'frmMain.lblTo.Caption = myText.textF
    'frmMain.lblTo.Visible = True
    
    For lngLoop = 0 To frmMain.ListMessages.ListCount - 1
        t_Readed = 0
        t_Atachments = " "
        t_From = ""
        t_Subject = ""
        t_Date = ""
    
        t_Temp = frmMain.ListMessages.List(lngLoop)
        
        'Eerst het id nummer, kan overgeslagen worden!
        k = InStr(t_Temp, Chr(9))
        t_Temp = Mid(t_Temp, k + 1)

        'Message al gelezen 1=ja, 0=nee
        k = InStr(t_Temp, Chr(9))
        If val(Left(t_Temp, k - 1)) > 0 Then
            t_Readed = 1
        End If
        t_Temp = Mid(t_Temp, k + 1)
        
        'Aantal attachments!!!
        k = InStr(t_Temp, Chr(9))
        If val(Left(t_Temp, k - 1)) > 0 Then
            t_Atachments = "*"
        End If
        t_Temp = Mid(t_Temp, k + 1)

        'Subject inlezen
        k = InStr(t_Temp, Chr(9))
        t_Subject = Left(t_Temp, k - 1)
        t_Temp = Mid(t_Temp, k + 1)

        'From inlezen
        k = InStr(t_Temp, Chr(9))
        t_From = Left(t_Temp, k - 1)
        If (Left(t_From, 1) = Chr(34)) Then
            t_From = Mid(t_From, 2, InStr(2, t_From, Chr(34)) - 2)
        End If
        t_Temp = Mid(t_Temp, k + 1)

        'Datum inlezen
        k = InStr(t_Temp, Chr(9))
        t_Date = Left(t_Temp, k - 1)
        t_Temp = Mid(t_Temp, k + 1)

        'To inlezen
        k = InStr(t_Temp, Chr(9))
        t_To = t_Temp
        If (Left(t_To, 1) = Chr(34)) Then
            t_To = Mid(t_To, 2, InStr(2, t_To, Chr(34)) - 2)
        End If
        
        frmMain.MLmessages.AddItem t_Atachments & Chr(9) & Chr(9) & t_From & Chr(9) & Chr(9) & t_Subject & Chr(9) & Chr(9) & t_Date & Chr(9) & Chr(9) & t_To
        frmMain.MLmessages.ItemBackColor(frmMain.MLmessages.NewIndex) = frmMain.MLmessages.BackColor
        If t_Readed = 1 Then
            frmMain.MLmessages.ItemForeColor(frmMain.MLmessages.NewIndex) = frmMain.MLmessages.foreColor
        Else
            frmMain.MLmessages.ItemForeColor(frmMain.MLmessages.NewIndex) = frmMain.MLmessages.HorzDivForeColor
        End If
        frmMain.MLmessages.ItemHiliteTextColor(frmMain.MLmessages.NewIndex) = frmMain.MLmessages.HiliteTextColor
        frmMain.MLmessages.ItemHiliteColor(frmMain.MLmessages.NewIndex) = frmMain.MLmessages.HiliteColor
        DoEvents
    Next
End Sub

Public Function Email_WriteMessage(mailOCX As mMail, fileDir As String) As Boolean
    'We gaan nu een message vanuit de mmail.buffer in
    'de filedir\index.mdb en data.mdb zetten!
    Dim WMesWorkspace As Workspace
    Dim WMesDatabase As Database
    Dim WMesTable As Recordset
    Dim WMesQuery As QueryDef
    Dim wMesID As Long
    Dim sqlString As String
    
    Dim tmpHeaders As String
    Dim Part As Long
    Dim PartSub As Long
    Dim BooIni As Boolean
    
    Email_WriteMessage = False
    'We moeten eerst kijken of het een dubbele message is die we al een keer opgehaald hebben !!!
    PartSub = 0
    For Part = 0 To mailOCX.HeadersCount - 1
        tmpHeaders = mailOCX.Headers(Part)
        ' Message-id: <200403150952.i2F9qs72020352@vmx80.multikabel.net>
        If UCase(Mid(tmpHeaders, 1, 11)) = "MESSAGE-ID:" Then
            sqlString = Mid(tmpHeaders, 14)
            tmpHeaders = Mid(sqlString, 1, Len(sqlString) - 1)
            BooIni = INI_GetKey("MESID", tmpHeaders, MailDir & "incomming.ini")
            If BooIni = True Then
                Exit Function
            Else
                INI_WriteKey "MESID", tmpHeaders, "1", MailDir & "incomming.ini"
                PartSub = 1
            End If
        End If
        Debug.Print CStr(Part) & " " & tmpHeaders
    Next
    If PartSub = 0 Then
        mailOCX.Flags = MailDstIsBuffer
        mailOCX.Action = MailActionWriteMessage
        'Er is GEEN Message ID, dan een MD5 checksum inbouwen.
        tmpHeaders = CalculateMD5(mailOCX.Buffer)
        BooIni = INI_GetKey("MD5", tmpHeaders, MailDir & "incomming.ini")
        If BooIni = True Then
            Exit Function
        Else
            INI_WriteKey "MD5", tmpHeaders, "1", MailDir & "incomming.ini"
        End If
    End If
    
    Set WMesWorkspace = Workspaces(0)
    
    
    Set WMesDatabase = WMesWorkspace.OpenDatabase(MailDir + fileDir + "\index.mdb")
    Set WMesTable = WMesDatabase.OpenRecordset("index", dbOpenTable)
    WMesTable.AddNew
    WMesTable.Fields("Subject").Value = Trim(Left(mailOCX.Subject, 255))
    WMesTable.Fields("From").Value = Trim(Left(mailOCX.From, 255))
    WMesTable.Fields("Date").Value = mailOCX.Date
    WMesTable.Fields("To").Value = Trim(Left(mailOCX.To, 255))
    WMesTable.Fields("Attachments").Value = 0
    'Tijdelijk de datum van NU!!!
    WMesTable.Fields("RealDate").Value = Now
    wMesID = WMesTable.Fields("ID").Value
    WMesTable.Update
    WMesTable.Close
    WMesDatabase.Close
    
    
    tmpHeaders = ""
    For Part = 0 To mailOCX.HeadersCount - 1
        tmpHeaders = tmpHeaders & mailOCX.Headers(Part) & vbCrLf
    Next
    
    tmpTEXT = ""
    tmpHTML = ""
    tmpAttachments = 0
    
    If mailOCX.Parts > 0 Then
        For Part = 0 To mailOCX.Parts - 1
            mailOCX.Part = Part
            mailOCX.Action = MailActionDescend
            If mailOCX.Parts > 0 Then
                For PartSub = 0 To mailOCX.Parts - 1
                    mailOCX.Part = PartSub
                    mailOCX.Action = MailActionDescend
                    
                    Email_WriteProcess mailOCX, fileDir, wMesID
                    mailOCX.Action = MailActionAscend
                Next
            Else
                Email_WriteProcess mailOCX, fileDir, wMesID
            End If
            mailOCX.Action = MailActionAscend
        Next
    Else
        Email_WriteProcess mailOCX, fileDir, wMesID
    End If
   
    'Schrijf de data van het bericht weg als Text/Html/Headers
    Set WMesDatabase = WMesWorkspace.OpenDatabase(MailDir + fileDir + "\data.mdb")
    Set WMesTable = WMesDatabase.OpenRecordset("message", dbOpenTable)
    WMesTable.AddNew
    WMesTable.Fields("ID").Value = wMesID
    If tmpTEXT <> "" Then WMesTable.Fields("text").Value = tmpTEXT
    If tmpHTML <> "" Then WMesTable.Fields("html").Value = tmpHTML
    If tmpHeaders <> "" Then WMesTable.Fields("headers").Value = tmpHeaders
    WMesTable.Update
    WMesTable.Close
    WMesDatabase.Close
   
    If tmpAttachments > 0 Then
    'Set de readed flag op gelezen!
    Set WMesDatabase = WMesWorkspace.OpenDatabase(MailDir + fileDir + "\index.mdb")
    Set WMesQuery = WMesDatabase.CreateQueryDef("")
    sqlString = "SELECT * FROM index where ID=" + CStr(wMesID) + " "
    With WMesQuery
        .SQL = sqlString
        Set WMesTable = .OpenRecordset()
    End With
    'Even kijken of er iets gevonden is
    If Not WMesTable.EOF Then
        WMesTable.Edit
        WMesTable.Fields("Attachments").Value = tmpAttachments
        WMesTable.Update
    End If
    WMesTable.Close
    WMesDatabase.Close
    End If
    Email_WriteMessage = True
End Function

Public Sub Email_WriteProcess(mailOCX As mMail, fileDir As String, wMesID As Long)
    Dim cType As String
    Dim cSubType As String
    Dim enc As String
    Dim BodyCount As Long
    
    Dim WMesWorkspace As Workspace
    Dim WMesDatabase As Database
    Dim WMesTable As Recordset
    
    Set WMesWorkspace = Workspaces(0)
    
    enc = mailOCX.ContentTransferEncoding
    cType = LCase$(mailOCX.ContentType)
    cSubType = LCase$(mailOCX.ContentSubtype)
    If (enc = "base64" Or enc = "quoted-printable" Or enc = "mac-binhex40" Or enc = "x-uuencode") Then
        mailOCX.Flags = MailSrcIsBody Or MailDstIsBuffer
        mailOCX.Action = MailActionDecode
        If ((cType = "text" And cSubType = "plain")) Then
            If tmpTEXT = "" Then
                tmpTEXT = mailOCX.Buffer
            End If
        ElseIf ((cType = "text" And cSubType = "html")) Then
            If tmpHTML = "" Then
                tmpHTML = mailOCX.Buffer
            End If
        Else
            'Is een attachment
            Set WMesDatabase = WMesWorkspace.OpenDatabase(MailDir + fileDir + "\attachments.mdb")
            Set WMesTable = WMesDatabase.OpenRecordset("attachments", dbOpenTable)
            WMesTable.AddNew
            WMesTable.Fields("ID").Value = wMesID
            If mailOCX.Buffer <> "" Then
                WMesTable.Fields("data").Value = mailOCX.Buffer
            End If
            WMesTable.Fields("filename").Value = mailOCX.ContentSubtypeParameters
            WMesTable.Update
            WMesTable.Close
            WMesDatabase.Close
            tmpAttachments = tmpAttachments + 1
        End If
    Else
        If ((cType = "text" And cSubType = "plain")) Then
            If tmpTEXT = "" Then
                For BodyCount = 0 To mailOCX.BodyCount - 1
                    tmpTEXT = tmpTEXT & mailOCX.Body(BodyCount)
                Next
            End If
        ElseIf ((cType = "text" And cSubType = "html")) Then
            If tmpHTML = "" Then
                For BodyCount = 0 To mailOCX.BodyCount - 1
                    tmpHTML = tmpHTML & mailOCX.Body(BodyCount)
                Next
            End If
        Else
            'Is een attachment
            Set WMesDatabase = WMesWorkspace.OpenDatabase(MailDir + fileDir + "\attachments.mdb")
            Set WMesTable = WMesDatabase.OpenRecordset("attachments", dbOpenTable)
            WMesTable.AddNew
            WMesTable.Fields("ID").Value = wMesID
            enc = ""
            For BodyCount = 0 To mailOCX.BodyCount - 1
                enc = enc & mailOCX.Body(BodyCount)
            Next
            If enc <> "" Then
                WMesTable.Fields("data").Value = enc
            End If
            WMesTable.Fields("filename").Value = mailOCX.ContentSubtypeParameters
            WMesTable.Update
            WMesTable.Close
            WMesDatabase.Close
            tmpAttachments = tmpAttachments + 1
        End If
    End If
End Sub


