chat.frm

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

         Width           =   375
      End
   End
   Begin VB.Menu mnuFile 
      Caption         =   "&File"
      Begin VB.Menu mnuExit 
         Caption         =   "E&xit"
      End
   End
   Begin VB.Menu mnuOptions 
      Caption         =   "&Colors"
      Begin VB.Menu mnuColor 
         Caption         =   "Background Color"
      End
      Begin VB.Menu mnuFrameColor 
         Caption         =   "Frame Background Colors"
      End
      Begin VB.Menu mnuFrameCapColor 
         Caption         =   "Frame Caption Color"
      End
   End
   Begin VB.Menu mnuHelp 
      Caption         =   "&Help"
      Begin VB.Menu mnuHelpContents 
         Caption         =   "Contents"
         HelpContextID   =   10
      End
      Begin VB.Menu mnuAbout 
         Caption         =   "&About"
      End
   End
End
Attribute VB_Name = "frmChat"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'Written by Michael Sharp (aka Mike D.) [e-mail]

'Notes:
'In case you can't figure out how I got all the images
'to change, depending on the connection status, I have 4
'different images laid on top of each other (imgConnecting,
'imgOnline, imgOffline, imgConnecting (you can move
'them around on the form layout to see))

'Chat variables
Dim IP As String
Dim s As Integer
Dim m As Integer

'Utilities: Send Email variables
Dim Response As String, Reply As Integer, DateNow As String
Dim first As String, Second As String, Third As String
Dim Fourth As String, Fifth As String, Sixth As String
Dim Seventh As String, Eighth As String, Ninth As String
Dim start As Single, Tmr As Single

'Utilities: Check Email variables

Option Explicit

'Constant used to limit the number of list
'box items before removing the oldest
Private Const MAX_LIST_ITEMS = 100

'Variables to store waiting message information
Private mnMessageCount As Integer
Private mlMessageChars As Long

'This variable hold the most recent command
'that was sent to the POP3 Server
Private msCommand As String

'State of the Log Port Status Check Box
Private mbLogStatus As Boolean

'Variable to track state of socket data reception
Private mbGotData As Boolean

'Array for socket state descriptions
Private mvntSocketState As Variant

'################# BEGIN CHAT SUBS ######################

'Below Subs (Offline, Online, Connecting & Listening
'are repetitious tasks that are called from other
'Subs. Instead of putting these 10 or so lines in each Sub
'that they belong to, I put them up here which makes it
'easier to figure out the heart of each sub instead of
'being bombarded by all of these .Visible's ,  etc
'Perhaps I could've made some modules?

Public Sub Offline()
imgOffline.Visible = True
imgOnline.Visible = False
imgConnecting.Visible = False
txtPort.Enabled = True
txtNick.Enabled = True
txtIP.Enabled = True
cmdSendText.Enabled = False
txtSendText.Enabled = False
optHostGuest(0).Enabled = True
optHostGuest(1).Enabled = True
StatusBar1.Panels(2).Text = ""
Winsock1.Close

'Reset Online Timer
tmrClock.Enabled = False
s = 0
m = 0
FrameCounter.Visible = False
lblSeconds.Caption = ""
lblMinutes.Caption = ""

tmrFlash.Enabled = False
End Sub

Public Sub Online()
imgOnline.Visible = True
imgOffline.Visible = False
imgConnecting.Visible = False
txtIP.Enabled = False
txtPort.Enabled = False
cmdSendText.Enabled = True
txtSendText.Enabled = True
txtIncomingData.Text = ""
optHostGuest(0).Enabled = False
optHostGuest(1).Enabled = False
cmdConnect.Caption = "Disconnect"
tmrFlash.Enabled = False
End Sub

Public Sub Connecting()
tmrFlash.Enabled = True
imgConnecting.Visible = True
imgOffline.Visible = False
imgOnline.Visible = False
cmdSendText.Enabled = False
txtSendText.Enabled = False
StatusBar1.Panels(2).Text = "CONTACTING HOST..."
Winsock1.Close
           IP = txtIP.Text
If LCase$(IP) = "localhost" Then IP = Winsock1.LocalIP
Winsock1.Connect txtIP.Text, txtPort.Text
End Sub

Public Sub Listening()
imgConnecting.Visible = True
imgOffline.Visible = False
imgOnline.Visible = False
cmdSendText.Enabled = False
txtSendText.Enabled = False

Winsock1.Close
Winsock1.LocalPort = txtPort.Text 'set the port
Winsock1.Listen 'tell it to listen
StatusBar1.Panels(2).Text = "LISTENING ON PORT: " & txtPort.Text
tmrFlash.Enabled = True
End Sub

Private Sub cmdConnect_Click()
    If cmdConnect.Caption = "Connect" Or cmdConnect.Caption = "Listen" Then
