frmmain.frm

自动检查邮件

End Sub

Private Sub Form_Load()
  If App.PrevInstance Then End
  Call InitializeSettings
End Sub

Sub InitializeSettings()
  Set DB = OpenDatabase(App.Path & "\ConsoleData.mdb")
  Call LoadSettings
  Call LoadBackground
  Call LoadEmailAccounts
  
  lvwEmail.ColumnHeaders(1).Width = 1621.5
  lvwEmail.ColumnHeaders(2).Width = 2342.5
  lvwEmail.ColumnHeaders(3).Width = 1081
  fraEmail.Move 0, 0, 5495, 2425
  fraSettings.Move 0, 0, 5495, 2425
  
  Call CreateSystemTrayIcon(Me, "邮件自动检测工具")
  
  Dim tempString As String
  Dim Spot As Integer
  tempString = GetSetting("AllSeeingEye", "Settings", "Position")
  Spot = InStr(1, tempString, ",")
  If tempString <> "" Then
    Left = Val(Left$(tempString, Spot - 1))
    Top = Val(Mid$(tempString, Spot + 1))
  Else
    Top = Screen.Height - (Height + 900)
    Left = Screen.Width - Width
  End If
End Sub

Sub LoadBackground()
  If GetSetting("AllSeeingEye", "Settings", "BGColor") <> "" Then
    BackColor = Val(GetSetting("AllSeeingEye", "Settings", "BGColor"))
  End If

  Dim X As Control
  For Each X In Me
    If TypeOf X Is Frame Or TypeOf X Is CheckBox Then X.BackColor = BackColor
  Next
End Sub

Sub LoadEmailAccounts()
  lvwEmail.ListItems.Clear
  Dim lstItem As ListItem
  Dim X As Integer
  For X = Winsock1.UBound To 0 Step -1
    If X <> 0 Then Unload Winsock1(X)
  Next
  
  ReDim m_Server(0)
  ReDim m_User(0)
  ReDim m_Password(0)
  ReDim m_State(0)
  ReDim m_Title(0)
  ReDim m_Ready(0)
  m_Ready(0) = True
  
  Dim RS As Recordset
  Set RS = DB.OpenRecordset("Select * From EmailAccounts Order by Name Asc")
  If RS.RecordCount = 0 Then
    tmrCheckMail.Enabled = False
    cmdDeleteAccount.Enabled = False
    cmdCheckMail.Enabled = False
    lblEdit = "添加帐号后开始"
    FirstRun = True
    Exit Sub
  Else
    cmdDeleteAccount.Enabled = True
    cmdCheckMail.Enabled = True
    lblEdit = "双击编辑"
  End If
  X = 0
  
  RS.MoveFirst
  Do While Not RS.EOF
    If X <> 0 Then
      ReDim Preserve m_Server(X)
      ReDim Preserve m_User(X)
      ReDim Preserve m_Password(X)
      ReDim Preserve m_Ready(X)
      ReDim Preserve m_State(X)
      ReDim Preserve m_Title(X)
      m_Ready(X) = True
    End If
    
    m_Server(X) = RS!Server
    m_User(X) = RS!User
    m_Password(X) = Decrypt(RS!Password)
    m_Title(X) = RS!Name
    
    Set lstItem = lvwEmail.ListItems.Add(, "帐号:" & X, RS!Name)
    lstItem.SubItems(1) = " "
    lstItem.SubItems(2) = " "
    lstItem.Tag = RS!ID
    
    X = X + 1
    RS.MoveNext
  Loop
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  If (X / Screen.TwipsPerPixelX) = STI_LBUTTONUP Then
    WindowState = vbNormal
    Visible = True
    Me.SetFocus
    inTray = False
  End If
End Sub

Private Sub Form_Resize()
  If WindowState = vbMinimized Then
    Me.Hide
    inTray = True
  End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
  Call SaveSetting("AllSeeingEye", "Settings", "Position", Left & ", " & Top)
  Call DeleteSystemTrayIcon(Me)
End Sub

Private Sub lvwEmail_DblClick()
  Dim I As Integer
  I = Val(Mid$(lvwEmail.SelectedItem.Key, 9))
  CurrAccount = Val(lvwEmail.SelectedItem.Tag)
  
  txtTitle = m_Title(I)
  txtUsername = m_User(I)
  txtPassword = m_Password(I)
  txtServer = m_Server(I)
  
  fraEmail.Visible = True
  lblHeading = "编辑帐号:"
  DoEvents
  txtTitle.SetFocus
End Sub

Private Sub Picture1_Click()
  CD1.CancelError = True
  On Error GoTo Err:
  
  CD1.ShowColor
  Picture1.BackColor = CD1.Color
  fraSettings.BackColor = CD1.Color
  chkSound.BackColor = CD1.Color
  chkNotify.BackColor = CD1.Color
  
Err:
End Sub

Private Sub tmrCheckMail_Timer()
  cmdCheckMail.Enabled = False
  Dim X As Integer
  For X = 0 To UBound(m_User)
    DoCheckMail (X)
    Do Until m_Ready(X)
      DoEvents
    Loop
    Pause 0.5
  Next
  cmdCheckMail.Enabled = True
  
  Dim Sum As Integer
  Dim Size As Double
  For X = 1 To lvwEmail.ListItems.Count
    Sum = Sum + Val(lvwEmail.ListItems(X).SubItems(1))
    Size = Size + Val(lvwEmail.ListItems(X).SubItems(2))
  Next

  Call SendNotify(Sum, Size)

End Sub


