frmmail.frm

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

    End Select

    Me.Hide
    frmStatus.Show
    
    'Convert the mail from rtf to html
    
    If bolHtmlMail Then
        strTemp = rtfMail.TextRTF
        strTemp = rtf2html.rtf2html(strTemp, "+H")
    Else
        strTemp = rtfMail.Text
    End If
    
     Save_LastMail
   
    
    With poSendMail

        ' **************************************************************************
        ' Optional properties for sending email, but these should be set first
        ' if you are going to use them
        ' **************************************************************************

        .SMTPHostValidation = validate_none 'VALIDATE_HOST_DNS     ' Optional, default = VALIDATE_HOST_DNS
        .EmailAddressValidation = VALIDATE_SYNTAX   ' Optional, default = VALIDATE_SYNTAX
        .Delimiter = ";"                            ' Optional, default = ";" (semicolon)

        ' **************************************************************************
        ' Basic properties for sending email
        ' **************************************************************************
        .SMTPHost = frmOptions.txtServer            ' Required the fist time, optional thereafter
        .from = frmOptions.txtfromaddress           ' Required the fist time, optional thereafter
        .FromDisplayName = frmOptions.txtfromname   ' Optional, saved after first use
        .Recipient = Me.txtTo                       ' Required, separate multiple entries with delimiter character
        .Subject = Me.txtSubject                    ' Optional
        .Message = strTemp                  ' Optional
        .Attachment = Trim(m_strAttachedFiles)      ' Optional, separate multiple entries with delimiter character

        ' **************************************************************************
        ' Additional Optional properties, use as required by your application / environment
        ' **************************************************************************
        .AsHTML = bolHtmlMail                             ' Optional, default = FALSE, send mail as html or plain text
        .UseAuthentication = frmOptions.ckLogin.Value             ' Optional, default = FALSE
        .UsePopAuthentication = frmOptions.ckPopLogin.Value      ' Optional, default = FALSE
        .Username = frmOptions.txtUsername          ' Optional, default = Null String
        .Password = frmOptions.txtPassword                     ' Optional, default = Null String, value is NOT saved
        .POP3Host = frmOptions.txtPop3Server

        ' **************************************************************************
        ' OK, all of the properties are set, send the email...
        ' **************************************************************************
        .send                                       ' Required

    End With
    
   
    Unload frmStatus

Exit Sub

error:
    MsgBox "Sorry an error occurred while sending the mail!"

End Sub

Private Sub tbToolBar_ButtonClick(ByVal Button As MSComCtlLib.Button)

  

    On Error Resume Next
      Select Case Button.Key
        Case "New"
          newMail_Click
        Case "Open"
          mnuFileOpen_Click
        Case "Save"
          mnuFileSave_Click
        Case "Print"
          PrintRTF rtfMail, 720, 720, 720, 720
        Case "Cut"
          mnuEditCut_Click
        Case "Copy"
          mnuEditCopy_Click
        Case "Paste"
          mnuEditPaste_Click
        Case "Bold"
          CheckBold_Click
        Case "Italic"
          CheckItalic_Click
        Case "Underline"
            
          CheckStrikeLine_Click
        Case "Align Left"
          rtfMail.SelAlignment = rtfLeft
          rtfMail.SetFocus
          bolHtmlMail = False
          Me.mHtmlMail.Checked = False
        Case "Center"
          rtfMail.SelAlignment = rtfCenter
          rtfMail.SetFocus
          bolHtmlMail = True
          Me.mHtmlMail.Checked = True
        Case "Align Right"
          rtfMail.SelAlignment = rtfRight
          rtfMail.SetFocus
          bolHtmlMail = True
          Me.mHtmlMail.Checked = True
      End Select

End Sub

Private Sub mnuViewOptions_Click()

    frmOptions.Show vbModal, Me

End Sub









Private Sub mnuEditPaste_Click()

    rtfMail.SelText = Clipboard.GetText

End Sub

Private Sub mnuEditCopy_Click()

    If rtfMail.SelLength > 0 Then
        Clipboard.SetText rtfMail.SelText
    End If

End Sub

Private Sub mnuEditCut_Click()

    If rtfMail.SelLength > 0 Then
        Clipboard.Clear
        Clipboard.SetText rtfMail.SelText
        rtfMail.SelText = ""
    End If

End Sub



Private Sub mnuFileExit_Click()

  'unload the form

    Unload Me

End Sub

Private Sub mnuFilePageSetup_Click()

    On Error Resume Next
      With ComDialog
          .DialogTitle = "Page Setup"
          .CancelError = True
          .ShowPrinter
      End With

End Sub



Private Sub mnuFileOpen_Click()

  Dim sFile As String

    With ComDialog
        .DialogTitle = "Open"
        .CancelError = False
        'ToDo: set the flags and attributes of the common dialog control
        .Filter = "Import Message (*.*)|*.*"
        .ShowOpen
        If Len(.FileName) = 0 Then
            Exit Sub
        End If
        sFile = .FileName
        rtfMail.LoadFile sFile
    End With

End Sub

' *****************************************************************************
' The following four Subs capture the Events fired by the vbSendMail component
' *****************************************************************************

Private Sub poSendMail_Progress(lPercentCompete As Long)

  ' vbSendMail 'Progress Event'

    With frmMain
        .lstStatus.AddItem lPercentCompete
        .lstStatus.ListIndex = .lstStatus.ListCount - 1
        .lstStatus.ListIndex = -1
    End With

