module1.bas

时通讯和P2P开发工具

''''On Error Resume Next
'
'
'If Len(parm) = 0 Then Exit Sub
'
'
'Select Case i
'
'
'
'    Case BATCH_VIS_LIST
'        lmsg "======BATCH_VIS_LIST====="
'
'      ' MsgBox "基本信息"
'       Dim count As Integer
'       Dim ii As Integer
'       Dim onlineUserlist() As String
'       onlineUserlist = Split(parm, "`")
'       count = UBound(onlineUserlist) / 5
'       Debug.Print "vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv" & count
'       onlineUser(0).bl = count
'       For ii = 0 To count - 1
'
'       onlineUser(ii).UIN = onlineUserlist(ii * 5)
'       onlineUser(ii).Status = onlineUserlist(ii * 5 + 1)
'       onlineUser(ii).ip = onlineUserlist(ii * 5 + 2)
'       onlineUser(ii).port = onlineUserlist(ii * 5 + 3)
'       onlineUser(ii).firewall = onlineUserlist(ii * 5 + 4)
'       Next ii
'
'    End Select
' login1 = True
End Sub



'返回系统消息，e是codes, i是哪个命令的返回消息,i可能不用，parm备用
'//error code
'Public Const E_SEND_UDP = 10000             'UDP发送本机出错
'Public Const E_NOT_WAIT_NEXT = 10001                '未处于发送状态
'Public Const E_MSG_NOT_REACH_PEER = 10002       '消息未能到达对方
'#define E_USER_ALREADY_LOGIN        10003   //用户已经LoginImg
'Public Const E_USER_NOT_FOUND = 10010           '
'Public Const E_USERNAME_EXIST = 10020            '用户已经存在
'Public Const E_SOKET_CREATE = 10030                 '无法创建socket

'Public Const E_SUCCEED = 0                      '操作成功
'Public Const E_LOGIN_SUC = 12000                    '登录成功
'Public Const E_NO_UIN = 12010                   '登录不成功，用户名不存在
'Public Const E_PWD = 12020                      '密码错误
'Public Const E_LOGIN_FAIL = 12025               '登录不成功，其它原因
'Public Const E_NEET_AUTH = 12030                    '对方需要认证
'Public Const E_FRIEND_REFUSE = 12040
'Public Const E_ADD_LIST_SUC = 12050                 '用户添加成功
'Public Const E_ALREDY_LIST_FRIEND = 12060       '他已经是本组成员
'Public Const E_DEL_LIST_SUC = 12070                 '成功删除
'Public Const E_UPDATE_SUC = 12080               '服务器已经接受你的修改
'Public Const E_SEARCH_NO_USER = 12090           '没找到用户
'Public Const E_NEED_LOGIN = 13000               '未登录
'Public Const E_SEND = 13010                         '发送出错

'检查Session的返回值
'Public Const E_NO_USER = 2                  '用户不在线
'Public Const E_SESSION_CORRECT = 1          'session正确
'Public Const E_SESSION_ERROR = 0                'session不对

'本地错误
'Public Const E_TIME_OUT = 14000                     '超时未发出某个命令

Sub ExeSysMsg(ByVal nVer As Long, ByVal e As Integer, ByVal i As Long, ByVal parm As String)

'Sub ExeSysMsg(ByVal e As Integer, ByVal i As Long, ByVal parm As String)
    '
   ' Debug.Print
    lmsg "ExeSysMsg:::::::::::::::" & e & "i=" & "parm=" & parm & " 登录状态 " & g_stMe.nStatus
    Debug.Print "ExeSysMsg:::::::::::::::" & e & "i=" & "parm=" & parm & " 登录状态 " & g_stMe.nStatus
    'Exit Sub
    
    '停止动作
    
   ' MsgBox e
    
    If e = E_CONTACT_LIST_END Then

           
    ElseIf e = E_SEARCH_END Then
        MsgBox "已经找完所有记录", vbInformation
       
    ElseIf e = E_SEARCH_NO_USER Then
        MsgBox "未能找到用户", vbInformation
        
    End If
    'Exit Sub
            
            
    Select Case e
    Case E_CONTACT_LIST_END
             lmsg "收到  E_CONTACT_LIST_END ，全部contact list已经完成"
            
    Case E_SUCCEED
           MsgBox "操作成功"  '  //操作成功，不需要提示
           
    Case E_LOGIN_SUC
        '登录成功会转到ExeLoginReply函数，而不是返回错误信息
       MsgBox "操作成功"  '  //操作成功，不需要提示
           
    Case E_NO_UIN
            MsgBox "登录不成功，登录的用户ID不存在"
    Case E_PWD
            MsgBox "登录不成功，密码错误", vbCritical
    Case E_LOGIN_FAIL
            MsgBox "登录不成功，其它原因", vbCritical
      Case E_SOKET_CREATE
            MsgBox "无法创建socket", vbCritical
    Case E_TIME_OUT
           Select Case i
           Case 1000  '如果是登录
                    lmsg "登录不成功，超时"
           Case Else
     
           End Select
   Case E_ALLPACKAGE_TIME_OUT
        MsgBox "网络连接服务器失败，请检查网络", vbCritical ' & i & " 超时，" & parm
        
   Case E_TXT_MSG_TIME_OUT
            Dim sMsg As String
            Dim UIN As Long
            UIN = i
          sMsg = "您所发以下消息未成功: " & parm
   Case E_SEND_UDP
            'g_nMyState = STATUS_OFFLINE
            MsgBox "发送数据失败，可能网络不通", vbCritical
   Case E_USERNAME_EXIST
            MsgBox "用户名已经有人使用，请再选择", vbCritical
      '      StopProcess
   Case E_USER_ALREADY_LOGIN
           MsgBox "此用户已经在其它地方登录，您被迫下线", vbInformation
    Case E_ALREDY_LIST_FRIEND
            MsgBox "此用户已经是本组成员", vbCritical
    Case E_UPDATE_SUC
            MsgBox "服务器已经接受你的修改", vbInformation
    Case E_SEARCH_NO_USER
            MsgBox "未找到用户", vbCritical
    Case E_SEARCH_SQL_ERROR
            MsgBox "查找出错，可能是输入了无效的查询条件。", vbCritical
    Case 183
           ' MsgBox "网络错误，请检查服务器配置是否正确。", vbCritical
        lmsg "网络错误"
    Case E_ADD_LIST_SUC
            MsgBox "添加成功", vbInformation
            g_blAddUser = True
    Case E_DEL_LIST_SUC
            MsgBox "删除成功", vbInformation
    
            
    
    Case Else
           ' MsgBox "服务器返回: " & e & " " & parm, vbInformation
    End Select
End Sub


'如果收到这个函数，表示登录成功
Sub ExeLoginReply(ByVal nVer As Long, ByVal UIN As Long, ByVal i As Long, ByVal parm As String)

'Sub ExeLoginReply(ByVal UIN As Long, ByVal i As Long, ByVal parm As String)

'parm格式：
'IconID = Nick = UserName = BAuthType = bSex = nAuthGroup = sIP = nPort = City = Province
'=country=nLanStatus=age=sMoblie=nStatus );
    
 Form1.Text1.Text = Form1.Text1.Text & vbCrLf & "登陆成功，ExeLoginReply: UIN: " & UIN & ", i:" & i & ", parm: " & parm
    
    
     Dim UserBaseData() As String
     UserBaseData = Split(parm, "`")
     Form1.Text2.Text = UserBaseData(6)
     Form1.Text3.Text = Val(UserBaseData(7))
    
'    Const HEADER_IMAGE_COUNT = 5
'    'LHJ 读入商务组信息并建立组
'    Call CmdReqContactListDll(AddressOf ExeReqContactList)
'
'    ' If login1 = True Then
'     '  MsgBox "longstr"
'     '  End If
'    Form1.Caption = Form1.Caption + "(" + Form2.Combo2.Text + ")"
'    Form2.Visible = False
'    Form1.Frame4.Visible = True
'    Form1.Frame5.Visible = True
'    Form1.Frame1.Visible = False
'    Form1.Frame2.Visible = False
'    Form1.Frame3.Visible = False
'    Form1.addfriend.Enabled = True
'    Form1.addlist.Enabled = False
'
' Form1.Image1.Picture = Form1.ImageList1.ListImages(g_stMe.IconID + 1).Picture
'
'   Dim UserBaseData() As String
'   UserBaseData = Split(parm, "`")
'   Dim nIconID As Integer
'   nIconID = CInt(UserBaseData(0))
'   If nIconID > HEADER_IMAGE_COUNT Then nIconID = 0
   '设置我的登录状态
    'LHJ 这里应该给我的所有变量给值，最好是能得到自己的那个控件
    Form1.Text10.Text = Form1.Text10.Text & "我从网上下来的信息是：" & vbCrLf
    Form1.Text10.Text = Form1.Text10.Text & "图片ID：" & UserBaseData(0) & vbCrLf
    Form1.Text10.Text = Form1.Text10.Text & "昵称：" & UserBaseData(1) & vbCrLf
    Form1.Text10.Text = Form1.Text10.Text & "用户名：" & UserBaseData(2) & vbCrLf
    Form1.Text10.Text = Form1.Text10.Text & "类别：" & UserBaseData(3) & vbCrLf
    Form1.Text10.Text = Form1.Text10.Text & "性别：" & UserBaseData(4) & vbCrLf
    Form1.Text10.Text = Form1.Text10.Text & "所属组：" & UserBaseData(5) & vbCrLf
    Form1.Text10.Text = Form1.Text10.Text & "端口：" & UserBaseData(7) & vbCrLf
    Form1.Text10.Text = Form1.Text10.Text & "省份：" & UserBaseData(8) & vbCrLf
    Form1.Text10.Text = Form1.Text10.Text & "国家：" & UserBaseData(10) & vbCrLf
    Form1.Text10.Text = Form1.Text10.Text & "防火墙状态：" & UserBaseData(11) & vbCrLf
    Form1.Text10.Text = Form1.Text10.Text & "年龄：" & UserBaseData(12) & vbCrLf
    Form1.Text10.Text = Form1.Text10.Text & "手机：" & UserBaseData(13) & vbCrLf
    Form1.Text10.Text = Form1.Text10.Text & "IP地址：" & UserBaseData(6) & vbCrLf
    Form1.Text10.Text = Form1.Text10.Text & "状态：" & UserBaseData(14) & vbCrLf
    
    'g_nInFaceMyState = g_nMyState

'          loginlist = True
     
 End Sub
 
 
'处理收到的消息，bLeaveMsg表明是否是留言
Private Sub DealWithRecievedMsg(bLeaveMsg As Boolean, UIN As Long, nType As Long, msg As String, sTime As String, Optional sIP As String, Optional nPort As Long)
 '   With TalkTo
        Dim thetime As String
        If Len(sTime) < 5 Then
            thetime = Now
        Else
            thetime = sTime
        End If
        
         If Len(msg) = 0 Then
            lmsg "警告，信息为空"
            Exit Sub
         End If
         
         lmsg " "
        lmsg "DealWithRecievedMsg: UIN: " & UIN & ", i:" & nType & ", parm: " & msg
        Debug.Print "DealWithRecievedMsg: UIN: " & UIN & ", i:" & nType & ", parm: " & msg
       
 
End Sub

Public Sub SendP2PMsg(nType As Integer, nFirewall As Integer, sIP As String, nPort As Long, UIN As Long, msg As String)
  lmsg "SendP2PMsg:  " & "nType" & nType & "nFirewall : " & nFirewall & "sIP : " & sIP & "nPort : " & nPort & "UIN : " & UIN & "Msg : " & msg
    
    '如果有效IP地址
    If Len(sIP) > 0 And nPort > 500 Then
         CmdSendMsgDll nType, nFirewall, 0, UIN, sIP, nPort, msg
     Else
         CmdLeaveMsgDll nType, 0, UIN, msg
    End If

End Sub


Public Sub SendMsg2(nType As Integer, msg As String, sIP As String, nPort As Long, UIN As Long, nLanStatus As Integer)
    lmsg "SendMsg2:::::::::::::: IP" & sIP & " Port: " & nPort & msg
      If Len(msg) > MAX_MSG_LENGTH_VB Then
       ' MsgBox "您输入内容超过可以发送的长度", vbCritical
        lmsg "警告警告警告： 内容超长"
        Debug.Print "警告警告警告： 内容超长：" & msg
        Exit Sub
    End If
    
    '如果有效IP地址
    If Len(sIP) > 0 And nPort > 500 Then
         CmdSendMsgDll nType, nLanStatus, 0, UIN, sIP, nPort, msg
     Else
         CmdLeaveMsgDll nType, 0, UIN, msg
    End If
End Sub




'在调用ResizeForm前先调用本函数
Public Sub ResizeInit(FormName As Form)
Dim Obj As Control
FormOldWidth = FormName.ScaleWidth
FormOldHeight = FormName.ScaleHeight
On Error Resume Next
For Each Obj In FormName
Obj.Tag = Obj.Left & " " & Obj.Top & " " & Obj.Width & " " & Obj.Height & " "
'Debug.Print Obj.Tag
Next Obj
On Error GoTo 0
End Sub

'按比例改变表单内各元件的大小，
'在调用ReSizeForm前先调用ReSizeInit函数
Public Sub ResizeForm(FormName As Form)
Dim pos(4) As Double
Dim i As Long, TempPos As Long, StartPos As Long
Dim Obj As Control
Dim ScaleX As Double, ScaleY As Double

ScaleX = FormName.ScaleWidth / FormOldWidth
'保存窗体宽度缩放比例
ScaleY = FormName.ScaleHeight / FormOldHeight
'保存窗体高度缩放比例
On Error Resume Next
For Each Obj In FormName
StartPos = 1
For i = 0 To 4
'读取控件的原始位置与大小

TempPos = InStr(StartPos, Obj.Tag, " ", vbTextCompare)
If TempPos > 0 Then
pos(i) = Mid(Obj.Tag, StartPos, TempPos - StartPos)
StartPos = TempPos + 1
Else
pos(i) = 0
End If
'根据控件的原始位置及窗体改变大小
'的比例对控件重新定位与改变大小
Obj.Move pos(0) * ScaleX, pos(1) * ScaleY, pos(2) * ScaleX, pos(3) * ScaleY
Next i
Next Obj
On Error GoTo 0
End Sub
Public Sub delay(Secs%) '延时
Dim EndOfDelay
Dim ia As Long
EndOfDelay = DateAdd("s", Secs, Now)

Do While (Now < EndOfDelay)
DoEvents

Loop
End Sub




'添加好友列表
'parm为：父亲组号=组号=组名=Nick Name=是否需要验证=图标ID=UIN=在线状态
'父亲组号=-1为无父组
Public Sub addContactList(ByVal parm As String)
    Dim boole As Boolean
    Dim UserB() As String
     Dim GroupNum As Long, ii As Long, GroupNameNo As Integer
     Dim GroupName As String
     Dim USER_ITEMS As Integer
    USER_ITEMS = 7   '一个用户数据包括的字段数
    Dim count As Long
    Dim i As Integer, nParentID As Integer
    Dim sNick As String
    Dim sIcon As String
    Dim sIP As String
    Dim nPort As Long
    Dim theUIN As Long
    Dim IconID As Integer, nStatusIconID As Integer, nStatus As Integer
         
   On Error GoTo checkerror
     
     If Len(Trim(parm)) = 0 Then
        Debug.Print "addContactList" & "用户列表为空"
        Exit Sub
     End If
     
    UserB = Split(parm, "`")
    GroupNum = UBound(UserB)
    boole = False
    
    nParentID = CInt(UserB(0))
    GroupNameNo = CInt(UserB(1))     '组号
    GroupName = UserB(2)        '组名
 
 Form1.Text10.Text = Form1.Text10.Text & vbCrLf & vbCrLf & "分组信息： nParentID：" & UserB(0) & "  组号：" & UserB(1) & " 组名：" & UserB(2)
          
                '循环添加
            For ii = 0 To ((GroupNum - 3) / USER_ITEMS) - 1

                 theUIN = CLng(UserB(3 + 3 + USER_ITEMS * ii))
                 sIcon = UserB(3 + 2 + USER_ITEMS * ii)
                 sNick = UserB(3 + 0 + USER_ITEMS * ii)
                 sIP = UserB(3 + 5 + USER_ITEMS * ii)
                 If Len(UserB(3 + 6 + USER_ITEMS * ii)) > 0 Then
                     nPort = CLng(UserB(3 + 6 + USER_ITEMS * ii))
                  Else
                     nPort = 0
                  End If

                 nStatus = CInt(UserB(3 + 4 + USER_ITEMS * ii))
                 IconID = CInt(sIcon)
          
                Form1.Text10.Text = Form1.Text10.Text & vbCrLf & vbCrLf & _
                 "好友信息： 号码：" & UserB(3 + 3 + USER_ITEMS * ii) & "  图片ID：" & sIcon & " 昵称：" & sNick & _
                "  好友IP：" & sIP & " 端口：" & UserB(3 + 6 + USER_ITEMS * ii) & " 状态：" & UserB(3 + 4 + USER_ITEMS * ii)

            Next
Exit Sub
checkerror:
        Debug.Print "警告，添加用户不成功" & Err.Description
        lmsg "警告，添加用户不成功" & Err.Description
End Sub