Sub SendNotify(Sum As Integer, Size As Double)
  
  Dim Text As String
  If Sum = 1 Then
    Text = "1 个电子邮件, 计:" & Size & " KB"
  Else
    Text = Sum & " 封电子邮件, 计:" & Size & " KB"
  End If
  Call ModifySystemTrayIcon(Me, "电子邮件自动检查工具" & vbCrLf & Text)
  
  If Sum > LastSum Then
    If chkNotify.Value = 1 And inTray Then Call ShowMessagesWindow(Text)
    If chkSound.Value = 1 Then PlaySound (App.Path & "\newalert.wav")
  End If
  LastSum = Sum
  
End Sub

Sub ShowMessagesWindow(Text As String)
  Set New1 = New FrmMSNPopUp
  New1.SetNumber 450
  New1.LblText.Caption = "邮件自动检测工具"
  New1.LblMessage.Caption = Replace(Text, ", ", vbCrLf & vbCrLf)
  'New1.LblOptions.Caption = TxtOptions.Text
  New1.Visible = True
End Sub

Private Sub txtPassword_GotFocus()
  txtPassword.SelStart = 0
  txtPassword.SelLength = Len(txtPassword)
End Sub

Private Sub txtPassword_KeyPress(KeyAscii As Integer)
  If KeyAscii = 13 Then
    cmdSave.SetFocus
    KeyAscii = 0
  End If
End Sub


Private Sub txtSeconds_LostFocus()
  txtSeconds = Val(txtSeconds)
End Sub

Private Sub txtServer_GotFocus()
  txtServer.SelStart = 0
  txtServer.SelLength = Len(txtServer)
End Sub

Private Sub txtServer_KeyPress(KeyAscii As Integer)
  If KeyAscii = 13 Then
    txtUsername.SetFocus
    KeyAscii = 0
  End If
End Sub

Private Sub txtTitle_GotFocus()
  txtTitle.SelStart = 0
  txtTitle.SelLength = Len(txtTitle)
End Sub

Private Sub txtTitle_KeyPress(KeyAscii As Integer)
  If KeyAscii = 13 Then
    txtServer.SetFocus
    KeyAscii = 0
  End If
End Sub

Private Sub txtUsername_GotFocus()
  txtUsername.SelStart = 0
  txtUsername.SelLength = Len(txtUsername)
End Sub

Private Sub txtUsername_KeyPress(KeyAscii As Integer)
  If KeyAscii = 13 Then
    txtPassword.SetFocus
    KeyAscii = 0
  End If
End Sub

Private Sub Winsock1_DataArrival(Index As Integer, ByVal bytesTotal As Long)
  
  Dim strData               As String
  Dim Spot                  As Integer
  Dim Username              As String
  Dim Password              As String
  Dim lIndex                As Integer
  Static intMessages        As Integer
  Static intCurrentMessage  As Integer
  Static strBuffer          As String
  Static TotalSize          As Long
  Static TotalSize2         As Long
  Dim EmailNum              As Long
  
  On Error Resume Next
   
  Spot = InStr(1, Winsock1(Index).Tag, "|")
  Username = Left(Winsock1(Index).Tag, Spot - 1)
  Password = Mid(Winsock1(Index).Tag, Spot + 1)
  
  Winsock1(Index).GetData strData
  
  If Left$(strData, 1) = "+" Or m_State(Index) = POP3_TOP Then
    Select Case m_State(Index)
      Case POP3_Connect
        intMessages = 0
        intCurrentMessage = 0
        m_State(Index) = POP3_USER
        Winsock1(Index).SendData "USER " & Username & vbCrLf
        DoEvents
      Case POP3_USER
        m_State(Index) = POP3_PASS
        Winsock1(Index).SendData "PASS " & Password & vbCrLf
        DoEvents
      Case POP3_PASS
        m_State(Index) = POP3_STAT
        Winsock1(Index).SendData "STAT" & vbCrLf
        DoEvents
      Case POP3_STAT
        intMessages = Get_After_Seperator(strData, 1, " ")
        TotalSize = Get_After_Seperator(strData, 2, " ")
        
        If intMessages = 1 Then
          lvwEmail.ListItems(Index + 1).SubItems(1) = "1 封邮件"
        Else
          lvwEmail.ListItems(Index + 1).SubItems(1) = intMessages & " 封邮件"
        End If
        lvwEmail.ListItems(Index + 1).SubItems(2) = Format(TotalSize / 1000, "0.00") & " KB"
                
        DoEvents
        If intMessages = 0 Then
          Winsock1(Index).SendData "QUIT" & vbCrLf
          DoEvents
          m_Ready(Index) = True
          Exit Sub
        End If
        
        Winsock1(Index).SendData "QUIT" & vbCrLf
        DoEvents
        m_State(Index) = POP3_QUIT
        m_Ready(Index) = True
      Case POP3_QUIT
        Winsock1(Index).Close
        Call DisconnectMe(Index)
        m_Ready(Index) = True
    End Select
  Else
    Winsock1(Index).Close
    lvwEmail.ListItems(Index + 1).SubItems(1) = "错误"
    m_Ready(Index) = True
  End If
End Sub

Private Sub Winsock1_Error(Index As Integer, ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
    
  If Number = 10053 Then
    lvwEmail.ListItems("帐号:" & Index).SubItems(1) = "错误"
    Winsock1(Index).Close
    Exit Sub
  End If
  
  Winsock1(Index).Close
  m_Ready(Index) = True
    
End Sub

Public Sub DisconnectMe(Index As Integer)
  On Error Resume Next
  Winsock1(Index).SendData "QUIT" & vbCrLf
  DoEvents
  m_Ready(Index) = True
  DoEvents
End Sub

Sub DeleteEmailAccount(ID As Integer)
  DB.Execute ("Delete From EmailAccounts Where ID=" & ID)
End Sub