'If the button is showing Connect or Listen, then we are
'currently offline, so do this:

'Now do the Online sub
    Call Online

    Else
'If the button is NOT showing Connect or Listen, then we
'must be Offline, so call the Offline sub
    Call Offline
       
     If optHostGuest(0).Value = True Then
cmdConnect.Caption = "Listen"
   
'If the Host button is checked, then we dont want
'to do the Online sub, which is for Guest Mode, we
'want to call the Listening Sub:

   Call Listening
       Else
'Else we are already Listening in Host mode, so Go Offline
cmdConnect.Caption = "Connect"
       End If
Call Offline

Exit Sub
    End If
  
    Select Case optHostGuest(0).Value
        Case True:  'Host
           'Listen for connections
Call Listening
        Case False: 'Guest
           'Try to connect
Call Connecting
    End Select

End Sub



Private Sub cmdSendMail_Click()
On Error GoTo ErrorHandling
    SendEmail txtEmailServer.Text, txtFromEmailAddress.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtEmailBodyOfMessage.Text
 MsgBox ("Mail Sent")
    StatusTxt.Caption = "Mail Sent"
    StatusTxt.Refresh
    Beep

    Close

ErrorHandling:

Winsock2.Close

End Sub

Private Sub mnuAbout_Click()
frmAbout.Show
End Sub


Private Sub mnuColor_Click()
On Error GoTo Cancel
CommonDialog1.ShowColor
frmChat.BackColor = CommonDialog1.Color
Cancel:
End Sub

Private Sub mnuExit_Click()
Unload Me
End Sub

Private Sub mnuFrameCapColor_Click()
On Error GoTo Cancel
CommonDialog1.ShowColor
FrameSendText.ForeColor = CommonDialog1.Color
FrameUtility.ForeColor = CommonDialog1.Color
FrameSendEmail.ForeColor = CommonDialog1.Color
FrameCheckEmail.ForeColor = CommonDialog1.Color
FrameCounter.ForeColor = CommonDialog1.Color
FrameConnectOptions.ForeColor = CommonDialog1.Color
FrameStatus.ForeColor = CommonDialog1.Color
FrameSendEmailStatus.ForeColor = CommonDialog1.Color
FrameCheckEmailStatus.ForeColor = CommonDialog1.Color
Cancel:
End Sub

Private Sub mnuFrameColor_Click()
On Error GoTo Cancel
CommonDialog1.ShowColor
FrameSendText.BackColor = CommonDialog1.Color
FrameUtility.BackColor = CommonDialog1.Color
FrameSendEmail.BackColor = CommonDialog1.Color
FrameCheckEmail.BackColor = CommonDialog1.Color
FrameCounter.BackColor = CommonDialog1.Color
FrameConnectOptions.BackColor = CommonDialog1.Color
FrameStatus.BackColor = CommonDialog1.Color
FrameSendEmailStatus.BackColor = CommonDialog1.Color
FrameCheckEmailStatus.BackColor = CommonDialog1.Color
optUtility(0).BackColor = CommonDialog1.Color
optUtility(1).BackColor = CommonDialog1.Color
optUtility(2).BackColor = CommonDialog1.Color
lblCaption(0).BackColor = CommonDialog1.Color
lblCaption(1).BackColor = CommonDialog1.Color
lblCaption(2).BackColor = CommonDialog1.Color
lblCaption(3).BackColor = CommonDialog1.Color
lblCaption(4).BackColor = CommonDialog1.Color
chkLogStatus.BackColor = CommonDialog1.Color
optHostGuest(0).BackColor = CommonDialog1.Color
optHostGuest(1).BackColor = CommonDialog1.Color
LabelAddress.BackColor = CommonDialog1.Color
labelPort.BackColor = CommonDialog1.Color
LabelNick.BackColor = CommonDialog1.Color
Label1.BackColor = CommonDialog1.Color
Label2.BackColor = CommonDialog1.Color
Label3.BackColor = CommonDialog1.Color
Label5.BackColor = CommonDialog1.Color
Label6.BackColor = CommonDialog1.Color
Label7.BackColor = CommonDialog1.Color
StatusTxt.BackColor = CommonDialog1.Color
Cancel:
End Sub

Private Sub mnuHelpContents_Click()
Shell "winhelp.exe coolchat.hlp", vbNormalFocus

End Sub

Private Sub cmdCheckEmail_Click()

Dim nMonitorPort As Integer
Dim sServer As String


    'Get the Value used for the server name
    sServer = txtServer.Text
    If Len(sServer) = 0 Then
        MsgBox "Plese enter the POP3 server name"
       
        Exit Sub
    End If
    
'Get the value used for the port connection
nMonitorPort = CInt(txtPort.Text)
If nMonitorPort = 0 Then
    MsgBox "Please enter the POP3 server and Port (Default = 110)"

    Exit Sub
