frmmain.frm

TCP-IP数据库查询.zip

'        * Possibility to capture string from Client or Server Appl
'           And replace it in a other string..
'        Example if you application (client) sends
'        #this is okay#Peter#test  & you want to change Peter
'        to Dirk .. then it will capture the data & replace it
'        to  #this is okay#Dirk#test
'        * Helpbox
'
'----------------------------------------------------------
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Any) As Long
Const EM_UNDO = &HC7
Private Declare Function OSWinHelp% Lib "user32" Alias "WinHelpA" (ByVal hwnd&, ByVal HelpFile$, ByVal wCommand%, dwData As Any)

Private Sub MDIForm_Load()
    Me.Left = GetSetting(App.Title, "Settings", "MainLeft", 1000)
    Me.Top = GetSetting(App.Title, "Settings", "MainTop", 1000)
    Me.Width = GetSetting(App.Title, "Settings", "MainWidth", 6500)
    Me.Height = GetSetting(App.Title, "Settings", "MainHeight", 6500)
    'setting for the Colors..
    IP.RTColorLocaal = vbRed
    IP.RTColorRemote = vbBlue
    'Disable TextView ..
    Settings.EnableTXT = True
    Settings.DC_Total = True
End Sub


Private Sub LoadNewDoc()
    Static lDocumentCount As Long
    Dim frmD As frmDocument
    lDocumentCount = lDocumentCount + 1
    Set frmD = New frmDocument
    'frmD.Caption = "Waiting from input dialogbox."
   ' frmD.blnDialogShow = True
    frmD.Show
End Sub


Private Sub MDIForm_Unload(Cancel As Integer)
    If Me.WindowState <> vbMinimized Then
        SaveSetting App.Title, "Settings", "MainLeft", Me.Left
        SaveSetting App.Title, "Settings", "MainTop", Me.Top
        SaveSetting App.Title, "Settings", "MainWidth", Me.Width
        SaveSetting App.Title, "Settings", "MainHeight", Me.Height
    End If
End Sub

Private Sub tbToolBar_ButtonClick(ByVal Button As MSComCtlLib.Button)
    On Error Resume Next
    Select Case Button.Key
        Case "NewConnection"
        
            IP.DialogInfo = 0
            Dialog.Show (vbModal)
         While (IP.DialogInfo = 0)
            DoEvents
         Wend
            If IP.DialogInfo = 1 Then
            LoadNewDoc
            End If
        
        
        '---------------- SAVE AS ---------------
        Case "Save"
        mnuFileSaveAs_Click
        
    End Select
End Sub

Private Sub mnuHelpAbout_Click()
    MsgBox "Version " & App.Major & "." & App.Minor & "." & App.Revision & vbCrLf & _
    "Created by Verburgh Peter"
    
End Sub

Private Sub mnuHelpSearchForHelpOn_Click()
    Dim nRet As Integer


    'if there is no helpfile for this project display a message to the user
    'you can set the HelpFile for your application in the
    'Project Properties dialog
    If Len(App.HelpFile) = 0 Then
        MsgBox "Unable to display Help Contents. There is no Help associated with this project.", vbInformation, Me.Caption
    Else
        On Error Resume Next
        nRet = OSWinHelp(Me.hwnd, App.HelpFile, 261, 0)
        If Err Then
            MsgBox Err.Description
        End If
    End If

End Sub

Private Sub mnuHelpContents_Click()
    Dim nRet As Integer


    'if there is no helpfile for this project display a message to the user
    'you can set the HelpFile for your application in the
    'Project Properties dialog
    If Len(App.HelpFile) = 0 Then
        MsgBox "Unable to display Help Contents. There is no Help associated with this project.", vbInformation, Me.Caption
    Else
        On Error Resume Next
        nRet = OSWinHelp(Me.hwnd, App.HelpFile, 3, 0)
        If Err Then
            MsgBox Err.Description
        End If
    End If

End Sub


Private Sub mnuWindowArrangeIcons_Click()
    Me.Arrange vbArrangeIcons
End Sub

Private Sub mnuWindowTileVertical_Click()
    Me.Arrange vbTileVertical
End Sub

Private Sub mnuWindowTileHorizontal_Click()
    Me.Arrange vbTileHorizontal
End Sub

Private Sub mnuWindowCascade_Click()
    Me.Arrange vbCascade
End Sub

