modaddressof.vb

本目录内所有代码仅作指导用户编程之用,用户如果要作为 商业用途,建议使用正版软件进行编译. 开发环境说明： delphi demo : delphi 6.0 vc de

    '得到当前在线用户的数量
    Public Declare Function get_max_user_amount Lib "wcomm_dll.dll" () As Integer

    '设置网络事件工作模式
    Public Declare Function SetWorkMode Lib "wcomm_dll.dll" (ByVal nWorkMode As Integer) As Integer

    'windos API函数，可以查看MSDN
    Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Integer, ByVal hwnd As Integer, ByVal Msg As Integer, ByVal wParam As Integer, ByVal lParam As Integer) As Integer


    'windos API函数，可以查看MSDN
    Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Integer, ByVal nIndex As Integer) As Integer

    'windos API函数，可以查看MSDN
    Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Integer, ByVal nIndex As Integer, ByVal dwNewLong As Integer) As Integer

    'windows api函数，转换IP地址为字符串    			
    Public Declare Function inet_ntoa Lib "Ws2_32" Alias "inet_ntoa" (ByVal ip As Integer) As String
    Public Declare Function ntohl Lib "Ws2_32" Alias "ntohl" (ByVal ip As Integer) As Integer


    'windos API函数，可以查看MSDN
    'Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

    Public Function GetAddressOf(ByVal AddressOfProc As Integer) As Integer
        GetAddressOf = AddressOfProc
    End Function


    '当用户把API工作模式设置为2时(SetWorkMode)
    '只有采用消息机制时,才需要定义此回调函数
    Public Function NewWindowProc(ByVal hw As Integer, ByVal uMsg As Integer, ByVal wParam As Integer, ByVal lParam As Integer) As Long
        Dim lpPrevWndProc As Integer
        Dim pcount As Integer
        Dim rvdata As data_record
        'UPGRADE_WARNING: 数组 mess 的下限已从 1 更改为 0。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1033"”
        Dim mess(1024) As Byte
        Dim result As Integer


        If uMsg = (WM_USER + 103) Then

            '调用do_read_proc函数处理结果
            result = do_read_proc(rvdata, mess(0), Form1.DefInstance.miAnswer.Checked)
            If result = 0 Then

                If rvdata.m_data_len > 0 Then

                    pcount = Val(Form1.DefInstance.Text4.Text)

                    If Form1.DefInstance.miViewData.Checked = True Then
                        If (pcount Mod 20) = 0 Then Form1.DefInstance.Text3.Text = ""

                        Form1.DefInstance.addtext((vbNewLine))
                        'UPGRADE_ISSUE: 常量 vbUnicode 未升级。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup2070"”
                        Form1.DefInstance.addtext("用户号码：" & System.Text.Encoding.Default.GetString(rvdata.m_userid))
                        'UPGRADE_ISSUE: 常量 vbUnicode 未升级。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup2070"”
                        Form1.DefInstance.addtext("接收时间：" & System.Text.Encoding.Default.GetString(rvdata.m_recv_date))
                        Form1.DefInstance.addtext(("数据长度：" & Str(rvdata.m_data_len)))
                        'Form1.addtext("aaa",true)
                        If Not Form1.DefInstance.miHEXShow.Checked Then
                            'UPGRADE_ISSUE: 常量 vbUnicode 未升级。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup2070"”
                            Form1.DefInstance.addtext("接收数据：" & System.Text.Encoding.Default.GetString(rvdata.m_data_buf))
                        Else
                            'UPGRADE_WARNING: 未能解析对象 Form1.strtohexstr() 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"”
                            Form1.DefInstance.addtext(("接收数据：" & Form1.DefInstance.strtohexstr(rvdata.m_data_buf, rvdata.m_data_len)))
                        End If
                    End If

                    If Form1.DefInstance.miCount.Checked = True Then
                        '显示颜色
                        Form1.DefInstance.Text4.Text = Str(pcount + 1)
                        Select Case (colorflag)
                            Case 1
                                greencolor = greencolor + 1
                                If greencolor = 255 Then colorflag = 2
                            Case 2
                                redcolor = redcolor - 1
                                If redcolor = 30 Then colorflag = 3
                            Case 3
                                bluecolor = bluecolor + 1
                                If bluecolor = 255 Then colorflag = 4
                            Case 4
                                greencolor = greencolor - 1
                                If greencolor = 30 Then colorflag = 5
                            Case 5
                                redcolor = redcolor + 1
                                If redcolor = 255 Then colorflag = 6
                            Case 6
                                bluecolor = bluecolor - 1
                                If bluecolor = 30 Then colorflag = 1
                        End Select
                        Form1.DefInstance.Text4.BackColor = System.Drawing.ColorTranslator.FromOle(RGB(redcolor, greencolor, bluecolor))
                        Form1.DefInstance.Text4.ForeColor = System.Drawing.ColorTranslator.FromOle(RGB(255 - redcolor, 255 - greencolor, 255 - bluecolor))
                    End If

                End If

                If rvdata.m_data_len = 0 Then
                    Form1.DefInstance.pollusertable()
                End If

            End If
        Else

            '将消息传递给原来的处理函数，这一行代码是必须的，否则其它消息无法处理
            NewWindowProc = CallWindowProc(oldwindow, hw, uMsg, wParam, lParam)
        End If
    End Function
    Public Sub Hook(ByVal hwnd As Integer)
        Dim pOld As Integer
        Dim temp As Integer
        Dim h As HandleRef
        '指定自定义的窗口过程
        'UPGRADE_WARNING: 为 AddressOf NewWindowProc 添加委托 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1048"”
        'oldwindow = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf NewWindowProc)


    End Sub
    Public Sub Unhook(ByVal hwnd As Integer)
        Dim temp As Integer
        'Cease subclassing.
        temp = SetWindowLong(hwnd, GWL_WNDPROC, oldwindow)
    End Sub
End Module