chat.frm

可以把数据库中的记录以email的形式发送出去

'What happens when a connection is closed/terminated

    Select Case optHostGuest(0).Value
        Case True:  'Host closed Winsock
cmdConnect_Click    'Click the Disconnect button
cmdConnect_Click     'Click Listen button again for Listen Mode

MsgBox "Connection terminated by Guest. Server has been reset and awaiting a new client..."

        Case False: 'Guest closed Winsock


MsgBox "Connection terminated by Host..."

cmdConnect_Click     'Push the disconnect button to make offline
                    

    End Select

End Sub

Private Sub Winsock1_Connect()

    Select Case optHostGuest(0).Value
        
        Case True:  'Host got a connection

'I left this blank because the "CLIENT CONNECTED" msg
'is displayed below in the Winsock1_ConnectionRequest Sub
'along with the Call Online command

        Case False: 'Guest got a connection

Call Online
StatusBar1.Panels(2).Text = "CONNECTED TO HOST"
End Select

'Turn on and show Online Timer
FrameCounter.Visible = True
tmrClock.Enabled = True

End Sub

Private Sub Winsock1_ConnectionRequest(ByVal requestID As Long)

'When Host received a Connection Request...

If Winsock1.State <> sckClosed Then
    Winsock1.Close
Winsock1.LocalPort = txtPort.Text
Winsock1.Accept requestID 'accept the connection
Online
StatusBar1.Panels(2).Text = "CLIENT CONNECTED"

FrameCounter.Visible = True
tmrClock.Enabled = True

End If
End Sub

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)

'Get incoming chat data and put it in the Text Box
Dim Data As String
Winsock1.GetData Data 'gets the data
txtIncomingData.Text = txtIncomingData.Text + vbCrLf & Data
End Sub

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)
'What to do if an error occurs, this usually happens
'the Host is not Listening or your ISP is down
StatusBar1.Panels(2).Text = "WINSOCK ERROR: " & Err
cmdConnect_Click   'Push the disconnect button to reset

MsgBox "UNABLE TO CONNECT..."

End Sub

'#################### END CHAT SUBS ###############



'#################### SEND EMAIL SUBS #######################

Sub SendEmail(MailServerName As String, FromName As String, FromEmailAddress As String, ToName As String, ToEmailAddress As String, EmailSubject As String, EmailBodyOfMessage As String)
  On Error GoTo ErrorHandler
  
    Winsock2.LocalPort = 0 ' Must set local port to 0 (Zero) or you can only send 1 e-mail pre program start
    
If Winsock2.State = sckClosed Then ' Check to see if socet is closed
    DateNow = Format(Date, "Ddd") & ", " & Format(Date, "dd Mmm YYYY") & " " & Format(Time, "hh:mm:ss") & "" & " -0600"
    first = "mail from:" + Chr(32) + FromEmailAddress + vbCrLf ' Get who's sending E-Mail address
    Second = "rcpt to:" + Chr(32) + ToEmailAddress + vbCrLf ' Get who mail is going to
    Third = "Date:" + Chr(32) + DateNow + vbCrLf ' Date when being sent
    Fourth = "From:" + Chr(32) + FromName + vbCrLf ' Who's Sending
    Fifth = "To:" + Chr(32) + ToEmailAddress + vbCrLf ' Who it going to
    Sixth = "Subject:" + Chr(32) + EmailSubject + vbCrLf ' Subject of E-Mail
    Seventh = EmailBodyOfMessage + vbCrLf ' E-mail message body
    Ninth = "X-Mailer: EBT Reporter v 2.x" + vbCrLf ' What program sent the e-mail, customize this
    Eighth = Fourth + Third + Ninth + Fifth + Sixth  ' Combine for proper SMTP sending

    Winsock2.Protocol = sckTCPProtocol ' Set protocol for sending
    Winsock2.RemoteHost = MailServerName ' Set the server address
    Winsock2.RemotePort = 25 ' Set the SMTP Port
    Winsock2.Connect ' Start connection
   
    WaitFor ("220")
    
    StatusTxt.Caption = "Connecting...."
    StatusTxt.Refresh
    Winsock2.SendData ("HELO worldcomputers.com" + vbCrLf)

    WaitFor ("250")

    StatusTxt.Caption = "Connected"
    StatusTxt.Refresh
 ProgressBar1.Value = 25
    Winsock2.SendData (first)

    StatusTxt.Caption = "Sending Message"
    StatusTxt.Refresh

    WaitFor ("250")

    Winsock2.SendData (Second)

    WaitFor ("250")
 ProgressBar1.Value = 50

    Winsock2.SendData ("data" + vbCrLf)
    
    WaitFor ("354")


    Winsock2.SendData (Eighth + vbCrLf)
    Winsock2.SendData (Seventh + vbCrLf)
    Winsock2.SendData ("." + vbCrLf)

    WaitFor ("250")
 ProgressBar1.Value = 75
    Winsock2.SendData ("quit" + vbCrLf)
     ProgressBar1.Value = 100
    StatusTxt.Caption = "Disconnecting"
    StatusTxt.Refresh

    WaitFor ("221")

    Winsock2.Close
     ProgressBar1.Value = 0
