程序内存占用问题

Question

为什么我的一个监控程序运行的程序，占用内存超大，会占用系统上G的内存量，但打开任务管理器看到的却是实际内存使用4M，虚拟内存使用1.3M，其他的在哪呢，一关闭这个程序，系统马上恢复正常，这个程序也不是说一开就耗内存的，有时开一天占用几百M,上G，有时没那么明显，哪位高手能帮我解答一下，先谢谢啦!

Answer 1

...会占用系统上G的内存量，但打开任务管理器看到的却是实际内存使用4M..
---------
既然这样,你是如何得知占用了上G的内存呢?

Answer 2

那么就看看任务管理器中谁占用内存多。
也许是数据库，也许是双exe软件。

Answer 3

在哪里看到是占用上G的内存，刚刚才看到，系统总内存使用量为1.9G，把我的这个程序关闭后内存使用总数为230M，那肯定剩下的1.7个G的内存是给我这个程序给吃掉了，但奇怪的是单独查看我的这个程序的内存使用，实际内存4.几M，虚拟内存1.几M，其他的没显示
谢谢各位的热心解答

Answer 4

代码如下：
'form1.codeConst TH32CS_SNAPHEAPLIST = &H1
Const TH32CS_SNAPPROCESS = &H2
Const TH32CS_SNAPTHREAD = &H4
Const TH32CS_SNAPMODULE = &H8
Const TH32CS_SNAPALL = (TH32CS_SNAPHEAPLIST Or TH32CS_SNAPPROCESS Or TH32CS_SNAPTHREAD Or TH32CS_SNAPMODULE)
Const TH32CS_INHERIT = &H80000000
Const MAX_PATH As Integer = 260
Private Type PROCESSENTRY32
dwSize As Long
cntUsage As Long
th32ProcessID As Long
th32DefaultHeapID As Long
th32ModuleID As Long
cntThreads As Long
th32ParentProcessID As Long
pcPriClassBase As Long
dwFlags As Long
szExeFile As String * MAX_PATH
End Type
Private Declare Function CreateToolhelp32Snapshot Lib "kernel32" (ByVal lFlags As Long, ByVal lProcessID As Long) As Long
Private Declare Function Process32First Lib "kernel32" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function Process32Next Lib "kernel32" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Sub ExitProcess Lib "kernel32" (ByVal uExitCode As Long)
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As LongPrivate Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SendMessageTimeout Lib "user32" Alias "SendMessageTimeoutA" _
(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As _
Long, ByVal fuFlags As Long, ByVal uTimeout As Long, lpdwResult As Long) As Long
Private modObjIE As Object
Private modlngWndIE As Long
Const SMTO_BLOCK = &H1
Const SMTO_ABORTIFHUNG = &H2
Const WM_NULL = &H0
Const WM_CLOSE = &H10
Const PROCESS_ALL_ACCESS = &H1F0FFF
'API functions
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, _
lpdwProcessId As Long) As LongPrivate Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As LongPrivate Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, _
ByVal uExitCode As Long) As LongPrivate Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)Function exitproc(ByVal exefile As String) As Boolean
exitproc = False
Dim hSnapShot As Long, uProcess As PROCESSENTRY32
hSnapShot = CreateToolhelp32Snapshot(TH32CS_SNAPALL, 0&)
uProcess.dwSize = Len(uProcess)
r = Process32First(hSnapShot, uProcess)
Do While r
If LCase(Left$(uProcess.szExeFile, IIf(InStr(1, uProcess.szExeFile, Chr$(0)) > 0, InStr(1, uProcess.szExeFile, Chr$(0)) - 1, 0))) = LCase(exefile) Then
exitproc = True
Exit Do
End If
r = Process32Next(hSnapShot, uProcess)
Loop
End FunctionPrivate Sub Command1_Click()
If exitproc("程序1.exe") = True Then
'MsgBox "存在！"
Label2.Caption = "True"
Else
If Dir(App.Path & "\程序1.exe") <> "" Then
    Shell "程序1.exe", vbHide
Else
    MsgBox "程序1.exe文件不存在!" & vbCrLf & "请检查文件路径是否正确!", vbOKOnly, ""
End If
Label2.Caption = "False"
'MsgBox "不存在！"
End If
If exitproc("程序2.exe") = True Then
'MsgBox "存在！"
Label4.Caption = "True"
Else
If Dir("程序2.exe") <> "" Then
    Shell "程序2.exe", vbNormalFocus
Else
    MsgBox "程序2.exe文件不存在!" & vbCrLf & "请检查文件路径是否正确!", vbOKOnly, ""
End If
Label4.Caption = "False"
'MsgBox "不存在！"
End IfEnd SubPrivate Sub Form_Load()
If App.PrevInstance Then
'    MsgBox "The Program is running.", vbOKOnly, ""
    Unload Me
    Exit Sub
End IfIf exitproc("explorer.exe") = True Then
    Shell "cmd /c taskkill /f /im explorer.exe", 0    '结束explorer.exe进程
End If
HookForm Me
If exitproc("程序2.exe") = False And Dir(App.Path & "\程序2.exe") <> "" Then
    Shell App.Path & "\程序2.exe", vbNormalFocus