End If

'Error checking for username and password has been
'left out intentionally to show the error messages
'returned by the POP3 Server

cmdCheckEmail.Enabled = False

'Connect and get the message count
lstStatus.Clear
Call POP3CheckMail
cmdCheckEmail.Enabled = True


End Sub

Private Sub optHostGuest_Click(Index As Integer)
'Does something when either Guest or Host value is checked
'(Not pushing the connect button, just clicking the options)
    
    Select Case Index
       
       Case 0: 'Host value is clicked on
            'Automatically paste your IP# in the Address box
           
          IP = Winsock1.LocalIP
          txtIP.Text = IP
           'Prevent the address from being changed
           txtIP.Locked = True
          txtIP.Enabled = False
          cmdConnect.Caption = "Listen"
        StatusBar1.Panels(1).Text = "HOST MODE"
       
       Case 1: 'Guest value is clicked on
              txtIP.Text = "localhost"
          cmdConnect.Caption = "Connect"
       txtIP.Locked = False
        txtIP.Enabled = True
        StatusBar1.Panels(1).Text = "GUEST MODE"
          
    End Select
End Sub

Private Sub cmdSendText_Click()
'Send Text to other party
Winsock1.SendData txtNick.Text & ":  " & txtSendText.Text
'Display YOUR text on your screen, too
txtIncomingData.Text = txtIncomingData.Text + vbCrLf + txtNick.Text + ": " + txtSendText.Text
'Make the text box blank after we send the text.
'otherwise, we'd have to erase all the characters before
'sending a new message, EVERYTIME
txtSendText.Text = ""
End Sub

Private Sub Form_Load()
        StatusBar1.Panels(1).Text = "GUEST MODE"
cmdSendText.Enabled = False
txtSendText.Enabled = False
FrameCounter.Visible = False
txtIncomingData.Text = "Welcome to Cool Chat!" & vbCrLf & _
 "Click on this screen to clear the text at anytime."
StatusBar1.Panels(2).Text = "Cool Chat v" & App.Major & "." & App.Minor & "." & App.Revision & "  - MDSoftware"



'Check Email variables
'Load the variant arrary with socket states
mvntSocketState = Array("Closed", "Opening", "Listening", "Connection Pending", "Resolving Host", "Host Resolved", "Connecting", "Connected", "Closing", "Error")
                        
'Initialize the log status state to false
mbLogStatus = False

End Sub



Private Sub optUtility_Click(Index As Integer)
Select Case Index
Case 0: 'Connection Options
FrameConnectOptions.Visible = True
FrameSendEmail.Visible = False
FrameCheckEmail.Visible = False

Case 1: 'Send Email
FrameConnectOptions.Visible = False
FrameSendEmail.Visible = True
FrameCheckEmail.Visible = False
IP = Winsock1.LocalIP
txtEmailBodyOfMessage.Text = "My IP number is: " & IP

Case 2: ' Check Email
FrameConnectOptions.Visible = False
FrameSendEmail.Visible = False
FrameCheckEmail.Visible = True

End Select
End Sub

Private Sub tmrClock_Timer()

'This does nothing but simply display an online timer
'when a connection is complete
'Note if you want to make a timer like this, make sure
'you set the Interval in Properties to 1000
'Simplest form to do a timer is:
's = s + 1
'Label1.Caption = s (for Label) or Text1.Text = s (for text)
'Just those 2 lines will make you a seconds counter.

s = s + 1
'When seconds gets to 60, then restart to 0 and add 1 to minutes
If s = 60 Then
s = 0
m = m + 1
End If

'When the first minutes is reached display it
If m > 0 Then
lblMinutes.Caption = m
End If
lblSeconds.Caption = s

End Sub

Private Sub tmrFlash_Timer()
Static blnImage1 As Boolean
If blnImage1 Then
imgConnecting.Picture = ImageList1.ListImages(1).Picture
Else
imgConnecting.Picture = ImageList1.ListImages(2).Picture
End If
blnImage1 = Not blnImage1

End Sub

Private Sub txtIncomingData_Change()
'Makes the chat screen auto scroll
'BTW, Len is used to tell you the length (# of characters)
'in a text ("string") Variable
txtIncomingData.SelStart = Len(txtIncomingData)
End Sub

Private Sub txtIncomingData_Click()
txtIncomingData.Text = ""
End Sub

Private Sub txtSendText_KeyPress(KeyAscii As Integer)
   
   If KeyAscii = 13 Then 'If user pressed 'Enter'
      cmdSendText_Click 'click 'Send' button
      KeyAscii = 0 'Make sure it doesnt write enter to txtText
   End If
    
End Sub


Private Sub Winsock1_Close()