vb 有内存溢出
本帖最后由 bcrun 于 2013-04-19 13:12:54 编辑 只要是执行下面这段代码 内存就会不停的增加，我应该怎么调整下才能够不让内存溢出呢？
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long
Private Sub Form_Load()
Me.BorderStyle = 0
Me.Caption = ""
Me.WindowState = 2
End Sub
Private Sub Timer1_Timer()
If FindWindow("TFormLogin", vbNullString) <> 0 Then
Timer2.Enabled = True
Timer1.Enabled = False
End If
End Sub
Private Sub Timer2_Timer()
If FindProcess("BJMain.exe") = 0 Then
Timer2.Enabled = False
Unload Form6
End If
End Sub
Private Sub form6_unload()
Timer1.Enabled = False
Timer2.Enabled = False
Set Form6 = Nothing
End Sub
Option Explicit
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Declare Function NtQuerySystemInformation Lib "NTDLL.DLL" (ByVal dwInfoType As Long, lpStructure As Any, ByVal dwSize As Long, dwReserved As Long) As Long
Public Type LARGE_INTEGER
LowPart As Long
HighPart As Long
End Type
Public Type IO_COUNTERS
ReadOperationCount As LARGE_INTEGER
WriteOperationCount As LARGE_INTEGER
OtherOperationCount As LARGE_INTEGER
ReadTransferCount As LARGE_INTEGER
WriteTransferCount As LARGE_INTEGER
OtherTransferCount As LARGE_INTEGER
End Type
Public Type VM_COUNTERS
PeakVirtualSize As Long
VirtualSize As Long
PageFaultCount As Long
PeakWorkingSetSize As Long
WorkingSetSize As Long
QuotaPeakPagedPoolUsage As Long
QuotaPagedPoolUsage As Long
QuotaPeakNonPagedPoolUsage As Long
QuotaNonPagedPoolUsage As Long
PagefileUsage As Long
PeakPagefileUsage As Long
End Type
Public Type CLIENT_ID
UniqueProcess As Long
UniqueThread As Long
End Type
Public Type SYSTEM_THREAD_INFORMATION
KernelTime As LARGE_INTEGER
UserTime As LARGE_INTEGER
CreateTime As LARGE_INTEGER
WaitTime As Long
StartAddress As Long 'pointer
ClientId As CLIENT_ID
Priority As Long
BasePriority As Long
ContextSwitchCount As Long
State As Long 'THREAD_STATE
WaitReason As Long 'KWAIT_REASON
End Type
Public Type UNICODE_STRING
Length As Integer
MaximumLength As Integer
buffer As Long
End Type
Public Type SYSTEM_PROCESS_INFORMATION
NextEntryDelta As Long
ThreadCount As Long
Reserved1(5) As Long
CreateTime As LARGE_INTEGER
UserTime As LARGE_INTEGER
KernelTime As LARGE_INTEGER
ProcessName As UNICODE_STRING
BasePriority As Long
ProcessID As Long
InheritedFromProcessId As Long
HandleCount As Long
Reserved2(1) As Long
VmCounters As VM_COUNTERS
IoCounters As IO_COUNTERS
Threads(0) As SYSTEM_THREAD_INFORMATION
End Type
Public Const SystemProcessesAndThreadsInformation = 5
Public Function Li2Double(X As LARGE_INTEGER) As Double
Li2Double = CDbl(X.HighPart) * 4294967296# + CDbl(X.LowPart)
End Function
Option Explicit
Private Sub Command1_Click()
Dim Process As SYSTEM_PROCESS_INFORMATION '进程结构
Dim buf() As Byte '接受信息BYTE
Dim buffer As Long '缓冲区长度
Dim NextProcess As Long '下个进程偏移量
Dim ProcessName As String '进程名
buffer = LenB(Process)
ReDim buf(buffer)
Do While NtQuerySystemInformation(SystemProcessesAndThreadsInformation, buf(0), buffer, 0)
buffer = buffer * 2
ReDim buf(buffer)
Loop
'执行成功后
CopyMemory Process, buf(0), LenB(Process) '复制BYTE数据到进程结构
Do While Process.NextEntryDelta <> 0 '如果存在下个链表
NextProcess = Process.NextEntryDelta + NextProcess '下个进程地址
CopyMemory Process, buf(NextProcess), LenB(Process) '复制BYTE数据到进程结构
ProcessName = Space(Process.ProcessName.Length / 2) '缓冲区
CopyMemory ByVal StrPtr(ProcessName), ByVal Process.ProcessName.buffer, Process.ProcessName.Length '还原字符串
List1.AddItem Process.ProcessID & vbTab & ProcessName & vbTab & Li2Double(Process.UserTime)
Loop
End Sub
Private Sub Command2_Click()
Dim i As Long
For i = 0 To List1.ListCount - 1
If InStr(1, List1.List(i), "BJMain.exe") > 0 Then
Set Form6 = Nothing: Exit For
End If
Next
End Sub
