frmmain.frm

BREW平台上实现的一个聊天系统

      .RowHeightMin = 350
      .WordWrap = True
      .SelectionMode = flexSelectionByRow
      .HighLight = flexHighlightAlways
      .ExplorerBar = flexExSort
   End With
   
   With grdDown
      .Rows = 1
      .Cols = 3
      .TextMatrix(0, 0) = "序号"
      .TextMatrix(0, 1) = "手机号码"
      .TextMatrix(0, 2) = "下行信息"

      .ColAlignment(0) = flexAlignCenterCenter
      .ColAlignment(1) = flexAlignCenterCenter
      .ColAlignment(2) = flexAlignLeftCenter
      
      .ExtendLastCol = True
      
      .AllowUserResizing = flexResizeBoth
      .AutoResize = True
      .AutoSize 0, .Cols - 1
      .RowHeightMin = 350
      .WordWrap = True
      .SelectionMode = flexSelectionByRow
      .HighLight = flexHighlightAlways
      .ExplorerBar = flexExSort
   End With
   
   With grdChat
      .Rows = 1
      .Cols = 3
      .TextMatrix(0, 0) = "序号"
      .TextMatrix(0, 1) = "手机号码"
      .TextMatrix(0, 2) = "聊天信息"

      .ColAlignment(0) = flexAlignCenterCenter
      .ColAlignment(1) = flexAlignCenterCenter
      .ColAlignment(2) = flexAlignLeftCenter
      
      .ExtendLastCol = True
      
      .AllowUserResizing = flexResizeBoth
      .AutoResize = True
      .AutoSize 0, .Cols - 1
      .RowHeightMin = 350
      .WordWrap = True
      .SelectionMode = flexSelectionByRow
      .HighLight = flexHighlightAlways
      .ExplorerBar = flexExSort
   End With
End Sub

Private Function InitSgip() As Boolean
'***************************************************
'目    的： 初始化控件
'输    入： 无
'输出/返回：无
'作    者：
'完成日期： 2004/08/30
'修 正 人：
'修正日期：
'****************************************************
   Dim lError As Long
   
   InitSgip = False
   bIsConnect = False
   
   Set m_CSgip = New ClsSgip
   lError = m_CSgip.Init
   If lError <> 0 Then
       Exit Function
   End If
   lError = m_CSgip.Bind()

   If lError <> 0 Then
       Exit Function
   End If
   bIsConnect = True
   InitSgip = True
End Function

Private Sub m_CSgip_Deliver(bStrSPID As String, bStrMobileID As String, bMessageCoding As Byte, lMessageLength As Long, MessageContent As Variant)
   Dim ifor As Long
   
   Dim str4Temp As String
   Dim strEuIp As String
   Dim strSql As String
   Dim i As Integer
   Dim UserCount As Integer
   Dim iTempLen As Integer
   
   Dim strName As String
   Dim strContent As String
   Dim strOther() As String
   
   Dim rstServer As New ADODB.Recordset
   UserCount = 0
   bStrMobileID = IIf(Len(bStrMobileID) = 11, bStrMobileID, Right(bStrMobileID, 11))
   addUp bStrMobileID, MessageContent
   addRecord bStrMobileID, MessageContent
   
   Select Case UCase(Left(MessageContent, 1))
      Case "Z" '用户发注册信息(格式: Z#姓名)
         If InStr(MessageContent, "#") > 0 Then
            strName = Right(MessageContent, Len(MessageContent) - InStr(MessageContent, "#"))
            If InsertUser(bStrMobileID, strName) = False Then
               strContent = "此用户名已被注册，请重新起名"
               sendMt bStrMobileID, strContent
               addDown bStrMobileID, strContent
               addRecord bStrMobileID, strContent
            End If
            
            strContent = "您注册成功,可以与以下用户聊天："
            
            strSql = "select UserName from T_User"
            Set rstServer = m_adoLocalcon.Execute(strSql, adOpenForwardOnly, adCmdText)
            On Error GoTo errExe
            If rstServer.BOF And rstServer.EOF Then
               rstServer.Close
               Set rstServer = Nothing
               Exit Sub
            End If
            
            rstServer.MoveFirst
            For i = 0 To rstServer.RecordCount
               If i Mod (rstServer.RecordCount / 10) <> 0 Then
                  rstServer.MoveNext
               End If
               strContent = strconten & rstServer(UserName) & ","
               UserCount = Usercout + 1
               If UserCount > 3 Or rstServer.BOF Then
                  Exit For
               End If
            Next
            sendMt bStrMobileID, strContent
            addDown bStrMobileID, strContent
            addRecord bStrMobileID, strContent
         Else
            strContent = "您发送的格式错误,请您发送Z#您的姓名注册"
            sendMt bStrMobileID, strContent
            addDown bStrMobileID, strContent
            addRecord bStrMobileID, strContent
         End If
      Case "L" '用户发聊天信息(格式: L#聊友名称#内容)
         If InStrRev(MessageContent, "#") = InStr(MessageContent, "#") _
               Or InStrRev(MessageContent, "#") <= 0 _
               Or InStr(MessageContent, "#") <= 0 Then
            strContent = "您发送的格式错误,请您发送L#聊友名称#内容"
            sendMt bStrMobileID, strContent
            addDown bStrMobileID, strContent
            addRecord bStrMobileID, strContent
            Exit Sub
         End If
         iTempLen = InStrRev(MessageContent, "#") - InStr(MessageContent, "#")
         strName = Mid(MessageContent, InStr(MessageContent, "#"), iTempLen)
         If JudgeUser(strName) = True Then
            If m_strMobile = Null Then
               strContent = "你的聊友没保留手机"
               sendMt bStrMobileID, strContent
               addDown bStrMobileID, strContent
               addRecord bStrMobileID, strContent
               Exit Sub
            Else
               strContent = Right(MessageContent, Len(MessageContent) - InStr(MessageContent, "#"))
               strOther = Split(strContent, "#")
               sendMt m_strMobile, strOther(1)
               addDown m_strMobile, strOther(1)
               addRecord m_strMobile, strOther(1)
         Else
            strContent = "您没注册,请您先注册,否则不能聊天"
            sendMt bStrMobileID, strContent
            addDown bStrMobileID, strContent
            addRecord bStrMobileID, strContent
         End If
   End Select
   Exit Sub
errExe:
   rstServer.Close
   Set rstServer = Nothing
   Exit Sub
End Sub

Private Function JudgeUser(ByVal strUserName As String) As Boolean
'***************************************************
'目    的： 判断用户是否注册
'输    入： strMobile
'输出/返回：True    表示注册
'           False   表示没注册
'作    者： 张龙
'完成日期： 2004/08/30
'修 正 人:
'修正日期：
'***************************************************
   Dim oRs4Temp As New ADODB.Recordset
   Dim strSql As String
   JudgeUser = False
   
   strSql = "select * from T_User where UserName='" & strUserName & "'"
   Set oRs4Temp = m_adoLocalcon.Execute(strSql, adOpenForwardOnly, adCmdText)
   On Error GoTo errExe
   If oRs4Temp.BOF And oRs4Temp.EOF Then
      oRs4Temp.Close
      Set oRs4Temp = Nothing
      JudgeUser = False
      Exit Function
   End If
   
   If oRs4Temp.RecordCount = 0 Then
      JudgeUser = False
      Exit Function
   End If
   
'   If oRs4Temp.State = adStateOpen Then oRs4Temp.Close
'   oRs4Temp.CursorLocation = adUseClient
'   oRs4Temp.Open strSql, m_adoLocalcon, adOpenKeyset, adLockOptimistic
   
   
   m_strMobile = oRs4Temp(Mobile)
   JudgeUser = True
   Exit Function
errExt:
   oRs4Temp.Close
   JudgeUser = False
   Set oRs4Temp = Nothing
   Exit Function
   
End Function

Private Function InsertUser(ByVal strMobile As String, _
                       ByVal strUser As String) As Boolean
'***************************************************
'目    的： 保存用户的信息
'输    入： 手机号,用户姓名
'输出/返回：无
'作    者： 张龙
'完成日期： 2004/07/07
'修 正 人:
'修正日期：
'***************************************************
   Dim strSql As String
   Dim rstServer As New ADODB.Recordset
   
   strSql = "select * from T_User where UserName =" & Trim(strUser)
   Set rstServer = m_adoLocalcon.Execute(strSql, adOpenForwardOnly, adCmdText)
   On Error GoTo errExe
'   If rstServer.BOF And rstServer.EOF Then
'      rstServer.Close
'      Set rstServer = Nothing
'      Exit Sub
'   End If
   If rstServer.RecordCount <> 0 Then
      InsertUser = False
      Exit Function
   End If
   
   strSql = "insert into T_User(UserName,Mobile)values('" _
                  & strUser & " ','" & strMobile & "')"
        
   Do While ExcuteSQL(strSql) <> 0
      DoEvents
   Loop
   InsertUser = True
   Exit Function
errExe:
   rstServer.Close
   Set rstServer = Nothing
   InsertUser = False
   Exit Function
End Function

Private Sub InsertMo(ByVal strMobile As String, _
                       ByVal strCon As String)
'***************************************************
'目    的： 保存用户的上行信息
'输    入： 手机号,信息内容
'输出/返回：无
'作    者： 张龙
'完成日期： 2004/07/07
'修 正 人:
'修正日期：
'***************************************************
    Dim strSql As String
    strSql = "insert into T_MO(UserNumber,MessageContent)values('" _
                  & strMobile & " ','" & strCon & "')"
        
    Do While ExcuteSQL(strSql) <> 0
        DoEvents
    Loop
End Sub

Private Sub InsertMt(ByVal strMobile As String, _
                       ByVal strCon As String)
