frmmail.frm

简单、实用、特别。 有很多不足之处

      Begin VB.Menu mnuFilePrint 
         Caption         =   "&Print..."
      End
      Begin VB.Menu mnuFilePageSetup 
         Caption         =   "Printer Page Setup"
      End
      Begin VB.Menu mnuFileBar3 
         Caption         =   "-"
      End
      Begin VB.Menu mnuFileMRU 
         Caption         =   ""
         Index           =   3
         Visible         =   0   'False
      End
      Begin VB.Menu mnuFileBar5 
         Caption         =   "-"
         Visible         =   0   'False
      End
      Begin VB.Menu mnuFileExit 
         Caption         =   "E&xit"
      End
   End
   Begin VB.Menu cmdAttachment 
      Caption         =   "&Attachment"
      Begin VB.Menu cmdAttachfile 
         Caption         =   "Attach file"
      End
   End
   Begin VB.Menu mnuEdit 
      Caption         =   "&Edit"
      Begin VB.Menu mnuEditCut 
         Caption         =   "Cu&t"
         Shortcut        =   ^X
      End
      Begin VB.Menu mnuEditCopy 
         Caption         =   "&Copy"
         Shortcut        =   ^C
      End
      Begin VB.Menu mnuEditPaste 
         Caption         =   "&Paste"
         Shortcut        =   ^V
      End
   End
   Begin VB.Menu mnuView 
      Caption         =   "&View"
      Begin VB.Menu mnuViewOptions 
         Caption         =   "&Options..."
      End
   End
   Begin VB.Menu format 
      Caption         =   "Format"
      Begin VB.Menu CheckBold 
         Caption         =   "Bold"
      End
      Begin VB.Menu CheckItalic 
         Caption         =   "Italic"
      End
      Begin VB.Menu CheckStrikeLine 
         Caption         =   "Strike Line"
      End
      Begin VB.Menu Line 
         Caption         =   "-"
      End
      Begin VB.Menu mHtmlMail 
         Caption         =   "Send Mail as HTML Mail"
      End
   End
End
Attribute VB_Name = "frmMail"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
' Win32 Declarations for Print sub
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Const WM_CUT = &H300
Const WM_COPY = &H301
Const WM_PASTE = &H302
Const WM_CLEAR = &H303
Const WM_USER = &H400
Const EM_CANUNDO = &HC6
Const EM_UNDO = &HC7

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type CharRange
    cpMin As Long     ' First character of range (0 for start of doc)
    cpMax As Long     ' Last character of range (-1 for end of doc)
End Type

Private Type FormatRange
    hdc As Long       ' Actual DC to draw on
    hdcTarget As Long ' Target DC for determining text formatting
    rc As RECT        ' Region of the DC to draw to (in twips)
    rcPage As RECT    ' Region of the entire DC (page size) (in twips)
    chrg As CharRange ' Range of text to draw (see above declaration)
End Type

Private Const EM_FORMATRANGE As Long = WM_USER + 57
Private Const PHYSICALOFFSETX As Long = 112
Private Const PHYSICALOFFSETY As Long = 113

Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long

Private ComDialog As New cmDlg
' *****************************************************************************
' Required declaration of the vbSendMail component (withevents is optional)
' You also need a reference to the vbSendMail component in the Project References
' *****************************************************************************
Private WithEvents poSendMail As clsSendMail
Attribute poSendMail.VB_VarHelpID = -1

Private bolHtmlMail As Boolean

Private Sub CheckBold_Click()

    CheckBold.Checked = Not CheckBold.Checked
    rtfMail.SelBold = CheckBold.Checked
    
If CheckBold.Checked = True Then
    mHtmlMail.Checked = True
    bolHtmlMail = True
Else
    mHtmlMail.Checked = False
    bolHtmlMail = False
End If

If CheckBold.Checked Then
    tbToolBar.Buttons("Bold").Value = tbrPressed
Else
    tbToolBar.Buttons("Bold").Value = tbrUnpressed
End If
End Sub

Private Sub CheckItalic_Click()

    CheckItalic.Checked = Not CheckItalic.Checked
    rtfMail.SelItalic = CheckItalic.Checked
    
If CheckItalic.Checked = True Then
    mHtmlMail.Checked = True
    bolHtmlMail = True
