frmemail.frm

企业人事管理系统,有考勤,人员管理等功能,值得研究,也是我付费弄来的,绝对超值

  frmAddress.Show vbModal
End Sub

Private Sub cmdExit_Click()
 Unload Me
End Sub

Private Sub cmdFrom_Click()
    frmAddress.blnTo = False
    frmAddress.Show vbModal
End Sub

Private Sub cmdGetSetting_Click()
  Dim fso As FileSystemObject
  Dim fld As Folder
  Dim fl As File
  Dim stm As TextStream
  Dim strFilePath As String
  Dim m As String
  
  Set fso = New FileSystemObject
  strFilePath = App.path & "\EMAILSET.txt"
   If fso.FileExists(strFilePath) = False Then
          'Set stm = fso.CreateTextFile(strFilePath)
    Exit Sub
   End If
   Set stm = fso.OpenTextFile(strFilePath, ForReading)
    'txtMessage = stm.ReadAll
       txtTo = stm.ReadLine
       txtHost = stm.ReadLine
       txtFrom = stm.ReadLine
       'txtPwd = stm.ReadLine
       txtSubject = stm.ReadLine
    Do While Not stm.AtEndOfStream
       m = stm.ReadLine
       txtMessage = txtMessage & m & vbCrLf
    Loop
    stm.Close
    Set stm = Nothing
    Set fso = Nothing
    txtStatus = "文件已经存取"
End Sub

Private Sub cmdNew_Click()
   txtTo.Text = ""
   txtSubject = ""
   txtMessage = ""
End Sub

Private Sub cmdSaveSetting_Click()
  Dim fso As FileSystemObject
  Dim fld As Folder
  Dim fl As File
  Dim stm As TextStream
  Dim strFilePath As String
  Dim strSave As String
  
  Set fso = New FileSystemObject
  strFilePath = App.path & "\EMAILSET.txt"
  
   If fso.FileExists(strFilePath) = False Then
          Set stm = fso.CreateTextFile(strFilePath, False)
   Else
      Set stm = fso.OpenTextFile(strFilePath, ForWriting)
   End If

   strSave = strSave & txtTo & vbCrLf
   strSave = strSave & txtHost & vbCrLf
   strSave = strSave & txtFrom & vbCrLf
   strSave = strSave & txtSubject & vbCrLf
   strSave = strSave & txtMessage
   stm.Write strSave
   stm.Close
   Set stm = Nothing
    Set fso = Nothing
    
    txtStatus = "文件已经保存"
End Sub

Private Sub cmdSend_Click()
  cmdSend.Enabled = False
  cmdNew.Enabled = False
  cmdSaveSetting.Enabled = False
  cmdGetSetting.Enabled = False
  
  Winsock1.Connect Trim(txtHost), 25
  m_State = MAIL_CONNECT
End Sub


Private Sub Form_Load()
 Call cmdGetSetting_Click
