form1.vb

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

        m2 = m1 * 256
        For i = 0 To tucount - 1
            temp = get_user_at(i, tuserinfo)

            If tuserinfo.m_status = 1 Then

                If SysAutoM = 1 Then '系统维护

                    t_update = (tuserinfo.m_update_date(1)) + m1 * (tuserinfo.m_update_date(2)) + m2 * (tuserinfo.m_update_date(3)) + m2 * (tuserinfo.m_update_date(4)) * 256 + 3600 * 8

                    If waittime = 0 Or (System.DateTime.FromOADate(Now.ToOADate - b.ToOADate).ToOADate * 3600 * 24 - t_update) < waittime Then

                        itmX = ListView1.ListItems.Add

                        'UPGRADE_ISSUE: 常量 vbUnicode 未升级。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup2070"”
                        itmX.Text = System.Text.Encoding.Default.GetString(tuserinfo.m_userid)

                        'UPGRADE_ISSUE: 常量 vbUnicode 未升级。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup2070"”
                        itmX.SubItems(1) = System.Text.Encoding.Default.GetString(tuserinfo.m_logon_date)
                        'UPGRADE_WARNING: 未能解析对象 inttoip() 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"”
                        'itmX.SubItems(2) = inttoip(tuserinfo.m_local_addr)
                        itmX.SubItems(2) = inet_ntoa(ntohl(tuserinfo.m_local_addr))
                        itmX.SubItems(3) = Str(tuserinfo.m_local_port)
                        'UPGRADE_WARNING: 未能解析对象 inttoip() 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"”
                        'itmX.SubItems(4) = inttoip(tuserinfo.m_sin_addr)
                        itmX.SubItems(4) = inet_ntoa(ntohl(tuserinfo.m_sin_addr))
                        itmX.SubItems(5) = Str(tuserinfo.m_sin_port)
                    Else
                        temp = do_close_one_user(tuserinfo.m_userid(1), closeonemess(0))
                    End If
                Else
                    itmX = ListView1.ListItems.Add

                    'UPGRADE_ISSUE: 常量 vbUnicode 未升级。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup2070"”
                    itmX.Text = System.Text.Encoding.Default.GetString(tuserinfo.m_userid)

                    'UPGRADE_ISSUE: 常量 vbUnicode 未升级。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup2070"”
                    itmX.SubItems(1) = System.Text.Encoding.Default.GetString(tuserinfo.m_logon_date)
                    'UPGRADE_WARNING: 未能解析对象 inttoip() 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"”
                    'itmX.SubItems(2) = inttoip(tuserinfo.m_local_addr)
                    itmX.SubItems(2) = inet_ntoa(ntohl(tuserinfo.m_local_addr))
                    itmX.SubItems(3) = Str(tuserinfo.m_local_port)
                    'UPGRADE_WARNING: 未能解析对象 inttoip() 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"”
                    'itmX.SubItems(4) = inttoip(tuserinfo.m_sin_addr)
                    itmX.SubItems(4) = inet_ntoa(ntohl(tuserinfo.m_sin_addr))
                    itmX.SubItems(5) = Str(tuserinfo.m_sin_port)
                End If
            End If
        Next
    End Sub

    Private Sub Timer2_Tick(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles Timer2.Tick
        Form1.DefInstance.StatusBar1.Panels.Item(3).Text = CStr(Now)
    End Sub

    '当用户把API工作模式设置为0或1时(SetWorkMode)
    '可以利用轮询方式来获取数据,而不需要采用消息机制
    Private Sub Timer3_Tick(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles Timer3.Tick
        Dim MAX_RECEIVE_BUF As Object
        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
        '调用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_type = 1) Or (rvdata.m_data_type = 2) Then
                Form1.DefInstance.pollusertable()
            End If

        End If
    End Sub

    Private Sub Toolbar1_ButtonClick(ByVal eventSender As System.Object, ByVal eventArgs As AxMSComctlLib.IToolbarEvents_ButtonClickEvent) Handles Toolbar1.ButtonClick
        Select Case eventArgs.button.Tag
            Case 1
                miStartServer_Click(miStartServer, New System.EventArgs)
            Case 2
                miStopServer_Click(miStopServer, New System.EventArgs)
            Case 3
                miOffLine_Click(miOffLine, New System.EventArgs)
            Case 4
                miSendData_Click(miSendData, New System.EventArgs)
            Case 5
                miClear_Click(miClear, New System.EventArgs)
            Case 7
                miQuit_Click(miQuit, New System.EventArgs)
        End Select
    End Sub

    Public Sub addtext(ByRef Content As String, Optional ByRef anewline As Boolean = 1)
        If LineCount > 200 Then
            Form1.DefInstance.Text3.Text = ""
            LineCount = 0
        End If
        'UPGRADE_NOTE: IsMissing() 已更改为 IsNothing()。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1021"”
        If IsNothing(anewline) Then
            Form1.DefInstance.Text3.Text = Form1.DefInstance.Text3.Text & vbNewLine & Content
        Else
            If anewline = True Then
                Form1.DefInstance.Text3.Text = Form1.DefInstance.Text3.Text & vbNewLine & Content
            Else
                Form1.DefInstance.Text3.Text = Form1.DefInstance.Text3.Text & Content
            End If
        End If
        LineCount = LineCount + 1
    End Sub

    Public Function strtohexstr(ByRef src() As Byte, ByRef ln As Short) As Object
        Dim i As Short
        Dim st As String
        Dim temp As Short

        For i = 1 To ln
            temp = src(i) \ 16
            If temp > 9 Then
                temp = temp + 55
            Else
                temp = temp + 48
            End If
            st = st & Chr(temp)

            temp = src(i) Mod 16
            If temp > 9 Then
                temp = temp + 55
            Else
                temp = temp + 48
            End If
            st = st & Chr(temp)

            st = st & " "
        Next
        'UPGRADE_WARNING: 未能解析对象 strtohexstr 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"”
        strtohexstr = st
    End Function

    Public Function hexstrtostr(ByRef src() As Byte, ByRef ln As Short) As Object
        Dim i As Short
        Dim st As String
        Dim flag As Short
        Dim temp As Short
        Dim temp1 As Short

        flag = 0

        For i = 1 To ln
            temp1 = -1
            '0-9
            If (src(i) >= &H30S And src(i) <= &H39S) Then
                temp1 = src(i) - &H30S
            End If
            'A-F
            If (src(i) >= &H41S And src(i) <= &H46S) Then
                temp1 = src(i) - &H37S
            End If
            'a-f
            If (src(i) >= &H61S And src(i) <= &H66S) Then
                temp1 = src(i) - &H57S
            End If

            If (temp1 >= 0) Then

                If flag = 0 Then
                    temp = temp1
                End If

                If flag = 1 Then
                    temp = temp * 16 + temp1
                    st = st & Chr(temp)
                End If
                flag = (flag + 1) Mod 2
            End If
        Next
        'UPGRADE_WARNING: 未能解析对象 hexstrtostr 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"”
        hexstrtostr = st
    End Function

    Private Sub Winsock1_DataArrival(ByVal eventSender As System.Object, ByVal eventArgs As AxMSWinsockLib.DMSWinsockControlEvents_DataArrivalEvent) Handles Winsock1.DataArrival
        Dim strData As String
        Winsock1.GetData(strData, VariantType.String)
        Form1.DefInstance.addtext(("接收数据：" & Winsock1.RemoteHostIP & ":" & Winsock1.RemotePort & "--" & eventArgs.bytesTotal & "     " & strData))
        If Form1.DefInstance.miNoProBack.Checked Then
            Winsock1.SendData(strData)
        End If
    End Sub

    Private Sub Command1_Click(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles Command1.Click
        Dim start_gprs_serverA As Object
        'Dim temp As Long
        'Dim tuserinfo As user_info
        'Dim userid1(1 To 12) As Byte
        'Dim i As Long

        'For i = 1 To 11
        '   userid1(i) = Asc(Mid("13900000000", i, 1))
        'Next

        'userid1(12) = 0

        '这里调用get_user_info函数
        'temp = get_user_info(userid1(1), tuserinfo)
        'Text3.Text = Text3.Text & StrConv(tuserinfo.m_logon_date, vbUnicode)
        '我这里只是显示了一个成员的值，你可以显示其他的
        'UPGRADE_WARNING: 数组 mess 的下限已从 1 更改为 0。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1033"”
        Dim mess(1024) As Byte
        Dim rvdata As data_record
        Dim result As Short
        'Dim i As Integer
        result = SetWorkMode(0) '兼容以前模式
        If result = 0 Then
            Form1.DefInstance.addtext(("阻塞模式"))
        ElseIf result = 1 Then
            Form1.DefInstance.addtext(("非阻塞模式")) 'use this mode on VB
            Timer3.Enabled = True
        Else
            Form1.DefInstance.addtext(("非阻塞模式:消息机制"))
        End If
        'UPGRADE_WARNING: 未能解析对象 start_gprs_serverA() 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"”
        'result = start_gprs_server(Form1.DefInstance.Handle.ToInt32, WM_USER + 103, srvport, mess(0))
        result = start_net_service(Form1.DefInstance.Handle.ToInt32, WM_USER + 103, srvport, mess(0))        
        If result = 0 Then
            'UPGRADE_ISSUE: 常量 vbUnicode 未升级。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup2070"”
            Form1.DefInstance.addtext(System.Text.UnicodeEncoding.Unicode.GetString(mess))
        Else
            'UPGRADE_ISSUE: 常量 vbUnicode 未升级。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup2070"”
            Form1.DefInstance.addtext("服务器启动失败" & System.Text.UnicodeEncoding.Unicode.GetString(mess))
        End If
        rvdata.Initialize()
        ' For i = 0 To 10
        result = do_read_proc(rvdata, mess(0), False)
        '  Next i

        Hook((Form1.DefInstance.Handle.ToInt32))

        If SysAutoM = 1 Then
            Timer1.Enabled = True
        End If

        Form1.DefInstance.StatusBar1.Panels.Item(2).Text = "启动"
        Form1.DefInstance.Toolbar1.Buttons.Item(1).Enabled = False
        Form1.DefInstance.Toolbar1.Buttons.Item(2).Enabled = True
        Form1.DefInstance.Toolbar1.Buttons.Item(3).Enabled = True
        Form1.DefInstance.Toolbar1.Buttons.Item(4).Enabled = True
        Form1.DefInstance.miStartServer.Enabled = False
        Form1.DefInstance.miStopServer.Enabled = True
        Form1.DefInstance.miOffLine.Enabled = True
        Form1.DefInstance.miSendData.Enabled = True
        Form1.DefInstance.miSendK.Enabled = True
        Form1.DefInstance.Text4.Text = "0"
    End Sub
End Class