mailocx.ctl

企业ERP系统里的网络邮件处理模块

      Left            =   240
      Top             =   120
      Width           =   1455
   End
End
Attribute VB_Name = "MailOcx"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Attribute VB_Ext_KEY = "PropPageWizardRun" ,"Yes"
Option Explicit

Dim msg
Dim separator As String
Dim ifconnect As Boolean
Dim CvrP
'缺省属性值:

Const m_def_EmailAddress = "0"
Const m_def_ForeColor = 0
Const m_def_Enabled = 0
Const m_def_BackStyle = 0
Const m_def_BorderStyle = 0
Const m_def_smtpUsername = "0"
Const m_def_smtppassword = "0"
Const m_def_smtpservername = "0"
Const m_def_smtpport = 25
Const m_def_pop3username = "0"
Const m_def_pop3password = "0"
Const m_def_pop3servername = "0"
Const m_def_pop3port = 110
'属性变量:
Dim m_Recordset As New ADODB.Recordset


Dim m_EmailAddress As String
Dim m_ForeColor As Long
Dim m_Enabled As Boolean
Dim m_Font As Font
Dim m_BackStyle As Integer
Dim m_BorderStyle As Integer
Dim m_smtpUsername As String
Dim m_smtppassword As String
Dim m_smtpservername As String
Dim m_smtpport As Variant
Dim m_pop3username As String
Dim m_pop3password As String
Dim m_pop3servername As String
Dim m_pop3port As Long
'事件声明:
Event Click()
Attribute Click.VB_Description = "当用户在一个对象上按下并释放鼠标按钮时发生。"
Event DblClick()
Attribute DblClick.VB_Description = "当用户在一个对象上按下并释放鼠标按钮后再次按下并释放鼠标按钮时发生。"
Event KeyDown(KeyCode As Integer, Shift As Integer)
Attribute KeyDown.VB_Description = "当用户在拥有焦点的对象上按下任意键时发生。"
Event KeyPress(KeyAscii As Integer)
Attribute KeyPress.VB_Description = "当用户按下和释放 ANSI 键时发生。"
Event KeyUp(KeyCode As Integer, Shift As Integer)
Attribute KeyUp.VB_Description = "当用户在拥有焦点的对象上释放键时发生。"
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Attribute MouseDown.VB_Description = "当用户在拥有焦点的对象上按下鼠标按钮时发生。"
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Attribute MouseMove.VB_Description = "当用户移动鼠标时发生。"
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Attribute MouseUp.VB_Description = "当用户在拥有焦点的对象上释放鼠标发生。"
Private Sub SubWizard1_GotFocus()

End Sub

Private Sub Image1_Click()
    On Error GoTo Label1
    Dim item As ListItem
    Dim i As Integer
    If ifconnect Then
       MsgBox "Socket服务器已经处于连接状态！", vbExclamation, "Socket"
       Exit Sub
    End If
    picdemo.Visible = True
    DoEvents
'    MsgBox Me.pop3username
'    MsgBox CvrP.Decode(Me.pop3username)
    pop3.Connect CvrP.Decode(Me.pop3username), CvrP.Decode(Me.pop3password), CvrP.Decode(Me.pop3servername)
    ifconnect = True
   ' pop3.Connect "vbgaoshou", "visual", "www.163.net"
    frmsend.EmailAddress = CvrP.Decode(Me.EmailAddress)
    Set recordset1 = Me.Recordset
    maillist.ListItems.Clear
    For i = 1 To pop3.Messages.Count - 1
        Set msg = pop3.Messages.item(i)
        Set item = maillist.ListItems.Add
        item.Tag = i
        If msg.Priority = 1 Then
             item.SubItems(1) = "低"
        ElseIf msg.Priority = 3 Then
             item.SubItems(1) = "普"
        ElseIf msg.Priority = 5 Then
             item.SubItems(1) = "高"
        End If
        If msg.attachments.Count <> 0 Then
           item.SubItems(2) = "△"
           item.ListSubItems(2).ForeColor = vbBlue
        End If
       
        item.SubItems(3) = msg.FromName
        item.SubItems(4) = msg.Subject
        item.SubItems(5) = msg.Date
    Next i
     
    picdemo.Visible = False
   ' pop3.Disconnect
   ' Set pop3 = Nothing
    Exit Sub
Label1:
   picdemo.Visible = False
   MsgBox Err.Description
   If ifconnect Then
        pop3.Disconnect
        Set pop3 = Nothing
        ifconnect = False
   End If
End Sub

Private Sub Image2_Click()
If ifconnect Then
  pop3.Disconnect
  Set pop3 = Nothing
  ifconnect = False
  maillist.ListItems.Clear
End If
End Sub

Private Sub Image3_Click()
  Set frmcontact.rsMail = Me.Recordset
  frmcontact.Show 1
End Sub
Private Sub Label11_Click()

End Sub

Private Sub Label13_Click()
Dim i As Integer
Dim item As ListItem
   If maillist.ListItems.Count = 0 Then
      MsgBox "请先指定邮件对象!", vbExclamation + vbOKOnly, "Web邮件"
      Exit Sub
   End If


If MsgBox("是否确定删除?", vbQuestion + vbOKCancel, "Web邮件") = vbOK Then
i = 1
'For i = 1 To maillist.ListItems.Count
Do While i <= maillist.ListItems.Count
If maillist.ListItems(i).Checked = True Then
   pop3.DeleteSingleMessage maillist.ListItems(i).Tag
   maillist.ListItems.Remove i
   i = i - 1
End If
i = i + 1
Loop
'Next i

