📄 frmlogonlist.frm
字号:
VERSION 5.00
Object = "{5E9E78A0-531B-11CF-91F6-C2863C385E30}#1.0#0"; "msflxgrd.ocx"
Begin VB.Form frmLogonList
BorderStyle = 1 'Fixed Single
Caption = "当前登陆用户列表"
ClientHeight = 4395
ClientLeft = 45
ClientTop = 435
ClientWidth = 7080
Icon = "frmLogonList.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 4395
ScaleWidth = 7080
ShowInTaskbar = 0 'False
StartUpPosition = 2 '屏幕中心
Begin CheckIP.xpcmdbutton cmdRef
Height = 435
Left = 1470
TabIndex = 7
Top = 3690
Width = 1095
_ExtentX = 1931
_ExtentY = 767
Caption = "刷 新"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin VB.PictureBox picTray
Height = 525
Left = 330
Picture = "frmLogonList.frx":08CA
ScaleHeight = 465
ScaleWidth = 525
TabIndex = 6
Top = 4110
Width = 585
End
Begin VB.Timer tmrKill
Left = 930
Top = 3660
End
Begin VB.Timer tmr
Left = 390
Top = 3660
End
Begin CheckIP.xpcmdbutton cmdStop
Height = 435
Left = 4190
TabIndex = 5
Top = 3690
Width = 1095
_ExtentX = 1931
_ExtentY = 767
Caption = "停止服务"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin CheckIP.xpcmdbutton cmdClose
Height = 435
Left = 5550
TabIndex = 4
Top = 3690
Width = 1095
_ExtentX = 1931
_ExtentY = 767
Caption = "关 闭"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin CheckIP.xpcmdbutton cmdKill
Height = 435
Left = 2830
TabIndex = 3
Top = 3690
Width = 1095
_ExtentX = 1931
_ExtentY = 767
Caption = "停止用户"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin MSFlexGridLib.MSFlexGrid Grid
Height = 2115
Left = 510
TabIndex = 0
Top = 1020
Width = 6105
_ExtentX = 10769
_ExtentY = 3731
_Version = 393216
Cols = 5
FixedCols = 0
GridLines = 2
SelectionMode = 1
AllowUserResizing= 1
Appearance = 0
FormatString = " 登 陆 时 间|^ 计 算 机|^ IP 地 址 |^ 用 户 帐 号|^ 系 统 ID"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin VB.Line Line6
BorderColor = &H00FFFFFF&
X1 = 0
X2 = 7080
Y1 = 390
Y2 = 390
End
Begin VB.Line Line5
BorderColor = &H00C0C0C0&
X1 = 0
X2 = 7080
Y1 = 360
Y2 = 360
End
Begin VB.Line Line4
BorderColor = &H00808080&
X1 = 6930
X2 = 6930
Y1 = 540
Y2 = 3360
End
Begin VB.Line Line1
BorderColor = &H00FFFFFF&
X1 = 150
X2 = 150
Y1 = 540
Y2 = 3360
End
Begin VB.Line Line3
BorderColor = &H00808080&
X1 = 150
X2 = 6930
Y1 = 3360
Y2 = 3360
End
Begin VB.Label Label1
Caption = "登陆用户列表："
Height = 180
Left = 270
TabIndex = 2
Top = 720
Width = 1260
End
Begin VB.Line Line2
BorderColor = &H00FFFFFF&
X1 = 150
X2 = 6930
Y1 = 540
Y2 = 540
End
Begin VB.Label lblNow
Caption = "当前时间："
Height = 225
Left = 4290
TabIndex = 1
Top = 120
Width = 2655
End
End
Attribute VB_Name = "frmLogonList"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Sub cmdClose_Click()
Unload Me
End Sub
Private Sub cmdKill_Click()
If Grid.Text = "" Then Exit Sub
Dim Cmd As ADODB.Command
If MsgBox("您真的要终止对计算机" & Grid.TextMatrix(Grid.RowSel, 1) & _
"上所登陆用户的服务吗？（是/否）", vbQuestion + vbYesNo, "系统提示") = vbNo Then Exit Sub
On Error GoTo dow:
Set Cmd = New ADODB.Command
Cmd.ActiveConnection = Conn
Cmd.CommandText = "kill " & Grid.TextMatrix(Grid.RowSel, 4)
Cmd.CommandType = adCmdText
Cmd.Execute
Set Cmd = Nothing
Grid.RemoveItem Grid.RowSel
Exit Sub
dow:
MsgBox Err.Description, 16, "错误"
End Sub
Private Sub cmdRef_Click()
tmr_Timer
End Sub
Private Sub cmdStop_Click()
Dim Cmd As ADODB.Command
If cmdStop.Caption = "停止服务" Then
Set Cmd = New ADODB.Command
Cmd.ActiveConnection = Conn
Cmd.CommandText = "use master exec xp_cmdshell 'net pause mssqlserver' use pos"
Cmd.CommandType = adCmdText
Cmd.Execute
Set Cmd = Nothing
cmdStop.Caption = "启动服务"
cmdKill.Enabled = False
Grid.Enabled = False
MsgBox "服务已终止！", 64
Else
Set Cmd = New ADODB.Command
Cmd.ActiveConnection = Conn
Cmd.CommandText = "use master exec xp_cmdshell 'net continue mssqlserver' use pos"
Cmd.CommandType = adCmdText
Cmd.Execute
Set Cmd = Nothing
cmdStop.Caption = "停止服务"
cmdKill.Enabled = True
Grid.Enabled = True
MsgBox "服务已启动！", 64
End If
End Sub
Private Sub Form_Load()
lblNow.Caption = "当前时间： " & Format(Date$, "yyyy年mm月dd日")
picTray.Top = 10000
AddToTray picTray.Picture, "用户管理器", picTray
Call tmr_Timer
tmr.Interval = 10000
tmr.Enabled = True
End Sub
Private Sub Form_Unload(Cancel As Integer)
Shell_NotifyIconA NIM_DELETE, NI
End Sub
Private Sub Grid_DblClick()
tmr_Timer
End Sub
Private Sub tmr_Timer()
Dim Rst As ADODB.Recordset
Dim CRst As ADODB.Recordset
Dim SQL As String
Dim I As Integer
tmr.Enabled = False
Set Rst = New ADODB.Recordset
Rst.CursorLocation = adUseClient
Rst.Open "sp_who", Conn, adOpenStatic, adLockReadOnly, adCmdText
Grid.Rows = 1
Do While Not Rst.EOF
If IsNull(Rst.Fields("dbname")) Then GoTo ne
If Trim(Rst.Fields("dbname")) <> "pos" Then GoTo ne
Grid.Rows = Grid.Rows + 1
Set CRst = New ADODB.Recordset
CRst.CursorLocation = adUseClient
SQL = "select [time],ip,username from logon where hostname='" & _
Trim(Rst.Fields("hostname")) & "'"
CRst.Open SQL, Conn, adOpenStatic, adLockReadOnly, adCmdText
If Not CRst.EOF Then
Grid.TextMatrix(Grid.Rows - 1, 0) = CRst.Fields(0)
Grid.TextMatrix(Grid.Rows - 1, 2) = CRst.Fields(1)
Grid.TextMatrix(Grid.Rows - 1, 3) = CRst.Fields(2)
End If
CRst.Close
Grid.TextMatrix(Grid.Rows - 1, 1) = Trim(Rst.Fields("hostname"))
Grid.TextMatrix(Grid.Rows - 1, 4) = Rst.Fields("spid")
ne:
Rst.MoveNext
Loop
Set Rst = Nothing
tmr.Interval = 10000
tmr.Enabled = True
tmrKill.Interval = 5000
tmrKill.Enabled = True
End Sub
Private Sub tmrKill_Timer()
Dim Rst As ADODB.Recordset
Dim Cmd As ADODB.Command
Dim DBs As Collection
Dim Nows As Collection
Dim I As Integer
Dim J As Integer
tmrKill.Enabled = False
Set Nows = New Collection
For I = 1 To Grid.Rows
Nows.Add UCase(CStr(Grid.TextMatrix(1, 1)))
Next
Set Rst = New ADODB.Recordset
Rst.CursorLocation = adUseClient
Rst.Open "select hostname from logon", Conn, adOpenStatic, adLockReadOnly, adCmdText
If Rst.EOF Then Exit Sub
Set DBs = New Collection
For I = 1 To Rst.RecordCount
DBs.Add UCase(CStr(Rst.Fields(0).Value))
Rst.MoveNext
Next
Set Rst = Nothing
For I = 1 To Nows.Count
For J = DBs.Count To 1 Step -1
If Trim(DBs(J)) = Trim(Nows(I)) Then DBs.Remove J
Next
Next
If DBs.Count > 0 Then
Set Cmd = New ADODB.Command
Cmd.ActiveConnection = Conn
For I = 1 To DBs.Count
Cmd.CommandText = "delete from logon where hostname='" & DBs(I) & "'"
Cmd.CommandType = adCmdText
Cmd.Execute
Next
Set Cmd = Nothing
End If
Set DBs = Nothing
Set Nows = Nothing
End Sub
Private Sub pictray_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim Msg As Long
Dim SQL As String
Msg = (X And &HFF) * &H100
Select Case Msg
Case 0 ' 鼠标移动在此输入你的代码
Case &HF00 ' 鼠标左键被按下
Me.WindowState = 0
Me.SetFocus
Case &H1E00 '右
Case &H2D00 ' 双击鼠标左键
Case &H3C00 ' 鼠标右键被按下
Me.WindowState = 0
Me.SetFocus
Case &H4B00 ' 鼠标右键弹起
Case &H5A00 ' 双击鼠标右键
End Select
End Sub
Private Sub AddToTray(TrayIcon, TrayText As String, TrayForm As PictureBox)
NI.cbSize = Len(NI)
NI.hwnd = TrayForm.hwnd
NI.uID = vbNull
NI.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
NI.uCallbackMessage = WM_MOUSEMOVE
NI.hIcon = TrayIcon
NI.szTip = TrayText & vbNullChar
Shell_NotifyIcon NIM_ADD, NI
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -