form1.vb

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

		miCount_Click(eventSender, eventArgs)
	End Sub
	Public Sub miCount_Click(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles miCount.Click
		miCount.Checked = Not miCount.Checked
	End Sub
	
	Public Sub miHelpContent_Popup(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles miHelpContent.Popup
		miHelpContent_Click(eventSender, eventArgs)
	End Sub
	Public Sub miHelpContent_Click(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles miHelpContent.Click
		FHelp.DefInstance.ShowDialog()
	End Sub
	
	Public Sub miHEXShow_Popup(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles miHEXShow.Popup
		miHEXShow_Click(eventSender, eventArgs)
	End Sub
	Public Sub miHEXShow_Click(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles miHEXShow.Click
		miHEXShow.Checked = Not miHEXShow.Checked
	End Sub
	
	Public Sub miNoProBack_Popup(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles miNoProBack.Popup
		miNoProBack_Click(eventSender, eventArgs)
	End Sub
	Public Sub miNoProBack_Click(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles miNoProBack.Click
		Form1.DefInstance.miNoProBack.Checked = Not Form1.DefInstance.miNoProBack.Checked
	End Sub
	
	Public Sub miOffLine_Popup(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles miOffLine.Popup
		miOffLine_Click(eventSender, eventArgs)
	End Sub
	Public Sub miOffLine_Click(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles miOffLine.Click
		Dim i As Integer
		'UPGRADE_WARNING: 数组 closeoneid 的下限已从 1 更改为 0。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1033"”
		Dim closeoneid(12) As Byte
		'UPGRADE_WARNING: 数组 closeonemess 的下限已从 1 更改为 0。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1033"”
		Dim closeonemess(1024) As Byte
		
		If Len(Text2.Text) <> 11 Then Exit Sub
		
		For i = 1 To 11
			closeoneid(i) = Asc(Mid(Form1.DefInstance.Text2.Text, i, 1))
		Next 
		closeoneid(12) = 0
        i = do_close_one_user(closeoneid(1), closeonemess(0))
        ListView1.ListItems.Remove((ListView1.SelectedItem.Index))
    End Sub


    Public Sub miQuit_Popup(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles miQuit.Popup
        miQuit_Click(eventSender, eventArgs)
    End Sub
    Public Sub miQuit_Click(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles miQuit.Click
        If MsgBox("确定要退出吗？", MsgBoxStyle.YesNo, "确认") = MsgBoxResult.Yes Then
            If Form1.DefInstance.Toolbar1.Buttons.Item(2).Enabled = True Then
                miStopServer_Click(miStopServer, New System.EventArgs)
            End If

            End
        End If
    End Sub

    Public Sub miSendData_Popup(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles miSendData.Popup
        miSendData_Click(eventSender, eventArgs)
    End Sub
    Public Sub miSendData_Click(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles miSendData.Click
        Dim i As Integer
        Dim sendresult As Integer
        'UPGRADE_WARNING: 数组 sendsrc 的下限已从 1 更改为 0。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1033"”
        Dim sendsrc(1024) As Byte
        Dim sendsrclen As Integer
        'UPGRADE_WARNING: 数组 sendmess 的下限已从 1 更改为 0。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1033"”
        Dim sendmess(1024) As Byte
        'UPGRADE_WARNING: 数组 senduserid 的下限已从 1 更改为 0。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1033"”
        Dim senduserid(12) As Byte        

        If Len(Text2.Text) <> 11 Then
            Exit Sub
        End If

        For i = 1 To 11
            senduserid(i) = Asc(Mid(Text2.Text, i, 1))
        Next
        senduserid(12) = 0

        sendsrclen = System.Text.Encoding.Default.GetByteCount(Text1.Text)        
        'sendsrclen = Len(Text1.Text)                
        If Me.ckHex.CheckState = 1 Then '十六进制发送
            sendsrclen = Len(Text1.Text) / 2
            For i = 1 To sendsrclen
                sendsrc(i - 1) = Val("&H" & Mid(Text1.Text, (i - 1) * 2 + 1, 2))
            Next            
        Else
            sendsrc = System.Text.Encoding.Default.GetBytes(Text1.Text)
            'For i = 1 To sendsrclen
            'sendsrc(i) = Asc(Mid(Text1.Text, i, 1))
            'Next
        End If
        'sendsrc(1) = 255
        'sendsrc(2) = 255
        'sendsrc(3) = 105
        'sendsrc(4) = 3
        'sendsrc(5) = 3
        'sendsrc(6) = 105
        sendresult = do_send_user_data(senduserid(1), sendsrc(0), sendsrclen, sendmess(0))
        'sendresult = do_send_user_data(senduserid(1), sendsrc(1), 6, sendmess(0))
        If sendresult = 0 Then
            Form1.DefInstance.addtext(("向 " & Form1.DefInstance.Text2.Text & " 发送数据：" & Form1.DefInstance.Text1.Text))
        Else
            'UPGRADE_ISSUE: 常量 vbUnicode 未升级。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup2070"”
            Form1.DefInstance.addtext("发送失败：" & System.Text.UnicodeEncoding.Unicode.GetString(sendmess))
        End If
    End Sub

    Public Sub miSendK_Popup(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles miSendK.Popup
        miSendK_Click(eventSender, eventArgs)
    End Sub
    Public Sub miSendK_Click(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles miSendK.Click
        If Len(Form1.DefInstance.Text2.Text) = 11 Then
            FSend.DefInstance.Text2.Text = Form1.DefInstance.Text2.Text
            FSend.DefInstance.ShowDialog()
        End If
    End Sub

    Public Sub miSetting_Popup(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles miSetting.Popup
        miSetting_Click(eventSender, eventArgs)
    End Sub
    Public Sub miSetting_Click(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles miSetting.Click
        FSetting.DefInstance.ShowDialog()
    End Sub

    Public Sub miStartNoProService_Popup(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles miStartNoProService.Popup
        miStartNoProService_Click(eventSender, eventArgs)
    End Sub
    Public Sub miStartNoProService_Click(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles miStartNoProService.Click
        Winsock1.Bind(srvport)
        Form1.DefInstance.miStartNoProService.Enabled = False
        Form1.DefInstance.miStopNoProService.Enabled = True
        Form1.DefInstance.miNoProBack.Enabled = True
        Form1.DefInstance.addtext("无协议服务启动")
    End Sub

    Public Sub miStartServer_Popup(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles miStartServer.Popup
        miStartServer_Click(eventSender, eventArgs)
    End Sub
    Public Sub miStartServer_Click(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles miStartServer.Click
        'UPGRADE_WARNING: 数组 mess 的下限已从 1 更改为 0。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1033"”
        Dim mess(1024) As Byte
        Dim result As Short
        Dim a As String
        result = SetWorkMode(1) '兼容以前模式
        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
        '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.Encoding.Default.GetString(mess))
        Else
            'UPGRADE_ISSUE: 常量 vbUnicode 未升级。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup2070"”
            Form1.DefInstance.addtext("服务器启动失败" & System.Text.Encoding.Default.GetString(mess))
        End If

        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

    Public Sub miStopNoProService_Popup(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles miStopNoProService.Popup
        miStopNoProService_Click(eventSender, eventArgs)
    End Sub
    Public Sub miStopNoProService_Click(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles miStopNoProService.Click
        Winsock1.Close()
        Form1.DefInstance.miStartNoProService.Enabled = True
        Form1.DefInstance.miStopNoProService.Enabled = False
        Form1.DefInstance.miNoProBack.Enabled = False
        Form1.DefInstance.addtext("无协议服务停止")
    End Sub

    Public Sub miStopServer_Popup(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles miStopServer.Popup
        miStopServer_Click(eventSender, eventArgs)
    End Sub
    Public Sub miStopServer_Click(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles miStopServer.Click
        '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
        'UPGRADE_WARNING: 数组 closeonemess 的下限已从 1 更改为 0。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1033"”
        Dim closeonemess(1024) As Byte

        result = do_close_all_user(mess(0))
        'result = stop_gprs_server(mess(0))
        result = stop_net_service(mess(0))        
        Unhook(Form1.DefInstance.Handle.ToInt32)
        If Timer1.Enabled = True Then
            Timer1.Enabled = False
        End If
        'UPGRADE_ISSUE: 常量 vbUnicode 未升级。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup2070"”
        Form1.DefInstance.addtext(System.Text.Encoding.Default.GetString(mess))
        Form1.DefInstance.ListView1.ListItems.Clear()
        Form1.DefInstance.Text2.Text = ""
        Form1.DefInstance.StatusBar1.Panels.Item(2).Text = "停止"
        Form1.DefInstance.Toolbar1.Buttons.Item(1).Enabled = True
        Form1.DefInstance.Toolbar1.Buttons.Item(2).Enabled = False
        Form1.DefInstance.Toolbar1.Buttons.Item(3).Enabled = False
        Form1.DefInstance.Toolbar1.Buttons.Item(4).Enabled = False
        Form1.DefInstance.miStartServer.Enabled = True
        Form1.DefInstance.miStopServer.Enabled = False
        Form1.DefInstance.miOffLine.Enabled = False
        Form1.DefInstance.miSendData.Enabled = False
        Form1.DefInstance.miSendK.Enabled = False
        Form1.DefInstance.Text4.Text = "0"
    End Sub

    Public Sub miViewData_Popup(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles miViewData.Popup
        miViewData_Click(eventSender, eventArgs)
    End Sub
    Public Sub miViewData_Click(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles miViewData.Click
        miViewData.Checked = Not miViewData.Checked
    End Sub

    Private Sub StatusBar1_PanelDblClick(ByVal eventSender As System.Object, ByVal eventArgs As AxMSComctlLib.IStatusBarEvents_PanelDblClickEvent) Handles StatusBar1.PanelDblClick
        If eventArgs.panel.Tag = 4 Then
            miAbout_Click(miAbout, New System.EventArgs)
        End If
        If eventArgs.panel.Tag = 3 Then
            Timer2.Enabled = Not Timer2.Enabled
            eventArgs.panel.Text = ""
            If Timer2.Enabled = False Then
                eventArgs.panel.Bevel = MSComctlLib.PanelBevelConstants.sbrRaised
            Else
                eventArgs.panel.Bevel = MSComctlLib.PanelBevelConstants.sbrInset
            End If
        End If
    End Sub


    Private Sub Text1_KeyDown(ByVal eventSender As System.Object, ByVal eventArgs As System.Windows.Forms.KeyEventArgs) Handles Text1.KeyDown
        Dim KeyCode As Short = eventArgs.KeyCode
        Dim Shift As Short = eventArgs.KeyData \ &H10000
        If KeyCode = System.Windows.Forms.Keys.Return Then
            miSendData_Click(miSendData, New System.EventArgs)
        End If
    End Sub

    Private Sub Timer1_Tick(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles Timer1.Tick
        Form1.DefInstance.pollusertable()
    End Sub

    Public Function inttoip(ByRef intip() As Byte) As Object
        Dim ipstr As String

        ipstr = ipstr & Str((intip(3) + 256) Mod 256)
        ipstr = ipstr & "."
        ipstr = ipstr & Str((intip(2) + 256) Mod 256)
        ipstr = ipstr & "."
        ipstr = ipstr & Str((intip(1) + 256) Mod 256)
        ipstr = ipstr & "."
        ipstr = ipstr & Str((intip(0) + 256) Mod 256)
        'UPGRADE_WARNING: 未能解析对象 inttoip 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"”
        inttoip = ipstr
    End Function

    Public Sub pollusertable()
        Dim i As Integer
        Dim itmX As MSComctlLib.ListItem
        Dim dstr As String
        'UPGRADE_WARNING: 数组 closeonemess 的下限已从 1 更改为 0。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1033"”
        Dim closeonemess(512) As Byte
        Dim temp As Integer
        Dim tucount As Short
        Dim tuserinfo As user_info
        'UPGRADE_WARNING: 数组 tmess 的下限已从 1 更改为 0。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1033"”
        Dim tmess(1024) As Byte
        Dim b As Date
        Dim t_update As Integer
        Dim m1 As Integer
        Dim m2 As Integer

        b = #1/1/1970#

        tucount = get_max_user_amount()
        If tucount < 1 Then
            Exit Sub
        End If
        ListView1.ListItems.Clear()

        m1 = 256