Private Sub mnuWindowNewWindow_Click()
    LoadNewDoc
End Sub

Private Sub mnuViewWebBrowser_Click()
    'ToDo: Add 'mnuViewWebBrowser_Click' code.
    MsgBox "Add 'mnuViewWebBrowser_Click' code."
End Sub




Private Sub mnuViewStatusBar_Click()
    mnuViewStatusBar.Checked = Not mnuViewStatusBar.Checked
    sbStatusBar.Visible = mnuViewStatusBar.Checked
End Sub

Private Sub mnuViewToolbar_Click()
    mnuViewToolbar.Checked = Not mnuViewToolbar.Checked
    tbToolBar.Visible = mnuViewToolbar.Checked
End Sub



Private Sub mnuEditPaste_Click()
    On Error Resume Next
    ActiveForm.rtfText.SelRTF = Clipboard.GetText

End Sub

Private Sub mnuEditCopy_Click()
    On Error Resume Next
    Clipboard.SetText ActiveForm.rtfText.SelRTF

End Sub

Private Sub mnuEditCut_Click()
    On Error Resume Next
    Clipboard.SetText ActiveForm.rtfText.SelRTF
    ActiveForm.rtfText.SelText = vbNullString

End Sub

Private Sub mnuEditUndo_Click()
    'ToDo: Add 'mnuEditUndo_Click' code.
    MsgBox "Add 'mnuEditUndo_Click' code."
End Sub


Private Sub mnuFileExit_Click()
    'unload the form
    Unload Me

End Sub



Private Sub mnuFilePrint_Click()
    On Error Resume Next
    If ActiveForm Is Nothing Then Exit Sub
    

    With dlgCommonDialog
        .DialogTitle = "Print"
        .CancelError = True
        .Flags = cdlPDReturnDC + cdlPDNoPageNums
        If ActiveForm.rtfText.SelLength = 0 Then
            .Flags = .Flags + cdlPDAllPages
        Else
            .Flags = .Flags + cdlPDSelection
        End If
        .ShowPrinter
        If Err <> MSComDlg.cdlCancel Then
            ActiveForm.rtfText.SelPrint .hDC
        End If
    End With

End Sub

Private Sub mnuFilePrintPreview_Click()
    'ToDo: Add 'mnuFilePrintPreview_Click' code.
    MsgBox "Add 'mnuFilePrintPreview_Click' code."
End Sub

Private Sub mnuFilePageSetup_Click()
    On Error Resume Next
    With dlgCommonDialog
        .DialogTitle = "Page Setup"
        .CancelError = True
        .ShowPrinter
    End With

End Sub

Private Sub mnuFileProperties_Click()
    'ToDo: Add 'mnuFileProperties_Click' code.
    MsgBox "Add 'mnuFileProperties_Click' code."
End Sub

Private Sub mnuFileSaveAll_Click()
    'ToDo: Add 'mnuFileSaveAll_Click' code.
    MsgBox "Add 'mnuFileSaveAll_Click' code."
End Sub

Private Sub mnuFileSaveAs_Click()
    Dim sFile As String
    

    If ActiveForm Is Nothing Then Exit Sub
    

    With dlgCommonDialog
        .DialogTitle = "Save As"
        .CancelError = False
        'ToDo: set the flags and attributes of the common dialog control
        .Filter = "Doc Files- Datalook (*.IPD)|*.IPD"
        .ShowSave
        If Len(.FileName) = 0 Then
            Exit Sub
        End If
        sFile = .FileName
    End With
    ActiveForm.Caption = sFile
    ActiveForm.RTBox.SaveFile sFile

End Sub





Private Sub mnuFileOpen_Click()
    Dim sFile As String

Settings.Fileopen = True
   ' If ActiveForm Is Nothing Then LoadNewDoc
   LoadNewDoc

    With dlgCommonDialog
        .DialogTitle = "Open"
        .CancelError = False
        'ToDo: set the flags and attributes of the common dialog control
        .Filter = "Doc Files- Datalook (*.IPD)|*.IPD"
        .ShowOpen
        If Len(.FileName) = 0 Then
            Exit Sub
        End If
        sFile = .FileName
    End With
    ActiveForm.RTBox.LoadFile sFile
    ActiveForm.Caption = sFile

End Sub