End Sub

Private Sub poSendMail_SendFailed(Explanation As String)

  ' vbSendMail 'SendFailed Event

    MsgBox ("Your attempt to send mail failed for the following reason(s): " & vbCrLf & Explanation)
    frmStatus.Hide

End Sub

Private Sub poSendMail_SendSuccesful()

  ' vbSendMail 'SendSuccesful Event'

    frmStatus.Hide
    Unload frmMail

End Sub

Private Sub poSendMail_Status(Status As String)

  ' vbSendMail 'Status Event'

    With frmMain
        .lstStatus.AddItem Status
        .lstStatus.ListIndex = .lstStatus.ListCount - 1
        .lstStatus.ListIndex = -1
    End With

    frmStatus.Status = Status

End Sub

Public Sub PrintRTF(RTF As RichTextBox, LeftMarginWidth As Long, TopMarginHeight, RightMarginWidth, BottomMarginHeight)

  '** Description:
  '** Print the active document

    On Error GoTo PrintError
  Dim LeftOffset As Long, TopOffset As Long
  Dim LeftMargin As Long, TopMargin As Long
  Dim RightMargin As Long, BottomMargin As Long
  Dim fr As FormatRange
  Dim rcDrawTo As RECT
  Dim rcPage As RECT
  Dim TextLength As Long
  Dim NextCharPosition As Long
  Dim r As Long

    ' Start a print job to get a valid Printer.hDC
    Printer.Print Space(1)
    Printer.ScaleMode = vbTwips

    ' Get the offsett to the printable area on the page in twips
    LeftOffset = Printer.ScaleX(GetDeviceCaps(Printer.hdc, PHYSICALOFFSETX), vbPixels, vbTwips)
    TopOffset = Printer.ScaleY(GetDeviceCaps(Printer.hdc, PHYSICALOFFSETY), vbPixels, vbTwips)

    ' Calculate the Left, Top, Right, and Bottom margins
    LeftMargin = LeftMarginWidth - LeftOffset
    TopMargin = TopMarginHeight - TopOffset
    RightMargin = (Printer.Width - RightMarginWidth) - LeftOffset
    BottomMargin = (Printer.Height - BottomMarginHeight) - TopOffset

    ' Set printable area rect
    rcPage.Left = 0
    rcPage.Top = 0
    rcPage.Right = Printer.ScaleWidth
    rcPage.Bottom = Printer.ScaleHeight

    ' Set rect in which to print (relative to printable area)
    rcDrawTo.Left = LeftMargin
    rcDrawTo.Top = TopMargin
    rcDrawTo.Right = RightMargin
    rcDrawTo.Bottom = BottomMargin

    ' Set up the print instructions
    fr.hdc = Printer.hdc   ' Use the same DC for measuring and rendering
    fr.hdcTarget = Printer.hdc  ' Point at printer hDC
    fr.rc = rcDrawTo            ' Indicate the area on page to draw to
    fr.rcPage = rcPage          ' Indicate entire size of page
    fr.chrg.cpMin = 0           ' Indicate start of text through
    fr.chrg.cpMax = -1          ' end of the text

    ' Get length of text in RTF
    TextLength = Len(RTF.Text)

    ' Loop printing each page until done
    Do
        ' Print the page by sending EM_FORMATRANGE message
        NextCharPosition = SendMessage(RTF.hwnd, EM_FORMATRANGE, True, fr)
        If NextCharPosition >= TextLength Then Exit Do  'If done then exit
        fr.chrg.cpMin = NextCharPosition ' Starting position for next page
        Printer.NewPage                  ' Move on to next page
        Printer.Print Space(1) ' Re-initialize hDC
        fr.hdc = Printer.hdc
        fr.hdcTarget = Printer.hdc
    Loop

    ' Commit the print job
    Printer.EndDoc

    ' Allow the RTF to free up memory
    r = SendMessage(RTF.hwnd, EM_FORMATRANGE, False, ByVal CLng(0))
PrintError:

End Sub

Public Sub SaveStr2File(strInput As String, strPathName As String)

  Dim iFreeFile As Integer

    '-----
    ' Reference to a free file
    '-----
    iFreeFile = FreeFile
    Open strPathName For Binary As iFreeFile
    '-----
    ' Save the total size of the array in a variable, this stops
    ' VB to calculate the size each time it comes into the loop,
    ' which of course, takes (much) more time then this sollution
    '-----

    Put iFreeFile, , strInput

    Close iFreeFile

End Sub

Private Sub Save_LastMail()
Dim MailNumber As Integer

If Not CheckExistence(txtTo, CStr(txtTo)) Then
    MailNumber = txtTo.ListCount
    If MailNumber > 10 Then MailNumber = 9
    SaveIni "Last Addresses", CStr(MailNumber), txtTo.Text
End If
End Sub

Private Sub Load_LastMail()
Dim Counter As Integer
Dim strTemp As String

'Load Last 10 Adresses
For Counter = 9 To 0 Step -1
    strTemp = LoadIni("Last Addresses", CStr(Counter))
    If strTemp <> "" Then
        txtTo.AddItem strTemp
    End If
Next

End Sub

':) Ulli's VB Code Formatter V2.12.7 (19.06.2002 23:12:58) 43 + 526 = 569 Lines