Else
    mHtmlMail.Checked = False
    bolHtmlMail = False
End If

If CheckItalic.Checked Then
    tbToolBar.Buttons("Italic").Value = tbrPressed
Else
    tbToolBar.Buttons("Italic").Value = tbrUnpressed
End If

End Sub

Private Sub CheckStrikeLine_Click()

    CheckStrikeLine.Checked = Not CheckStrikeLine.Checked
    rtfMail.SelUnderline = CheckStrikeLine.Checked
    
If CheckStrikeLine.Checked = True Then
    mHtmlMail.Checked = True
    bolHtmlMail = True
Else
    mHtmlMail.Checked = False
    bolHtmlMail = False
End If

If CheckStrikeLine.Checked Then
    tbToolBar.Buttons("Underline").Value = tbrPressed
Else
    tbToolBar.Buttons("Underline").Value = tbrUnpressed
End If


End Sub

Private Sub cmdAddFile_Click()

    On Error GoTo error

    With ComDialog

        .ShowOpen
        

        If Err = 0 Then

            If Trim(.FileName) <> "" Then

                lstAttachments.AddItem .FileName
              Else
error:
                Exit Sub
            End If
        End If

    End With

End Sub

Private Sub cmdAttachfile_Click()

    Call cmdAddFile_Click

End Sub

Private Sub cmdRemove_Click()

    On Error Resume Next

      lstAttachments.RemoveItem lstAttachments.ListIndex

End Sub

Private Sub FilePageSetup_Click()

End Sub

Private Sub Form_Activate()
Load_LastMail
End Sub

Private Sub Form_Load()

  'Initiate vbSendMail.cls

    Set poSendMail = New clsSendMail

End Sub

Private Sub Form_Unload(Cancel As Integer)

  ' *****************************************************************************
  ' Unload the component before quiting.
  ' *****************************************************************************

    Set poSendMail = Nothing
    Set ComDialog = Nothing
End Sub

Private Sub imgPrevious_Click()
PhoneBook.Show
End Sub

Private Sub lblPreviousQuery_Click()
PhoneBook.Show
End Sub

Private Sub lstAttachments_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)

  Dim Counter As Integer

    For Counter = 1 To Data.Files.Count
        If (GetAttr(Data.Files.Item(Counter)) And vbDirectory) = 0 Then lstAttachments.AddItem Data.Files.Item(Counter)
    Next Counter

End Sub

Private Sub mHtmlMail_Click()
    mHtmlMail.Checked = Not mHtmlMail.Checked
    bolHtmlMail = Not bolHtmlMail
End Sub

Private Sub mnuFilePrint_Click()

    PrintRTF rtfMail, 720, 720, 720, 720

End Sub

Private Sub mnuFileSave_Click()

  Dim strTemp As String

    On Error GoTo error

    With ComDialog
        On Error GoTo error

        .FileName = "Message.txt"
        .ShowSave

        If Err = 0 Then
            SaveStr2File strTemp, .FileName
        End If

    End With

Exit Sub

error:
    MsgBox "Sorry, can't save Message!"

End Sub

Private Sub newMail_Click()

  Dim c As Control

    'Clear all fields
    For Each c In Me.Controls
        If TypeOf c Is TextBox Then
            c.Text = ""
        End If
    Next c

    rtfMail.TextRTF = ""

    lstAttachments.Clear

End Sub

Private Sub SendMail_Click()

  Dim I As Integer
  Dim ulimit As Integer
  Dim m_strAttachedFiles As String
  Dim strTemp As String
  Dim c As Control

    On Error GoTo error

    'Error Handler
    If Me.txtTo = "" Then
        MsgBox "Please enter an E-Mail Address!"
        Exit Sub
    End If

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

    'Read all Attachments
    ulimit = lstAttachments.ListCount

    Select Case ulimit

      Case Is > 1
        For I = 0 To ulimit - 1
            
            m_strAttachedFiles = lstAttachments.List(I) + ";" + m_strAttachedFiles
        Next I
            'Cut the ; from the rest
            If Right$(m_strAttachedFiles, 1) = ";" Then
                m_strAttachedFiles = Left$(m_strAttachedFiles, Len(m_strAttachedFiles) - 1)
            End If
      Case 1
            I = 0
            m_strAttachedFiles = lstAttachments.List(I)