Else
    MsgBox (Str(Winsock2.State))
End If
ErrorHandler:
 ProgressBar1.Value = 0
End Sub
Sub WaitFor(ResponseCode As String)
    start = Timer ' Time event so won't get stuck in loop
    While Len(Response) = 0
        Tmr = start - Timer
        DoEvents ' Let System keep checking for incoming response **IMPORTANT**
        If Tmr > 50 Then ' Time in seconds to wait
            MsgBox "SMTP service error, timed out while waiting for response", 64
            Exit Sub
        End If
    Wend
    While Left(Response, 3) <> ResponseCode
        DoEvents
        If Tmr > 50 Then
            MsgBox "SMTP service error, impromper response code. Code should have been: " + ResponseCode + " Code recieved: " + Response, 64
            Exit Sub
        End If
    Wend
Response = "" ' Sent response code to blank **IMPORTANT**
End Sub

Private Sub winsock2_DataArrival(ByVal bytesTotal As Long)

    Winsock2.GetData Response ' Check for incoming response *IMPORTANT*

End Sub


'##################### END SEND EMAIL SUBS ###############


'##################### BEGIN CHECK EMAIL SUBS ############

Private Sub chkLogStatus_Click()

'Update the state variable based on the
'value of the check box
If chkLogStatus.Value = vbChecked Then
    mbLogStatus = True
Else
    mbLogStatus = False
End If
End Sub

Private Sub ShowSocketState()

Dim sTempStr As String
Dim nListCount As Integer
Dim nLoopCtr As Integer

'Check state of port status logging
'If disabled, then exit from this sub
If mbLogStatus = False Then Exit Sub

'Build a string containing the current socket status
sTempStr = "Socket State: " & vbTab & mvntSocketState(Winsock3.State)

'Add the string to the list box
lstStatus.AddItem sTempStr

'Get the index position where the item was added
nListCount = lstStatus.NewIndex

If nListCount > MAX_LIST_ITEMS Then
    'Clean out old list entries
    For nLoopCtr = nListCount - MAX_LIST_ITEMS To 0 Step -1
        lstStatus.RemoveItem nLoopCtr
        Next nLoopCtr
        nListCount = lstStatus.ListCount - 1
        End If
        
'Position at the last item on the list
lstStatus.ListIndex = nListCount

End Sub

Private Sub Winsock3_Close()

'Update the connection status in the list box
Call ShowSocketState

End Sub

Private Sub Winsock3_Connect()

'Update the connection status in the list box
Call ShowSocketState

End Sub

Private Sub Winsock3_ConnectionRequest(ByVal requestID As Long)

'This event should never occur because this program
'does not listen on any port

'Show the connection Request ID
If mbLogStatus = True Then
    lstStatus.AddItem "Unexpected Connection Request"
End If

' The connection is refused by not accepting it

'Update the connection status in the list box
Call ShowSocketState

End Sub

Private Sub Winsock3_DataArrival(ByVal bytesTotal As Long)

Dim sData As String

'Get the inbound data from the socket
Winsock3.GetData sData, vbString, bytesTotal

'Show the data and its length in the list box
If mbLogStatus = True Then
    lstStatus.AddItem "Data Value:  " & vbTab & sData
    lstStatus.AddItem "Data Length:  " & vbTab & bytesTotal
End If

'Move the data into the form scope command variable
msCommand = Left$(sData, bytesTotal - 2)

'Let other code know we got data
mbGotData = True

'Update the connection status in the list box
Call ShowSocketState

End Sub

Private Sub Winsock3_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)
    
'Show the error details
lstStatus.AddItem "Error Number: " & vbTab & Number
lstStatus.AddItem " Error Text: " & vbTab & Description

'Update the connection status in the list box
Call ShowSocketState
    
End Sub

Private Sub Winsock3_SendComplete()

'Show that the send was completed
If mbLogStatus = True Then
    lstStatus.AddItem "Send Complete"
End If

'Update the connection status in the list box
Call ShowSocketState