' maillist.ListItems.Clear
'    For i = 1 To pop3.Messages.Count - 1
'        Set msg = pop3.Messages.item(i)
'        Set item = maillist.ListItems.Add
'        item.Tag = i
'        If msg.Priority = 1 Then
'             item.SubItems(1) = "低"
'        ElseIf msg.Priority = 3 Then
'             item.SubItems(1) = "普"
'        ElseIf msg.Priority = 5 Then
'             item.SubItems(1) = "高"
'        End If
'        If msg.attachments.Count <> 0 Then
'           item.SubItems(2) = "△"
'           item.ListSubItems(2).ForeColor = vbBlue
'        End If
'
'        item.SubItems(3) = msg.FromName
'        item.SubItems(4) = msg.Subject
'        item.SubItems(5) = msg.Date
'    Next i

End If
End Sub

Private Sub Label6_Click()
  Set frmcontact.rsMail = Me.Recordset
  frmsend.smtpuser = CvrP.Decode(Me.smtpUsername)
  frmsend.smtppass = CvrP.Decode(Me.smtppassword)
  frmsend.smtpserver = CvrP.Decode(Me.smtpservername)
  frmsend.txtfrom = CvrP.Decode(Me.EmailAddress)
  frmsend.Show 1
End Sub

Private Sub Label7_Click()
If maillist.ListItems.Count = 0 Then
   MsgBox "请先指定邮件对象!", vbExclamation + vbOKOnly, "Web邮件"
   Exit Sub
End If
Call maillist_DblClick
End Sub

Private Sub Label8_Click()
If maillist.ListItems.Count = 0 Then
   MsgBox "请先指定邮件对象!", vbExclamation + vbOKOnly, "Web邮件"
   Exit Sub
End If
Set msg = pop3.Messages.item(maillist.SelectedItem.Tag)
With frmsend
    .smtpuser = CvrP.Decode(Me.smtpUsername)
    .smtppass = CvrP.Decode(Me.smtppassword)
    .smtpserver = CvrP.Decode(Me.smtpservername)
    .txtfrom.Text = CvrP.Decode(Me.EmailAddress)
    .txtto.Text = msg.From
    .txtsubject.Text = "Re:" & msg.Subject
    .rbody.Text = msg.Body & Chr(13)
    .Show 1
End With
End Sub

Private Sub Label9_Click()
Dim msg
Dim attachments
Dim at
Dim separator As String
Dim i  As Integer
   If maillist.ListItems.Count = 0 Then
      MsgBox "请先指定邮件对象!", vbExclamation + vbOKOnly, "Web邮件"
      Exit Sub
   End If

Set msg = pop3.Messages.item(maillist.SelectedItem.Tag)
With frmsend
  .smtpuser = CvrP.Decode(Me.smtpUsername)
  .smtppass = CvrP.Decode(Me.smtppassword)
  .smtpserver = CvrP.Decode(Me.smtpservername)
  .txtfrom.Text = CvrP.Decode(Me.EmailAddress)
  .txtsubject.Text = "FW:" & msg.Subject
  .rbody.Text = msg.Body & Chr(13)

Set attachments = msg.attachments
For i = 0 To attachments.Count - 1
   If i = attachments.Count - 1 Then
   separator = ""
   End If
   Set at = attachments(i)
   .smtp.attachments.Add msg.attachments(i)
   .txtatt.AddItem at.Name
   
Next i
  
  .Show 1
End With
End Sub

Private Sub maillist_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
  Dim j As Integer
  maillist.SortKey = ColumnHeader.Index - 1
  If maillist.SortOrder = lvwAscending Then
     maillist.SortOrder = lvwDescending
  Else
     maillist.SortOrder = lvwAscending
  End If
  maillist.Sorted = True
  
  If ColumnHeader.Position = 1 Then
     If ColumnHeader.Text = " " Then
        ColumnHeader.Text = "√"
        For j = 1 To maillist.ListItems.Count
            maillist.ListItems(j).Checked = True
        Next j
     Else
        ColumnHeader.Text = " "
        For j = 1 To maillist.ListItems.Count
            maillist.ListItems(j).Checked = False
        Next j
     End If
  End If
End Sub

Private Sub maillist_DblClick()
   On Error GoTo Label1
  ' Dim pop3 As New jmail.pop3
   Dim recc, reto As String
   Dim i As Integer
   Dim re, at
   If maillist.ListItems.Count = 0 Then
      MsgBox "请先指定邮件对象!", vbExclamation + vbOKOnly, "Web邮件"
      Exit Sub
   End If
   recc = ""
   reto = ""
  ' pop3.Connect "vbgaoshou", "visual", "www.163.net"
   Set msg = pop3.Messages.item(maillist.SelectedItem.Tag)
   frmnew.lblfrom.Caption = """" & msg.FromName & """" & " " & "<" & msg.From & ">"
   frmnew.lblsubject.Caption = msg.Subject
   Open App.Path & "\hj.htm" For Output As #1
   Print #1, msg.HTMLBody
   Close #1
   frmnew.rbody.Navigate2 App.Path & "\hj.htm"
   separator = ", "

   For i = 0 To msg.Recipients.Count - 1
        If i = msg.Recipients.Count - 1 Then
        separator = ""
        End If
   Set re = msg.Recipients.item(i)
   If re.ReType = 0 Then
      If Left(re.Name, 1) = "=" Then
      reto = reto & """" & re.EMail & """" & " " & "<" & re.EMail & ">" & separator
      Else
      reto = reto & """" & re.Name & """" & " " & "<" & re.EMail & ">" & separator
      End If
   Else
      If Left(re.Name, 1) = "=" Then
      recc = recc & """" & re.EMail & """" & " " & "<" & re.EMail & ">" & separator
      Else
      recc = recc & """" & re.Name & """" & " " & "<" & re.EMail & ">" & separator
      End If
   End If
   Next

   With frmnew
        .lblto.Caption = reto