'***************************************************
'目    的： 保存用户的下行信息
'输    入： 手机号,信息内容
'输出/返回：无
'作    者： 张龙
'完成日期： 2004/07/07
'修 正 人:
'修正日期：
'***************************************************
    Dim strSql As String
    strSql = "insert into T_MT(CorpId,ServiceType,UserNumber,MessageContent)values('" _
                  & strMobile & " ','" & strCon & "')"
        
    Do While ExcuteSQL(strSql) <> 0
        DoEvents
    Loop
End Sub

Private Sub addRecord(ByVal strMobile As String, ByVal strCon As String)
'***************************************************
'目    的： 添加上行信息
'输    入： strMobile,strCon
'输出/返回：无
'作    者： 张龙
'完成日期： 2004/08/30
'修 正 人：
'修正日期：
'****************************************************
   With grdChat
      .AddItem .Rows & vbTab _
            & strMobile & vbTab _
            & strCon
      .ShowCell .Rows - 1, 1
   End With

End Sub

Private Sub addUp(ByVal strMobile As String, ByVal strCon As String)
'***************************************************
'目    的： 添加上行信息
'输    入： strMobile,strCon
'输出/返回：无
'作    者： 张龙
'完成日期： 2004/08/30
'修 正 人：
'修正日期：
'****************************************************
   With grdUP
      .AddItem .Rows & vbTab _
            & strMobile & vbTab _
            & strCon
      .ShowCell .Rows - 1, 1
   End With
   InsertMo strMobile, strCon
End Sub

Private Sub addDown(ByVal strMobile As String, ByVal strCon As String)
'***************************************************
'目    的： 发送下行信息和聊天信息
'输    入： strMobile,strCon,bState
'输出/返回：无
'作    者： 张龙
'完成日期： 2004/08/30
'修 正 人：
'修正日期：
'****************************************************
   With grdDown
   .AddItem .Rows & vbTab _
         & strMobile & vbTab _
         & strCon
   .ShowCell .Rows - 1, 1
   End With
End Sub

Private Sub sendMt(ByVal strMobile As String, _
                   ByVal strCon As String)
'***************************************************
'目    的： 发送下行信息
'输    入： strMobile,strCon
'输出/返回：无
'作    者： 张龙
'完成日期： 2004/08/30
'修 正 人：
'修正日期：
'****************************************************
   Dim lReturn As Long
   lReturn = m_CSgip.Submit(strMobile, strCon)
   
   If lReturn <> 0 Then
      Exit Sub
   End If
   InsertMt strMobile, strCon
   
End Sub
Public Sub SetParamValue()

   m_CSgip.Para(Timeout4Connect) = m_Timeout4Connect
'   m_Sgip.Para((Timeout4Connect) = m_Timeout4Connect
   m_CSgip.Para(Timeout4Recv) = m_Timeout4Recv
   m_CSgip.Para(PauseTime4Recv) = m_PauseTime4Recv
   m_CSgip.Para(PauseTime4Terminate) = m_PauseTime4Terminate
   m_CSgip.Para(SendIntervalTime) = m_SendIntervalTime
   m_CSgip.Para(Timeout4Response) = m_Timeout4Response
   
   m_CSgip.AgentFlag = m_AgentFeeFlag
   m_CSgip.ExpireTime = m_SExpireTime
   m_CSgip.FeeMobileID = m_SFeeMobileID
   m_CSgip.FeeType = m_SFeeType
   m_CSgip.FeeValue = m_SFeeValue
   m_CSgip.GivenValue = m_SGivenValue
   m_CSgip.MessageCoding = m_SMsgMsg
   m_CSgip.MessageType = m_SMsgType
   m_CSgip.MobileIDFix = m_MobileIDFix
   m_CSgip.MoreLateToMTFlag = m_SMoreLateToMTFlag
   m_CSgip.Priority = m_SPriority
   m_CSgip.Reserve = m_SReserve
   m_CSgip.ScheduleTime = m_SScheduleTime
   m_CSgip.SeviceType = m_SSeviceType
   m_CSgip.RegisteredDeliveryFlag = m_RegDeliveryFlag
   m_CSgip.SPID = m_SSPID
   m_CSgip.spnumber = m_SSPNumber
   m_CSgip.TPpid = m_STPpid
   m_CSgip.TPudhi = m_STPudhi
   m_CSgip.Version = m_SVersion
End Sub

Private Sub Form_Unload(Cancel As Integer)

   If MsgBox("确认退出程序！") = vbYes Then
      Cancel = 1
      If Not m_CSgip Is Nothing Then
         m_CSgip.Unbind
      End If
   End If
End Sub

Private Sub mnu_exit_Click()
   Unload Me
End Sub

Private Sub mnu_set_Click()
   frmIni.Show vbModal
End Sub

Private Sub mnuParam_Set_Click()
   FrmParam.Show vbModal
End Sub

Private Sub SynchTimer_Timer()
   m_CSgip.Active
End Sub