监控其他软件内容的程序，运行几个小时就崩溃了。。。

Question

监控其他软件内容的程序，运行几个小时就崩溃了
帮看看是什么问题
页面上两个Timer，都是250毫秒触发一次
主要代码在Timer1_Timer中
测试的时候我监控的是计划任务，到了3个小时这样，我的程序和计划任务都出现问题，我的程序没死，只是功能失效，监控不出东西，计划任务工具按钮出现一些混乱，其他没什么太大问题，需把我的程序和计划任务都关闭再开启才恢复正常，3个小时后又出问题
Private 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)
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcId As Long) As Long
Private Declare Function VirtualAllocEx Lib "kernel32" (ByVal hProcess As Long, ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare Function VirtualFreeEx Lib "kernel32" (ByVal hProcess As Long, ByVal lpAddress As Long, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
Private Declare Function WriteProcessMemory Lib "kernel32" (ByVal hProcess As Long, ByVal lpBaseAddress As Any, ByRef lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
Private Declare Function ReadProcessMemory Lib "kernel32" (ByVal hProcess As Long, ByVal lpBaseAddress As Any, ByRef lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Const LVM_FIRST = &H1000
Private Const LVM_GETITEMCOUNT = (LVM_FIRST + 4)Private Const LVM_GETITEM = (LVM_FIRST + 5)
Private Const LVM_GETSTRINGWIDTH = (LVM_FIRST + 17)
Private Const LVM_GETCOLUMN = (LVM_FIRST + 25)
Private Const LVM_GETITEMTEXT = (LVM_FIRST + 45)
Private Const LVM_GETHEADER = LVM_FIRST + 31
Private Const WC_HEADERA = "SysHeader32"
Private Const WC_HEADER = WC_HEADERA
Private Const HDM_FIRST = &H1200 '// Header messages
Private Const HDM_GETITEMCOUNT = (HDM_FIRST + 0)
Private Const HDM_ORDERTOINDEX = (HDM_FIRST + 15)Private Const PROCESS_QUERY_INFORMATION = 1024
Private Const PROCESS_VM_OPERATION = &H8
Private Const PROCESS_VM_READ = &H10
Private Const PROCESS_VM_WRITE = &H20
Private Const STANDARD_RIGHTS_REQUIRED = &HF0000
Private Const MAX_LVMSTRING As Long = 255 '可根椐读取数据长度设置适当的数值
Private Const MEM_COMMIT = &H1000
Private Const MEM_RELEASE = &H8000
Private Const PAGE_READWRITE = &H4
Private Const LVIF_TEXT As Long = &H1
Private Const WM_GETTEXT = &HD
Const PROCESS_ALL_ACCESS = &H1F0FFFConst MEM_DECOMMIT = &H4000Const WM_USER = &H400
Const SB_GETPARTS = (WM_USER + 6)
Const SB_GETTEXT = (WM_USER + 2)Private Type LV_ITEMA
    mask As Long
    iItem As Long
    iSubItem As Long
    state As Long
    stateMask As Long
    pszText As Long
    cchTextMax As Long
    iImage As Long
    lParam As Long
    iIndent As Long
End TypeDim NullStr As String
Dim SNOld As String
Dim ZTOld As String
Dim MustPut As BooleanDim lProcessID    As Long
Dim hProcess      As Long
Dim hStatsWindow  As Long
Dim hStats        As Long
Private Sub Form_Load()
    SetWindowPos Me.hwnd, -1, 0, 0, 0, 0, 3
    NullStr = "－－－－"
    SNOld = ""
    ZTOld = ""
    
    TxtZT.Text = NullStr
    TxtZKZH.Text = NullStr
    TxtXM.Text = NullStr
    MustPut = True
    
    lProcessID = 0
    hProcess = 0
    hStatsWindow = 0
    hStats = 0
End SubPublic Function GetListviewItem(ByVal hWindow As Long, ByVal ProcessID As Long, ByVal pColumn As Long, ByVal pRow As Long) As String
    Dim Result As Long
    Dim myItem As LV_ITEMA
    Dim pHandle As Long
    Dim pStrBufferMemory As Long
    Dim pMyItemMemory As Long
    Dim strBuffer() As Byte
    Dim Index As Long
    Dim tmpString As String
    Dim strLength As Long    ReDim strBuffer(MAX_LVMSTRING)       pHandle = OpenProcess(PROCESS_VM_OPERATION Or PROCESS_VM_READ Or PROCESS_VM_WRITE, False, ProcessID)   
    pStrBufferMemory = VirtualAllocEx(pHandle, 0, MAX_LVMSTRING, MEM_COMMIT, PAGE_READWRITE)       myItem.mask = LVIF_TEXT
    myItem.iSubItem = pColumn
    myItem.pszText = pStrBufferMemory
    myItem.cchTextMax = MAX_LVMSTRING       pMyItemMemory = VirtualAllocEx(pHandle, 0, Len(myItem), MEM_COMMIT, PAGE_READWRITE)
    Result = WriteProcessMemory(pHandle, pMyItemMemory, myItem, Len(myItem), 0)   
    Result = SendMessage(hWindow, LVM_GETITEMTEXT, pRow, ByVal pMyItemMemory)
    Result = ReadProcessMemory(pHandle, pStrBufferMemory, strBuffer(0), MAX_LVMSTRING, 0)
    Result = ReadProcessMemory(pHandle, pMyItemMemory, myItem, Len(myItem), 0)       tmpString = StrConv(strBuffer, vbUnicode)
    If InStr(tmpString, Chr$(0)) > 0 Then
        tmpString = Left$(tmpString, InStr(tmpString, Chr$(0)) - 1)
    End If    tmpString = Trim$(tmpString)        Result = VirtualFreeEx(pHandle, pStrBufferMemory, 0, MEM_RELEASE)
    Result = VirtualFreeEx(pHandle, pMyItemMemory, 0, MEM_RELEASE)    Result = CloseHandle(pHandle)    If Len(tmpString) > 0 Then GetListviewItem = tmpStringEnd Function

Answer 1

Private Sub Timer1_Timer()
    'Dim lProcessID    As Long
    'Dim hProcess      As Long
    Dim lpBuffer      As Long
    
    Dim hTargetWindow As Long
    Dim hStatusBar    As Long
    
    
    Dim lPartIndex    As Long
    
    Dim hListView     As Long
    Dim s             As String * 1024
    Dim x             As Long
    Dim i             As Long
    Dim HwndParent    As Long    hTargetWindow = FindWindow(vbNullString, "任务计划")
        If hTargetWindow = 0 Then
        lProcessID = 0
        hProcess = 0
        hStats = 0
        TxtZKZH.Text = NullStr
        TxtXM.Text = NullStr
        TxtZT.Text = NullStr
        MustPut = True
        Exit Sub
    End If
    
    hStatusBar = FindWindowEx(hTargetWindow, 0, "msctls_statusbar32", vbNullString)    If hStatusBar = 0 Then
        lProcessID = 0
        hProcess = 0
        hStats = 0
        TxtZKZH.Text = NullStr
        TxtXM.Text = NullStr
        TxtZT.Text = NullStr
        MustPut = True
        Exit Sub
    End If
    
    
    If lProcessID = 0 Then
        GetWindowThreadProcessId hTargetWindow, lProcessID
        hProcess = 0
    End If
    
    If hProcess = 0 Then hProcess = OpenProcess(PROCESS_ALL_ACCESS, False, lProcessID)
    
    
    
    If hProcess = 0 Then Exit Sub
    
    x = SendMessage(hStatusBar, SB_GETPARTS, 0, 0) - 1
    For i = 0 To 0
        lpBuffer = VirtualAllocEx(ByVal hProcess, ByVal 0&, Len(s), MEM_COMMIT, PAGE_READWRITE)
        If lpBuffer = 0 Then Exit Sub
        lPartIndex = i
        Call SendMessage(hStatusBar, SB_GETTEXT, lPartIndex, ByVal lpBuffer)
        Call ReadProcessMemory(ByVal hProcess, ByVal lpBuffer, ByVal s, Len(s), ByVal 0)
        VirtualFreeEx hProcess, ByVal lpBuffer, 0, MEM_DECOMMIT
        'Debug.Print "狀態欄"; lPartIndex + 1; "中的文本為:"; s
        
    Next    Dim SN As String
    SN = ""
    TxtTmp.Text = s
    SN = Trim(TxtTmp.Text)    If SN = "选定 1 个对象" Then
        SN = "正常考试[准考证号:520101165339]"
    Else
        SN = NullStr
    End If
    
    If UBound(Split(SN, "准考证号:")) = 1 Then
        SN = Split(SN, "准考证号:")(1)
        If UBound(Split(SN, "]")) = 1 Then
            SN = Split(SN, "]")(0)
        Else
            SN = NullStr
        End If
    Else
        SN = NullStr
    End If
    
    'If SN <> "" Then
   
    If SN <> SNOld Then
         MustPut = True
         TxtZKZH.Text = SN
   
         If SN <> NullStr Then
   
             HwndParent = hTargetWindow
             HwndParent = FindWindowEx(HwndParent, 0, "SHELLDLL_DefView", vbNullString)
             HwndParent = FindWindowEx(HwndParent, 0, "DUIViewWndClassName", vbNullString)
             HwndParent = FindWindowEx(HwndParent, 0, "DirectUIHWND", vbNullString)
             HwndParent = FindWindowEx(HwndParent, 0, "CtrlNotifySink", vbNullString)
             hListView = FindWindowEx(HwndParent, 0, "SysListView32", vbNullString)
            
            
             Dim lngHwnd As Long
             Dim lngHwnd1 As Long
             Dim lngHeaderHwnd As Long
             Dim lngPId As Long
             Dim lngRows As Long
             Dim lngCols As Long
             Dim lngRow As Long
             Dim lngCol As Long
             Dim strItem As String
             
             lngHwnd1 = hTargetWindow
             lngHwnd = hListView
             'Debug.Print lngHwnd
             lngHeaderHwnd = SendMessage(lngHwnd, LVM_GETHEADER, 0, 0) '获取ListView表头句柄
             lngRows = SendMessage(lngHwnd, LVM_GETITEMCOUNT, 0, 0) '获取ListView项目数
             
             'If lngHeaderHwnd > 0 Then
             '    lngCols = SendMessage(lngHeaderHwnd, HDM_GETITEMCOUNT, 0, 0) '获取ListView表头项目数
            ' Else
             '    lngCols = 1
             'End If
             GetWindowThreadProcessId lngHwnd, lngPId '获取与指定窗口关联在一起的一个进程和线程标识符
             
             
             For lngRow = 0 To lngRows - 1
                 strItem = ""
                 If SN = GetListviewItem(lngHwnd, lngPId, 0, lngRow) Then
                     TxtXM.Text = GetListviewItem(lngHwnd, lngPId, 1, lngRow)
                 End If
                 'For lngCol = 0 To 1
                 '    strItem = strItem & GetListviewItem(lngHwnd, lngPId, lngCol, lngRow) & "|"
                 'Next
                 'TxtList.Text = TxtList.Text & strItem & Chr(13) & Chr(10)
             Next
         Else
            TxtXM.Text = NullStr
         End If
         SNOld = SN
    End If
    'Dim hStats As Long
    Dim SZT As String
    
    hStatsWindow = hTargetWindow
    'If hStatsWindow = 0 Then
        'hStatsWindow = FindWindow(vbNullString, "添加到收藏夹")
        'If hStatsWindow = 0 Then
        '    hStats = 0
        'End If
    'End If
    
    'If 1 = 2 Then
    
        If hStats = 0 Then
            'WorkerW ReBarWindow32 ComboBoxEx32 ComboBox
            'hStats = FindWindowEx(hStatsWindow, 0, "Edit", vbNullString)
            'hStats = FindWindowEx(hStatsWindow, hStats, "Static", vbNullString)
            'hStats = FindWindowEx(hStatsWindow, hStats, "Static", vbNullString)
            hStats = FindWindowEx(hStatsWindow, 0, "WorkerW", vbNullString)
            hStats = FindWindowEx(hStats, 0, "ReBarWindow32", vbNullString)
            hStats = FindWindowEx(hStats, 0, "ComboBoxEx32", vbNullString)
            hStats = FindWindowEx(hStats, 0, "ComboBox", vbNullString)
            hStats = FindWindowEx(hStats, 0, "Edit", vbNullString)
        End If
        
        Text1.Text = hStats
        
        Dim sS As String
        sS = String(255, 0)
          
        SendMessage hStats, WM_GETTEXT, 255, ByVal sS
          
        Dim l As Long
        l = InStr(sS, vbNullChar)
          
        If l > 0 Then sS = Left$(sS, l - 1)
    
        
        Dim Status As String
        TxtTmp.Text = sS
        Status = Trim(TxtTmp.Text)
        
        If Status = "" Then Status = NullStr
    'End If
    If Status <> ZTOld Then
        MustPut = True
        TxtZT.Text = Status
        ZTOld = Status
    End If
    
End Sub
Private Sub Timer2_Timer()
    If MustPut = True Then
        Open "D:\led.txt" For Output As #1
        Close #1
        Open "D:\led.txt" For Binary As #1
        'Open "D:\xx.txt" For Output As #1
    
        'Print #1, TxtXM.Text & vbCrLf & TxtZT.Text
        Put #1, , TxtXM.Text
        Put #1, , vbCrLf
        Put #1, , TxtZT.Text
        Close #1
        MustPut = False
    End If
    
End Sub

Answer 2

问题解决了，是因为VirtualAllocEx申请的内存通过VirtualFreeEx释放提示成功事实上没有释放
把每次申请+释放改为一次申请不再释放，解决问题