form1.frm

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

    Form1.miSendK.Enabled = True
    Form1.Text4.Text = "0"
End Sub

Private Sub miStopNoProService_Click()
    Winsock1.Close
    Form1.miStartNoProService.Enabled = True
    Form1.miStopNoProService.Enabled = False
    Form1.miNoProBack.Enabled = False
    Form1.addtext "无协议服务停止"
End Sub

Private Sub miStopServer_Click()
    Dim mess(1 To 1024) As Byte
    Dim result As Long
    Dim closeonemess(1 To 1024) As Byte
    
    result = do_close_all_user(mess(1))
    'result = stop_gprs_server(mess(1))
    result = stop_net_service(mess(1))
    Unhook Form1.hwnd
    If Timer1.Enabled = True Then
        Timer1.Enabled = False
    End If
    Form1.addtext (StrConv(mess, vbUnicode))
    Form1.ListView1.ListItems.Clear
    Form1.Text2.Text = ""
    Form1.StatusBar1.Panels.Item(2).Text = "停止"
    Form1.Toolbar1.Buttons.Item(1).Enabled = True
    Form1.Toolbar1.Buttons.Item(2).Enabled = False
    Form1.Toolbar1.Buttons.Item(3).Enabled = False
    Form1.Toolbar1.Buttons.Item(4).Enabled = False
    Form1.miStartServer.Enabled = True
    Form1.miStopServer.Enabled = False
    Form1.miOffLine.Enabled = False
    Form1.miSendData.Enabled = False
    Form1.miSendK.Enabled = False
    Form1.Text4.Text = "0"
End Sub

Private Sub miViewData_Click()
    miViewData.Checked = Not miViewData.Checked
End Sub

Private Sub StatusBar1_PanelDblClick(ByVal Panel As MSComctlLib.Panel)
    If Panel.Tag = 4 Then
        miAbout_Click
    End If
    If Panel.Tag = 3 Then
        Timer2.Enabled = Not Timer2.Enabled
        Panel.Text = ""
        If Timer2.Enabled = False Then
            Panel.Bevel = sbrRaised
        Else
            Panel.Bevel = sbrInset
        End If
    End If
End Sub


Private Sub Text1_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyReturn Then
        miSendData_Click
    End If
End Sub

Private Sub Timer1_Timer()
    Form1.pollusertable
End Sub

Public Function inttoip(intip() As Byte)
   Dim ipstr As String
   
   ipstr = ipstr & Str((intip(4) + 256) Mod 256)
   ipstr = ipstr & "."
   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)
   inttoip = ipstr
End Function

Public Sub pollusertable()
    Dim i As Long
    Dim itmX As ListItem
    Dim dstr As String
    Dim closeonemess(1 To 512) As Byte
    Dim temp As Long
    Dim tucount As Integer
    Dim tuserinfo As user_info
    Dim tmess(1 To 1024) As Byte
    Dim b As Date
    Dim t_update As Long
    Dim m1 As Long
    Dim m2 As Long
    
    b = #1/1/1970#
   
    tucount = get_max_user_amount()
    If tucount < 1 Then
        Exit Sub
    End If
    ListView1.ListItems.Clear
    
    m1 = 256
    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 ((Now - b) * 3600 * 24 - t_update) < waittime Then

                    Set itmX = ListView1.ListItems.Add
        
                    itmX.Text = StrConv(tuserinfo.m_userid, vbUnicode)

                    itmX.SubItems(1) = StrConv(tuserinfo.m_logon_date, vbUnicode)
                    itmX.SubItems(2) = inttoip(tuserinfo.m_local_addr)
                    itmX.SubItems(3) = Str(tuserinfo.m_local_port)
                    itmX.SubItems(4) = inttoip(tuserinfo.m_sin_addr)
                    itmX.SubItems(5) = Str(tuserinfo.m_sin_port)
                Else
                    temp = do_close_one_user(tuserinfo.m_userid(1), closeonemess(1))
                End If
            Else
                Set itmX = ListView1.ListItems.Add
        
                itmX.Text = StrConv(tuserinfo.m_userid, vbUnicode)

                itmX.SubItems(1) = StrConv(tuserinfo.m_logon_date, vbUnicode)
                itmX.SubItems(2) = inttoip(tuserinfo.m_local_addr)
                itmX.SubItems(3) = Str(tuserinfo.m_local_port)
                itmX.SubItems(4) = inttoip(tuserinfo.m_sin_addr)
                itmX.SubItems(5) = Str(tuserinfo.m_sin_port)
            End If
        End If
    Next