End Sub


Private Sub POP3CheckMail()

Dim sUserName
Dim sPassword
Dim bResult


'Get the username and password
sUserName = txtUser.Text
sPassword = txtPassword.Text

'Set the message count variable to indicate
'a failure to get the info.  Also clear the
'variable holding message character length.
mnMessageCount = -1
mlMessageChars = 0

'Set the flag to wait for connections to open
'and the initial server reply to arrive
mbGotData = False

Winsock3.Close
Winsock3.Connect txtServer.Text, txtPOP3Port.Text


'Now wait for the server reply
Do Until mbGotData = True
    DoEvents
Loop
ProgressBar1.Value = 20
'Send username
bResult = POP3SendString("USER " & sUserName)
'Check for errors
If bResult = False Then GoTo CheckExitPoint
ProgressBar1.Value = 40
'Send the password
bResult = POP3SendString("PASS " & sPassword)
ProgressBar1.Value = 60
'Check for errors
If bResult = False Then GoTo CheckExitPoint

'Request the Mailbox Status
bResult = POP3SendString("STAT")
'Check for errors
If bResult = False Then GoTo CheckExitPoint
ProgressBar1.Value = 80
'Tell the POP3 Server we are done
bResult = POP3SendString("QUIT")
ProgressBar1.Value = 100
CheckExitPoint:
    'Close the port
    Winsock3.Close
    ProgressBar1.Value = 0
'Display the message info or an error
Select Case mnMessageCount
    Case 0
        MsgBox "There are no messages waiting on the server..."
    
    Case 1
        MsgBox "There is one message waiting on the server. It is " & mlMessageChars & " bytes in size."
        
    Case -1
        MsgBox "An error occured getting message from the server."
        
    Case Else
        'There is more than one message waiting so show the info
        MsgBox "There are " & mnMessageCount & " messages on the server. They are " & mlMessageChars & " total bytes in size."
        
End Select
        
End Sub

Private Function POP3SendString(sCommand As String) As Boolean

Dim sActiveCommand As String
Dim sWorkStr As String
Dim nCharLoc As String

'This routine checks the command to ensure it is the program
'it designed to parse
sActiveCommand = Left$(UCase(Trim$(sCommand)), 4)
Select Case sActiveCommand
    Case "USER", "PASS", "STAT", "QUIT"
    'Valid command, so just display it
    If sActiveCommand = "PASS" Then
    'Don't show the password itself
    lstStatus.AddItem "Server Command: PASS ********"
    Else
    'Otherwise, show the whole command
    lstStatus.AddItem "Server Command: " & sCommand
    End If
    
    Case Else
    'This is a command we are not set up to parse
    MsgBox "Unhandled POP3 command detected: " & sCommand
    Exit Function
    
End Select
    
'Set the flag to wait for the data from the server
mbGotData = False

'Send the string to the POP3 server
Winsock3.SendData sCommand & vbCrLf  'vbCrLf is the Enter button on keyboard

'Wait for the data to get here. Data is stored
'in the msCommand from-scope variable
Do Until mbGotData = True
    DoEvents
    Loop
    
'Parse the data in the reply from the server
'White space is removed and the string is uppercased
'to make the command parsing simpler
Select Case Left$(Trim$(UCase$(msCommand)), 3)
    Case "+OK"  'Command accepted
    'Parse the command specific replies
Select Case sActiveCommand
    Case "USER" 'Name is valid
    Case "PASS"  'Password is accepted
    Case "STAT"
        'Add the reply data to the list box
        lstStatus.AddItem "Server Reply: " & msCommand
        'Parse out the message count and size
        'Start by removing the "+OK " string
        sWorkStr = Right$(msCommand, Len(msCommand) - 4)
        
        'Now find the space that delimits the
        'message count and bytes size data
        nCharLoc = InStr(1, sWorkStr, " ")
        'Now extract the two values
        mnMessageCount = CInt(Mid$(sWorkStr, 1, nCharLoc - 1))
        mlMessageChars = CLng(Mid$(sWorkStr, nCharLoc + 1))
        
    Case "QUIT"  'Ready to disconnect
    
End Select

POP3SendString = True  'Return success

Case "-ER"  'Got an error
    'Add the error info to the list box
    lstStatus.AddItem "Error with command: " & sActiveCommand
    
    POP3SendString = False  'Return failure
    
Case Else    'Unexpected data from the server
    'Update the list box
    lstStatus.AddItem "Unexpected data from POP3 server."
    lstStatus.AddItem "Data: " & msCommand
    
    POP3SendString = False   'Return failure
    
End Select

End Function