frmmain.frm

VB做滴邮件收发系统,喜欢的朋友可以下载看看学习参考哈

      Begin ComctlLib.ListView lvMessages 
         Height          =   2535
         Left            =   2160
         TabIndex        =   1
         Top             =   240
         Width           =   8295
         _ExtentX        =   14631
         _ExtentY        =   4471
         View            =   3
         LabelEdit       =   1
         LabelWrap       =   -1  'True
         HideSelection   =   -1  'True
         _Version        =   327682
         ForeColor       =   -2147483640
         BackColor       =   -2147483643
         BorderStyle     =   1
         Appearance      =   1
         NumItems        =   5
         BeginProperty ColumnHeader(1) {0713E8C7-850A-101B-AFC0-4210102A8DA7} 
            Key             =   ""
            Object.Tag             =   ""
            Text            =   "From"
            Object.Width           =   2540
         EndProperty
         BeginProperty ColumnHeader(2) {0713E8C7-850A-101B-AFC0-4210102A8DA7} 
            SubItemIndex    =   1
            Key             =   ""
            Object.Tag             =   ""
            Text            =   "Subject"
            Object.Width           =   5292
         EndProperty
         BeginProperty ColumnHeader(3) {0713E8C7-850A-101B-AFC0-4210102A8DA7} 
            SubItemIndex    =   2
            Key             =   ""
            Object.Tag             =   ""
            Text            =   "Date"
            Object.Width           =   2540
         EndProperty
         BeginProperty ColumnHeader(4) {0713E8C7-850A-101B-AFC0-4210102A8DA7} 
            SubItemIndex    =   3
            Key             =   ""
            Object.Tag             =   ""
            Text            =   "Size"
            Object.Width           =   1411
         EndProperty
         BeginProperty ColumnHeader(5) {0713E8C7-850A-101B-AFC0-4210102A8DA7} 
            Alignment       =   1
            SubItemIndex    =   4
            Key             =   ""
            Object.Tag             =   ""
            Text            =   "Attachments"
            Object.Width           =   2540
         EndProperty
      End
   End
   Begin VB.Menu m_Messages 
      Caption         =   "&Message"
      Begin VB.Menu cmdCheckMailbox 
         Caption         =   "Check Mailbox"
      End
      Begin VB.Menu cmdnewMail 
         Caption         =   "Create new E-Mail"
      End
      Begin VB.Menu m_SaveMessage 
         Caption         =   "Save E-Mail Text"
      End
      Begin VB.Menu cmdDelselMessage 
         Caption         =   "Delete selected Message"
      End
      Begin VB.Menu cmdReplyMessage 
         Caption         =   "Reply selected Message"
      End
      Begin VB.Menu Strich 
         Caption         =   "-"
      End
      Begin VB.Menu m_Exit 
         Caption         =   "Exit"
      End
   End
   Begin VB.Menu mAccount 
      Caption         =   "&Account"
   End
   Begin VB.Menu mView 
      Caption         =   "&View"
      Begin VB.Menu m_MailHeader 
         Caption         =   "Show Rfc822 Header"
      End
   End
   Begin VB.Menu m_language 
      Caption         =   "Language"
      Begin VB.Menu mEnglish 
         Caption         =   "English"
      End
      Begin VB.Menu mGerman 
         Caption         =   "German"
      End
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private intMailSelected As Integer
Private ComDialog As New cmDlg
Private Conn As New ADODB.Connection


'Declare Events for the vbMime Class
Private WithEvents Mime As vbMime
Attribute Mime.VB_VarHelpID = -1

Sub OpenConn() 'Connection string :-)

    Conn.Open "PROVIDER=MICROSOFT.JET.OLEDB.4.0;DATA SOURCE=" & App.Path & "\data.mdb"

End Sub

Sub CompactDatabase() 'DBP We compact the MDB. The MDB Dosent shrink as records is delteted. So... We have to do everything ourselves

  Dim JRO As JRO.JetEngine

    On Error GoTo error

    Set JRO = New JRO.JetEngine

    JRO.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\data.mdb", "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\tempbase.mdb" & ";Jet OLEDB:Engine Type=5"
    Kill App.Path & "\data.mdb"
    Name App.Path & "\tempbase.mdb" As App.Path & "\data.mdb"
    Set JRO = Nothing

Exit Sub

error:
    MsgBox "The programm could not open the E-Mail database." & vbCrLf & _
           "Please close all programms and try again!"
    End

End Sub

Public Sub cmdCheckMailbox_Click()

  Dim c As Control
  Dim Pop3Server As String, Pop3Username As String, Pop3Password As String

    'Check up textboxes frmmain
    For Each c In frmOptions.Controls
        If TypeOf c Is TextBox Then
            If Len(c.Text) = 0 Then
                MsgBox "Please check your Account Settings!"
                frmOptions.Show
                Exit Sub
            End If
        End If
    Next c

    For Each c In Controls
        If TypeOf c Is Image Then
            c.Enabled = False
        End If

        If TypeOf c Is Label Then
            c.Enabled = False
        End If

    Next c

    cmdCheckMailbox.Enabled = False

    With frmOptions
        'Set property if the mails received should be deleted or not
        Mime.DelMail = .chkDelMails.Value
        'Go and get it tiger! GRRR!
        Mime.GetMail .txtUsername, .txtPassword, .txtPop3Server
    End With

    'Query Database and retreive the Account Info then Get All E-Mails!
    'Set rsAccount = Conn.Execute("Select * from accounts")

    'Do Until rsAccount.EOF
    '    Pop3Server = rsAccount("pop3server")
    '    Pop3Username = rsAccount("username")
    '    Pop3Password = rsAccount("password")

    '    Mime.GetMail Pop3Username, Pop3Password, Pop3Server
    '    rsAccount.MoveNext
    'Loop

End Sub

'Display all E-Mail Data
Public Sub ShowMail()

  Dim lvItem As ListItem
  Dim rsMail As New ADODB.Recordset

    On Error Resume Next

      Me.lvAttachments.ListItems.Clear
      Me.lvMessages.ListItems.Clear

      'Query the Database and get all Mail Infos
      Set rsMail = Conn.Execute("Select * from mails")

      Do Until rsMail.EOF
          Set lvItem = lvMessages.ListItems.Add
          lvItem.Text = rsMail("From")
          lvItem.SubItems(1) = rsMail("Subject")
          lvItem.SubItems(2) = rsMail("Date")
          lvItem.SubItems(3) = rsMail("Size")
          lvItem.Tag = rsMail("id")
          rsMail.MoveNext
      Loop

End Sub

'Convert an String to HTML File
Public Sub TextToHTML(strInputMessage As String, strOutputFile As String, strTitle As String, strBgcolor As String, strTextcolor As String)

  Dim Newline As String

    Newline = Chr$(13) + Chr$(10)

    Open strOutputFile For Output As #2
    If strTitle = "" Then
        strTitle = "No Document Title"
    End If
    If strBgcolor = "" Then
        strBgcolor = "white"
    End If
    If strTextcolor = "" Then
        strTextcolor = "black"
    End If

    ' Replaces common symbols
    strInputMessage = Replace$(strInputMessage, "&", "&")
    strInputMessage = Replace$(strInputMessage, "<", "&lt;")
    strInputMessage = Replace$(strInputMessage, ">", "&gt;")
    strInputMessage = Replace$(strInputMessage, Chr$(34), "&quot;")
    strInputMessage = Replace$(strInputMessage, "