End Sub

Private Sub Timer2_Timer()
    Form1.StatusBar1.Panels.Item(3).Text = Now
End Sub

'当用户把API工作模式设置为0或1时(SetWorkMode)
'可以利用轮询方式来获取数据,而不需要采用消息机制
Private Sub Timer3_Timer()
      Dim lpPrevWndProc As Long
      Dim pcount As Long
      Dim rvdata As data_record
      Dim mess(1 To 1024) As Byte
      Dim result As Long
        '调用do_read_proc函数处理结果
          result = do_read_proc(rvdata, mess(1), Form1.miAnswer.Checked)
          If result = 0 Then
            
              If rvdata.m_data_len > 0 Then
              
                  pcount = Val(Form1.Text4.Text)
                  
                  If Form1.miViewData.Checked = True Then
                      If (pcount Mod 20) = 0 Then Form1.Text3.Text = ""
                      
                      Form1.addtext (vbNewLine)
                      Form1.addtext ("用户号码：" & StrConv(rvdata.m_userid, vbUnicode))
                      Form1.addtext ("接收时间：" & StrConv(rvdata.m_recv_date, vbUnicode))
                      Form1.addtext ("数据长度：" & Str(rvdata.m_data_len))
                      'Form1.addtext("aaa",true)
                      If Not Form1.miHEXShow.Checked Then
                          Form1.addtext ("接收数据：" & StrConv(rvdata.m_data_buf, vbUnicode))
                      Else
                          Form1.addtext ("接收数据：" & Form1.strtohexstr(rvdata.m_data_buf, rvdata.m_data_len))
                      End If
                  End If

                  If Form1.miCount.Checked = True Then
                  '显示颜色
                      Form1.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.Text4.BackColor = RGB(redcolor, greencolor, bluecolor)
                      Form1.Text4.ForeColor = RGB(255 - redcolor, 255 - greencolor, 255 - bluecolor)
                  End If
                  
              End If
              
              If rvdata.m_data_len = 0 Then
                  Form1.pollusertable
              End If

          End If
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
  Select Case Button.Tag
    Case 1
        miStartServer_Click
    Case 2
        miStopServer_Click
    Case 3
        miOffLine_Click
    Case 4
        miSendData_Click
    Case 5
        miClear_Click
    Case 7
        miQuit_Click
  End Select
End Sub

Public Sub addtext(Content As String, Optional anewline As Boolean = 1)
    If LineCount > 200 Then
        Form1.Text3.Text = ""
        LineCount = 0
    End If
    If IsMissing(anewline) Then
        Form1.Text3.Text = Form1.Text3.Text & vbNewLine & Content
    Else
        If anewline = True Then
            Form1.Text3.Text = Form1.Text3.Text & vbNewLine & Content
        Else
            Form1.Text3.Text = Form1.Text3.Text & Content
        End If
    End If
    LineCount = LineCount + 1
End Sub

Public Function strtohexstr(src() As Byte, ln As Integer)
    Dim i As Integer
    Dim st As String
    Dim temp As Integer
    
    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
    strtohexstr = st
End Function

Public Function hexstrtostr(src() As Byte, ln As Integer)
    Dim i As Integer
    Dim st As String
    Dim flag As Integer
    Dim temp As Integer
    Dim temp1 As Integer
    
    flag = 0
    
    For i = 1 To ln
        temp1 = -1
        '0-9
        If (src(i) >= &H30 And src(i) <= &H39) Then
            temp1 = src(i) - &H30
        End If
        'A-F
        If (src(i) >= &H41 And src(i) <= &H46) Then
            temp1 = src(i) - &H37
        End If
        'a-f
        If (src(i) >= &H61 And src(i) <= &H66) Then
            temp1 = src(i) - &H57
        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
    hexstrtostr = st
End Function

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
   Dim strData As String
   Winsock1.GetData strData, vbString
   Form1.addtext ("接收数据：" & _
   Winsock1.RemoteHostIP & ":" _
   & Winsock1.RemotePort & "--" _
   & bytesTotal & "     " _
   & strData)
   If Form1.miNoProBack.Checked Then
       Winsock1.SendData strData
   End If
End Sub