Private Sub mnuFileNew_Click()
IP.DialogInfo = 0
    Dialog.Show (vbModal)
    While (IP.DialogInfo = 0)
    DoEvents
    Wend
    If IP.DialogInfo = 1 Then
    LoadNewDoc
    End If
End Sub

Private Sub Form_Resize()
    Dim a As Integer
    lvMain.Width = lvMain.Parent.Width - 100
    lvMain.Height = lvMain.Parent.Height - 850
    
    For a = 2 To lvMain.ColumnHeaders.Count
        lvMain.ColumnHeaders(a).Width = (frmMain.Width - 100) / (lvMain.ColumnHeaders.Count - 1) - 600
    Next a
End Sub


Private Sub mnuContextKill_Click()
    ipsMain.RowData(lvMain.SelectedItem.Tag).Kill
End Sub

Private Sub tmrRefresh_Timer()
    Dim a As Integer
    Dim intLVPtr As Integer
    
    ipsMain.getTCPConnections
    
    'Update routine - if the existing entry is the same as this one, leave it, otherwise overwrite it.
    intlvpointer = 0
    For a = 0 To ipsMain.RowCount - 1
        If ipsMain.RowData(a).State <> TCP_STATE_LISTEN Then
            intLVPtr = intLVPtr + 1
            'If we are past the bounds of the current array, add a new line
            If intLVPtr > lvMain.ListItems.Count Then
                lvMain.ListItems.Add , , ipsMain.RowData(a).LocalPort, , ipsMain.RowData(a).StateText
                lvMain.ListItems(intLVPtr).ToolTipText = ipsMain.RowData(a).StateText
                lvMain.ListItems(lvMain.ListItems.Count).ListSubItems.Add , , ipsMain.RowData(a).RemoteIPString & ":" & ipsMain.RowData(a).RemotePort
                'lvMain.ListItems(lvMain.ListItems.Count).ListSubItems.Add , , "Retrieving..."
                lvMain.Refresh
                'lvMain.ListItems(lvMain.ListItems.Count).ListSubItems(2).Text = iphDNS.AddressToName(ipsMain.RowData(a).RemoteIPString)
                lvMain.ListItems(lvMain.ListItems.Count).Tag = a
            Else
                'We are still in the bounds. If the current
                'entry equals the one to insert, just change
                'the icon. Otherwise, overwrite it.
                If lvMain.ListItems(intLVPtr).Text = ipsMain.RowData(a).LocalPort And lvMain.ListItems(intLVPtr).ListSubItems(1).Text = ipsMain.RowData(a).RemoteIPString & ":" & ipsMain.RowData(a).RemotePort And lvMain.ListItems(intLVPtr).Tag = a Then
                    'lvMain.ListItems(intLVPtr).SmallIcon = ipsMain.RowData(a).StateText
                    If lvMain.ListItems(intLVPtr).SmallIcon <> ipsMain.RowData(a).StateText Then
                        lvMain.ListItems(intLVPtr).SmallIcon = ipsMain.RowData(a).StateText
                        lvMain.ListItems(intLVPtr).ToolTipText = ipsMain.RowData(a).StateText
                    End If
                Else
                    'Different, overwrite it.
                    lvMain.ListItems(intLVPtr).Text = ipsMain.RowData(a).LocalPort
                    lvMain.ListItems(intLVPtr).ListSubItems(1).Text = ipsMain.RowData(a).RemoteIPString & ":" & ipsMain.RowData(a).RemotePort
                   ' lvMain.ListItems(lvMain.ListItems.Count).ListSubItems(2).Text = "Retrieving..."
                    lvMain.Refresh
                   ' lvMain.ListItems(lvMain.ListItems.Count).ListSubItems(2).Text = iphDNS.AddressToName(ipsMain.RowData(a).RemoteIPString)
                    lvMain.ListItems(intLVPtr).Tag = a
                    lvMain.ListItems(intLVPtr).SmallIcon = ipsMain.RowData(a).StateText
                    lvMain.ListItems(intLVPtr).ToolTipText = ipsMain.RowData(a).StateText
                End If
            End If
        End If
    Next a
    
    'If there are more listitem entries than connections, kill the extra ones.
    For a = lvMain.ListItems.Count To intLVPtr + 1 Step -1
        lvMain.ListItems.Remove a
    Next a
End Sub

Private Sub txtUpdate_Change()
    tmrRefresh.Interval = Val(txtUpdate.Text)
End Sub