End Sub

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
  Dim strServerResponse As String
  Dim strResponseCode As String
  Dim strDataToSend As String


  
  Winsock1.GetData strServerResponse
  strResponseCode = Left(strServerResponse, 3)
 
   If strResponseCode = "250" Or _
       strResponseCode = "220" Or _
       strResponseCode = "354" Or _
       strResponseCode = "334" Or _
       strResponseCode = "221" Or _
       strResponseCode = "235" Then
        Select Case m_State
            Case MAIL_CONNECT
                m_State = MAIL_HELO
                strDataToSend = Trim$(txtFrom)
                 Winsock1.SendData "HELO " & strDataToSend & vbCrLf
                 txtStatus = "登陆服务器"
            Case MAIL_HELO
                 m_State = MAIL_USER
                 Winsock1.SendData "AUTH LOGIN" & vbCrLf
                 txtStatus = "正在校验用户名"
            Case MAIL_USER
                 m_State = MAIL_PASS
                 Winsock1.SendData (Base64_Encode(getUserName(txtFrom))) & vbCrLf
                 txtStatus = "校验用户密码"
            Case MAIL_PASS
                 m_State = MAIL_LOGIN
                 Winsock1.SendData (Base64_Encode(txtPWD.Text)) & vbCrLf
                 txtStatus = "发送人邮件地址"
            Case MAIL_LOGIN
                 m_State = MAIL_FROM
                 Winsock1.SendData "MAIL FROM:" & Trim$(txtFrom) & vbCrLf
                 txtStatus = "接收人邮件地址"
            Case MAIL_FROM
                 m_State = MAIL_RCPTTO
                 Winsock1.SendData "RCPT TO:" & Trim$(txtTo) & vbCrLf
                 txtStatus = "邮件发送之中..."
            Case MAIL_RCPTTO
                 m_State = MAIL_DATA
                 Winsock1.SendData "DATA" & vbCrLf
                 txtStatus = "获取邮件内容"
            Case MAIL_DATA
                  m_State = MAIL_DOT
                
           
                  Dim strSubject As String
                   Dim strLines As Variant
                   Dim strLine As Variant
                   
                Winsock1.SendData "From:" & getUserName(txtFrom) & " <" & txtFrom & ">" & vbCrLf
                Winsock1.SendData "To:" & getUserName(txtTo) & " <" & txtTo & ">" & vbCrLf
                 
                 strSubject = Trim(txtSubject)
                 Winsock1.SendData "Subject:" & strSubject & vbLf & vbCrLf
                 
                            
  
                 strMessage = txtMessage
                 '发送正文
                 strLines = Split(strMessage, vbCrLf)
                 strMessage = ""
                 
                 For Each strLine In strLines
                    Winsock1.SendData strLine & vbLf
                 Next
                
               
                Winsock1.SendData "." & vbCrLf
                txtStatus = "邮件送完毕"
            Case MAIL_DOT
                m_State = MAIL_QUIT
                Winsock1.SendData "QUIT" & vbCrLf
                txtStatus = "邮件成功发送!!!"
                MsgBox "邮件发送成功"
              Case MAIL_QUIT
                 Winsock1.Close
                 txtStatus = "发送完毕..."
                 Call cmdEnabled
         End Select
    Else
         Winsock1.Close
         txtStatus = "发送错误"
          MsgBox "发送错误:" & strServerResponse
           Call cmdEnabled
    End If
   
   
   
End Sub

Private Sub cmdEnabled()
  cmdSend.Enabled = True
  cmdNew.Enabled = True
  cmdSaveSetting.Enabled = True
  cmdGetSetting.Enabled = True
End Sub


Private Function getUserName(strDataToSend As String)
  Dim strUser As String
  strUser = Left(strDataToSend, InStr(1, strDataToSend, "@") - 1)
  getUserName = strUser
End Function


Private Sub Winsock1_Error(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)
  MsgBox "Winsock Error" & number
  
End Sub

Private Function Base64_Encode(strSource) As String 'base6加密算法
    Const BASE64_TABLE As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
    Dim strTempLine As String
    Dim j As Integer
    For j = 1 To (Len(strSource) - Len(strSource) Mod 3) Step 3
        strTempLine = strTempLine + Mid(BASE64_TABLE, (Asc(Mid(strSource, j, 1)) \ 4) + 1, 1)
        strTempLine = strTempLine + Mid(BASE64_TABLE, ((Asc(Mid(strSource, j, 1)) Mod 4) * 16 _
                      + Asc(Mid(strSource, j + 1, 1)) \ 16) + 1, 1)
        strTempLine = strTempLine + Mid(BASE64_TABLE, ((Asc(Mid(strSource, j + 1, 1)) Mod 16) * 4 _
                      + Asc(Mid(strSource, j + 2, 1)) \ 64) + 1, 1)
        strTempLine = strTempLine + Mid(BASE64_TABLE, (Asc(Mid(strSource, j + 2, 1)) Mod 64) + 1, 1)
    Next j
    If Not (Len(strSource) Mod 3) = 0 Then
         If (Len(strSource) Mod 3) = 2 Then
            strTempLine = strTempLine + Mid(BASE64_TABLE, (Asc(Mid(strSource, j, 1)) \ 4) + 1, 1)
            strTempLine = strTempLine + Mid(BASE64_TABLE, (Asc(Mid(strSource, j, 1)) Mod 4) * 16 _
                      + Asc(Mid(strSource, j + 1, 1)) \ 16 + 1, 1)
             strTempLine = strTempLine + Mid(BASE64_TABLE, (Asc(Mid(strSource, j + 1, 1)) Mod 16) * 4 + 1, 1)
            strTempLine = strTempLine & "="
        ElseIf (Len(strSource) Mod 3) = 1 Then
            strTempLine = strTempLine + Mid(BASE64_TABLE, Asc(Mid(strSource, j, 1)) \ 4 + 1, 1)
            strTempLine = strTempLine + Mid(BASE64_TABLE, (Asc(Mid(strSource, j, 1)) Mod 4) * 16 + 1, 1)
             strTempLine = strTempLine & "=="
        End If
     End If
    Base64_Encode = strTempLine
End Function
 





 
Private Sub txtMessage_Change()

End Sub