End If
If exitproc("程序1.exe") = False And Dir(App.Path & "\程序1.exe") <> "" Then
    Shell App.Path & "\程序1.exe", vbHide
End If
Timer3.Enabled = True
Timer1.Enabled = True
End SubPublic Sub KillProcess(ByVal strProcess As String)
    
          Dim strComputer     As String
          Dim objWMIService     As Object
          Dim colProcessList
          Dim objProcess     As Object
            
          On Error Resume Next
            
          strComputer = "."
          Set objWMIService = GetObject("winmgmts:" _
                  & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
  '                 strProcess   =   "Excel.exe"
          Set colProcessList = objWMIService.ExecQuery _
                  ("Select   *   from   Win32_Process   Where   Name   =   '" & strProcess & "'")
          For Each objProcess In colProcessList
                  objProcess.Terminate
          Next
            
  End SubPrivate Sub Form_Unload(Cancel As Integer)
Out Val("&H37A"), Val("4")　‘关闭并口
UnHookForm MeEnd SubPrivate Sub Timer1_Timer()
    Dim lngResult As Long
    Dim lngReturnValue As Long
    Dim lngProcessID As Long
    Dim lngProcess As Long
If exitproc("程序1.exe") = True Then
    'MsgBox "存在！"
    modlngWndIE = FindWindow(vbNullString, "程序1标题")
    lngReturnValue = SendMessageTimeout(modlngWndIE, WM_NULL, 0&, 0&, SMTO_ABORTIFHUNG And SMTO_BLOCK, 10000, lngResult)
    If lngReturnValue Then
'        MsgBox "Responding"
        Timer1.Interval = 2000
    Else
        lngReturnValue = GetWindowThreadProcessId(modlngWndIE, lngProcessID)
        lngProcess = OpenProcess(PROCESS_ALL_ACCESS, 0&, lngProcessID)
        lngReturnValue = TerminateProcess(lngProcess, 0&)
        Shell App.Path & "\程序1.exe", vbHide
        Timer1.Interval = 10000
'        MsgBox "Not Responding", vbOKOnly, "Block tester"
    End IfLabel2.Caption = "True"
Else
    If Dir(App.Path & "\程序1.exe") <> "" Then
        Shell App.Path & "\程序1.exe", vbHide
        Timer1.Interval = 10000
    Else
        MsgBox App.Path & "\程序1.exe文件不存在!" & vbCrLf & "请检查文件路径是否正确!", vbOKOnly, ""
    End If
    Label2.Caption = "False"
    'MsgBox "不存在！"
End IfEnd SubPrivate Sub Timer2_Timer()
    modlngWndIE = FindWindow(vbNullString, "系统设置改变") '自动关闭系统对话框
    If modlngWndIE <> 0 Then
        SetForegroundWindow (modlngWndIE)
        SendKeys "{Esc}"
        Exit Sub
    End If
End SubPrivate Sub Timer3_Timer()
    Dim lngResult As Long
    Dim lngReturnValue As Long
    Dim lngProcessID As Long
    Dim lngProcess As LongIf exitproc("程序2.exe") = True Then
'MsgBox "存在！"
    modlngWndIE = FindWindow(vbNullString, "程序2标题")
    lngReturnValue = SendMessageTimeout(modlngWndIE, WM_NULL, 0&, 0&, SMTO_ABORTIFHUNG And SMTO_BLOCK, 15000, lngResult)
    If lngReturnValue Then
'        MsgBox "Responding"
        Timer3.Interval = 2000
    Else
        lngReturnValue = GetWindowThreadProcessId(modlngWndIE, lngProcessID)
        lngProcess = OpenProcess(PROCESS_ALL_ACCESS, 0&, lngProcessID)
        lngReturnValue = TerminateProcess(lngProcess, 0&)
'        MsgBox "Not Responding", vbOKOnly, "Block tester"
        Shell App.Path & "\程序2.exe", vbNormalFocus
        Timer3.Interval = 10000
    End If
    Label4.Caption = "True"
Else
    If Dir(App.Path & "\程序2.exe") <> "" Then
        Shell App.Path & "\程序2.exe", vbNormalFocus
        Timer3.Interval = 10000
    Else
        MsgBox App.Path & "\程序2.exe文件不存在!" & vbCrLf & "请检查文件路径是否正确!", vbOKOnly, ""
    End If
    Label4.Caption = "False"
    'MsgBox "不存在！"
End IfEnd Sub

Answer 5

接上：
‘module1.codePublic Declare Sub Out Lib "inpout32.dll" _
Alias "Out32" (ByVal PortAddress As Integer, ByVal Value As Integer) '并口控制
Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
 Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    
  Private Const SWP_NOMOVE = 2
  Private Const SWP_NOSIZE = 1
  Private Const SWP_SHOWWINDOW = &H40  Private Const FLAGS = SWP_SHOWWINDOW    ' SWP_NOMOVE Or SWP_NOSIZE
  Private Const HWND_TOPMOST = -1
  Private Const HWND_NOTOPMOST = -2
  'To   set   Form1   as   a   TopMost   form,   do   the   following:'module2.codePrivate Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
Dim n As LongPublic Function GetIni2(ByVal In_Key As String, Er_data As String) As String
On Error GoTo GetIniTFErr
Dim GetStr As String
GetStr = VBA.String(128, 0)
 GetPrivateProfileString "Setting", In_Key, "", GetStr, 256, "c:\配置文件.ini"
GetStr = VBA.Replace(GetStr, VBA.Chr(0), "")
If GetStr <> "" Then
    GetIni2 = GetStr
Else
    Call SetIni2(In_Key, Er_data)
    If n < 3 Then
        n = n + 1
        Call GetIni2(In_Key, Er_data)
    Else
        GetIni2 = ""
        n = 1
    End If
End If
Exit Function
GetIniTFErr:
Err.Clear
GetIni2 = ""
End FunctionPublic Function SetIni2(ByVal In_Key As String, ByVal In_data As String) As Boolean
On Error GoTo WriteIniTFErr
WritePrivateProfileString "Setting", In_Key, In_data, "c:\配置文件.ini"
Exit Function
WriteIniTFErr:
Err.Clear
End Function

Answer 6

用shell hook比你的更有效率些

Answer 7

我今天查看了一下,所有的内存都是在页面错误那里占用了,我不知道是哪里导致会有这么多的页面错误,其他程序也有,不过大多都在几M以内,微点杀毒也有180M的页面错误量,另一个我的程序也有36M的错误,还在以100K左右每次查询的量递增,上面这个程序是以几百K每次Time徇环的量递增,请大家帮我分析一下
昨天还有一部分代码没时间贴上来,现在补上
Option Explicit
'‘子类化窗体消息处理函数时需要使用的API，很常见，不作过多说明。
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Const GWL_WNDPROC = -4
Const WM_DEVICECHANGE As Long = &H219
Const DBT_DEVICEARRIVAL As Long = &H8000&
Const DBT_DEVICEREMOVECOMPLETE As Long = &H8004&
'设备类型：逻辑卷标
Const DBT_DEVTYP_VOLUME As Long = &H2
'与WM_DEVICECHANGE消息相关联的结构体头部信息
Private Type DEV_BROADCAST_HDR
lSize As Long
lDevicetype As Long    '设备类型
lReserved As Long
End Type
'设备为逻辑卷时对应的结构体信息
Private Type DEV_BROADCAST_VOLUME
lSize As Long
lDevicetype As Long
lReserved As Long
lUnitMask As Long    '和逻辑卷标对应的掩码
iFlag As Integer
End Type
Public info As DEV_BROADCAST_HDR
Public info_volume As DEV_BROADCAST_VOLUME
Public PrevProc As Long   '‘原来的窗体消息处理函数地址
Public Passed As BooleanPublic Sub HookForm(F As Form)
     PrevProc = SetWindowLong(F.hwnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub
Public Sub UnHookForm(F As Form)
     SetWindowLong F.hwnd, GWL_WNDPROC, PrevProc
End Sub
Public Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
     Select Case uMsg
            '插入USB DISK 则接收到此消息
           Case WM_DEVICECHANGE
            If wParam = DBT_DEVICEARRIVAL Then
           
            '若插入USBDISK或者映射网络盘等则
            'info.lDevicetype =2
            '即DBT_DEVTYP_VOLUME
           
            '‘利用参数lParam获取结构体头部信息
            CopyMemory info, ByVal lParam, Len(info)
           
            If info.lDevicetype = DBT_DEVTYP_VOLUME Then
             
              CopyMemory info_volume, ByVal lParam, Len(info_volume)
             
              '检测到有逻辑卷添加到系统中，则显示该设备根目录下全部文件名
              Check Chr(GetDriveName(info_volume.lUnitMask))
            End If
            End If
                 End Select
     ' 调用原来的窗体消息处理函数
     WindowProc = CallWindowProc(PrevProc, hwnd, uMsg, wParam, lParam)
    
End Function
'根据输入的32位LONG型数据（只有一位为1）返回对应的卷标的ASCII数值
'规则是1：A、2：B、4：C等等
Function GetDriveName(ByVal lUnitMask As Long) As Byte
Dim i As Long
i = 0
While lUnitMask Mod 2 <> 1
    lUnitMask = lUnitMask \ 2
    i = i + 1
Wend
GetDriveName = Asc("A") + i
End Function
Sub Check(strPath As String)
On Error GoTo Err
              If Dir(strPath & ":\另一程序.exe", vbNormal) <> "" Then ' Form2.Show
                Form2.Show vbModal, Form1　‘密码框
                If Passed = True Then Shell strPath & ":\另一程序.exe", vbNormalFocus
              End If
              Dir
Err:
End Sub程序总体思路是查询两个外部程序的运行状态,如果外部程序在运行没反应则关闭,重新开启,如果没运行则开启运行,如果运行正常进行下一轮的徇环查询.目的保证外部程序正常运行.

Answer 8

你的调用中 WindowProc() -> Check() ->  Form2.Show vbModal
这样会导致当前的 WindowProc 消息处理过程被模态窗体挂起。
密码认证为什么不在 另一程序.exe 中完成？