VB如何释放大内存

Question

废话少说，看代码：测试工程1：
------------------------
类ct代码
------------------------Option Explicit
Private m_lngV2 As Long
Private m_lngV1 As Long
Private m_lngV3 As Long
Private m_lngV4 As Long
Private m_lngV5 As Long
Private m_lngV6 As Long
Private m_lngV7 As Long
Private m_lngV8 As Long
Private m_lngV9 As LongPublic Property Get V9() As Long
    V9 = m_lngV9
End PropertyPublic Property Let V9(ByVal lngValue As Long)
    m_lngV9 = lngValue
End PropertyPublic Property Get V8() As Long
    V8 = m_lngV8
End PropertyPublic Property Let V8(ByVal lngValue As Long)
    m_lngV8 = lngValue
End PropertyPublic Property Get V7() As Long
    V7 = m_lngV7
End PropertyPublic Property Let V7(ByVal lngValue As Long)
    m_lngV7 = lngValue
End PropertyPublic Property Get V6() As Long
    V6 = m_lngV6
End PropertyPublic Property Let V6(ByVal lngValue As Long)
    m_lngV6 = lngValue
End PropertyPublic Property Get V5() As Long
    V5 = m_lngV5
End PropertyPublic Property Let V5(ByVal lngValue As Long)
    m_lngV5 = lngValue
End PropertyPublic Property Get V4() As Long
    V4 = m_lngV4
End PropertyPublic Property Let V4(ByVal lngValue As Long)
    m_lngV4 = lngValue
End PropertyPublic Property Get V3() As Long
    V3 = m_lngV3
End PropertyPublic Property Let V3(ByVal lngValue As Long)
    m_lngV3 = lngValue
End PropertyPublic Property Get V1() As Long
    V1 = m_lngV1
End PropertyPublic Property Let V1(ByVal lngValue As Long)
    m_lngV1 = lngValue
End PropertyPublic Property Get V2() As Long
    V2 = m_lngV2
End PropertyPublic Property Let V2(ByVal lngValue As Long)
    m_lngV2 = lngValue
End PropertyPublic Sub SetValue(v() As Long)
    m_lngV1 = v(0)
    m_lngV2 = v(1)
    m_lngV3 = v(2)
    m_lngV4 = v(3)
    m_lngV5 = v(4)
    m_lngV6 = v(5)
    m_lngV7 = v(6)
    m_lngV8 = v(7)
    m_lngV9 = v(8)
End Sub-----------------------
类cts代码
-----------------------
Option ExplicitPrivate m_Colcts As Collection
Private Sub Class_Initialize()    Set m_Colcts = New CollectionEnd SubSub Add(CtItem As ct, Optional varKey As Variant)    m_Colcts.Add CtItem, varKeyEnd SubSub Remove(varIndex As Variant)    m_Colcts.Remove varIndexEnd SubFunction Item(varIndex As Variant) As ct    Set Item = Nothing    On Error Resume Next
    Set Item = m_Colcts.Item(varIndex)
    On Error GoTo 0End FunctionFunction Exists(varIndex As Variant) As Boolean    Dim objTest As ct
    Set objTest = Nothing    If Count > 0 Then        On Error Resume Next
        Set objTest = Item(varIndex)
        On Error GoTo 0    End If    Exists = Not (objTest Is Nothing)End Function
Property Get Count() As Long    Count = m_Colcts.CountEnd Property
Sub Clear()    Set m_Colcts = New CollectionEnd SubFunction NewEnum() As IUnknown    Set NewEnum = m_Colcts.[_NewEnum]End Function-----------------------
Form1代码
-----------------------
Option ExplicitPrivate ts As ctsPrivate Sub Command1_Click()    Set ts = New cts    Dim i         As Long
    Dim t         As ct
    Dim a(0 To 8) As Long    For i = 0 To 8
    
        a(i) = i
    
    Next    Me.Timer1.Enabled = True    For i = 1 To 1000000
    
        Set t = New ct
    
        DoEvents
    
        Me.Text1.Text = i
    
        t.SetValue a
    
        ts.Add t
    
    Next    Me.Timer1.Enabled = False
End SubPrivate Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    Dim p As ct
    For Each p In ts
        
        DoEvents
        
        Set p = Nothing
        
    Next
    
    Set ts = Nothing
End Sub------------------
注：
------------------
窗体Form1上放一个Command1,一个Text1-------------------
问题
-------------------
关闭程序时无响应，占用的一大块内存没有被释放。高手都来发表下意见吧……

Answer 1

For i = 1 To 1000000 
    
        Set t = New ct 

Answer 2

不知直接.Clear下内存会是怎么？

Answer 3

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    Dim i As Long
    For i = ts.Count To 1 Step -1
        ts.Remove i
    Next
    Set ts = Nothing
End Sub

Answer 4

其实加一个按钮Private Sub Command2_Click()
Set ts = Nothing
End Sub盯着任务管理器，你会发现内存的确是被释放了，只不果释放速度比创建的时候慢

Answer 5

给你一段代码，效果立杆见影，用在以觉得内存比较大，需要释放一下的时候
'释放内存，常用于第一次启动完窗体后，效果显著
Private Declare Function SetProcessWorkingSetSize Lib "kernel32" (ByVal hProcess As Long, ByVal dwMinimumWorkingSetSize As Long, ByVal dwMaximumWorkingSetSize As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Sub releasemem()
   SetProcessWorkingSetSize GetCurrentProcess, -1, -1
End Sub

Answer 6

退出时直接调用End语句让操作系统自动释放你这个进程占用的内存试试。

Answer 7

各位朋友：
随着系统运行的时间越来越长，程序占用的内存越来越大，直至死机！你光靠VB自身释放恐怕是结局只有一个，那就是死机！用END语句程序会关掉的！fly1229的只是把当前应用程序进程占用的内存转至虚拟内存中，系统占用内存总数是不变的！之所以考虑到释放内存的问题，是因为程序要在服务器上运行，跑起来少则一个星期，VB的Nothing基本无用，尤其是对于大量对象的释放问题！

Answer 8

你Form1的代码贴全了么？timer似乎不是这样的用法哦

Answer 9

LZ要创建1000000个ct?? 你的代码本身就存在问题,是逻辑问题!你向内存一下子申请这么多内存地址块,写代码的那个人不是有病吗?和电脑开国际玩笑是吧,可惜它不能像你一样会笑啊!

Answer 10

我把楼主的程序调试状态下直接END了，现在VB里的鼠标还在沙漏状态，好几分钟了。记得这个问题我似乎也遇到过，也是做测试，一下子建立大量对象，New的时候快，结束程序的时候要慢很多。

Answer 11

汗，貌似把我同时开着的VBA IDE也弄死了

Answer 12

你应该注意，IDE调试运行，要比编译成 exe 后运行慢得多。

Answer 13

我测试的结果是，每释放1000个对象大约需要1、2分钟。测试代码参照口香糖7楼的回复修改如下：Private Sub Form_Unload(Cancel As Integer)
    Dim i As Long
    Dim sngStart As Single
    
    Screen.MousePointer = vbHourglass
    sngStart = Timer
    For i = ts.Count To 1 Step -1
        If i Mod 1000 = 0 Then
            Debug.Print Timer - sngStart
            DoEvents
            sngStart = Timer
        End If
        ts.Remove i
    Next
    Set ts = Nothing
    Debug.Print Timer - sngStart
    Screen.MousePointer = vbDefault
End Sub

Answer 14

按照这个速度，100万个对象完全正常释放完毕约需5小时或更多！如果按照杯子的说法，exe要快些，假设快上5倍，那也需要1个小时！

Answer 15

各位朋友们：
这个只是用来测试的代码，目前就是占用了很大一块内存，该如何释放的问题。现实工程中肯定没有这样的代码，只不过我的工程中使用了一个很复杂的对象，实际运行时内存随着用户不停的操作而逐渐增加。程序中使用对象时，该SET NOTHING的地方全部都写了，检查了N遍了，问题依旧。

Answer 16

TerminateProcess 直接杀掉，内存会很快释放````

Answer 17

程序运行时SET NOTHING后，那一大块内存如何释放？关闭程序时直接TASKKILL 就OK了。

Answer 18

你说的很对，当创建完了，用完了，也SETNOTHING了，内存还是在，这才是问题！

Answer 19

又写了类似我工程的结构的测试代码：测试工程名：TestFreeMemory
类模块：4个
窗体：Form1,上面放一个Command1代码为：类CA:
------------------------------
Option ExplicitPrivate m_Childs As CBs
Private m_varIndexKey As StringPublic Property Get IndexKey() As String
    IndexKey = m_varIndexKey
End PropertyPublic Property Let IndexKey(ByVal varValue As String)
    m_varIndexKey = varValue
End PropertyPublic Property Get Childs() As CBs
    Set Childs = m_Childs
End PropertyPrivate Sub Class_Initialize()
    Set m_Childs = New CBs
    Set m_Childs.Category = Me
End SubPrivate Sub Class_Terminate()
    Set m_Childs = Nothing
End Sub类CAs：
---------------------------------------
Option Explicit
Private m_ColCAs As Collection
Private Sub Class_Initialize()
    Set m_ColCAs = New Collection
End SubSub Add(CAItem As CA, Optional varKey As Variant)
    If IsMissing(varKey) Then
        m_ColCAs.Add CAItem, CAItem.IndexKey
    Else
        m_ColCAs.Add CAItem, varKey
    End If
End Sub
Sub Remove(varIndex As Variant)
    m_ColCAs.Remove varIndex
End Sub
Function Item(varIndex As Variant) As CA    Set Item = Nothing    On Error Resume Next
    Set Item = m_ColCAs.Item(varIndex)
    On Error GoTo 0End Function
Function Exists(varIndex As Variant) As Boolean    Dim objTest As CA
    Set objTest = Nothing    If Count > 0 Then        On Error Resume Next
        Set objTest = Item(varIndex)
        On Error GoTo 0    End If    Exists = Not (objTest Is Nothing)End Function
Property Get Count() As Long    Count = m_ColCAs.CountEnd PropertySub Clear()    Set m_ColCAs = New CollectionEnd Sub
Function NewEnum() As IUnknown    Set NewEnum = m_ColCAs.[_NewEnum]End FunctionPrivate Sub Class_Terminate()
Set m_ColCAs = Nothing
End Sub类CB：
--------------------------------------
Option ExplicitPrivate m_Parent As CA
Private m_varIndexKey As StringPublic Property Get IndexKey() As String
    IndexKey = m_varIndexKey
End PropertyPublic Property Let IndexKey(ByVal varValue As String)
    m_varIndexKey = varValue
End PropertyPublic Property Get Parent() As CA
    Set Parent = m_Parent
End PropertyPublic Property Set Parent(ByVal CAValue As CA)
    Set m_Parent = CAValue
End PropertyPrivate Sub Class_Terminate()
Set m_Parent = Nothing
End Sub类CBs：
---------------------------------------------------
Option Explicit
Private m_ColCBs As Collection
Private m_Category As CAPublic Property Set Category(ByVal CAValue As CA)
    Set m_Category = CAValue
End Property
Private Sub Class_Initialize()
    Set m_ColCBs = New Collection
End SubSub Add(CBItem As CB, Optional varKey As Variant)
    Set CBItem.Parent = m_Category
    If IsMissing(varKey) Then
        m_ColCBs.Add CBItem, CBItem.IndexKey
    Else
        m_ColCBs.Add CBItem, varKey
    End If
End Sub
Sub Remove(varIndex As Variant)
    m_ColCBs.Remove varIndex
End Sub
Function Item(varIndex As Variant) As CB    Set Item = Nothing    On Error Resume Next
    Set Item = m_ColCBs.Item(varIndex)
    On Error GoTo 0End Function
Function Exists(varIndex As Variant) As Boolean    Dim objTest As CB
    Set objTest = Nothing    If Count > 0 Then        On Error Resume Next
        Set objTest = Item(varIndex)
        On Error GoTo 0    End If    Exists = Not (objTest Is Nothing)End Function
Property Get Count() As Long
    Count = m_ColCBs.Count
End Property
Sub Clear()
    Set m_ColCBs = New Collection
End Sub
Function NewEnum() As IUnknown
    Set NewEnum = m_ColCBs.[_NewEnum]
End FunctionPrivate Sub Class_Terminate()
Set m_ColCBs = Nothing
Set m_Category = Nothing
End Sub窗体Form1：
-------------------------------------
Option ExplicitPrivate Sub Command1_Click()
    
    Me.Command1.Enabled = False
    
    Dim tCas As CAs
    Set tCas = New CAs
    
    Dim tCa As CA
    Dim iCa As Integer
    
    For iCa = 1 To 50
    
        Set tCa = New CA
        tCa.IndexKey = "a" & iCa
        
        Dim tCb As CB
        Dim iCb   As Long
        For iCb = 1 To 50
            Set tCb = New CB
            tCb.IndexKey = "b" & iCb
            tCa.Childs.Add tCb
            Set tCb = Nothing
        Next
        
        tCas.Add tCa
        Set tCa = Nothing
        
    Next
    
    '做要做的事
    Debug.Print tCas.Count, tCas.Item(1).Childs.Count
    
    '做完了释放
    Set tCas = Nothing
    
    Me.Command1.Enabled = True
    
End Sub编译为EXE后：
你点按钮Command1，内存也是越来越大，随着你点的次数不断增多，最终也会死机。先生们，女士们，类得撕俺的街头门，帮忙分析一下是什么原因造成的内存不断上涨呢？？？

Answer 20

好长的代码 没空看了 你看看有没有被循环引用了 我隐约看到了一个parent属性

Answer 21

用END命令，让系统自己来释放，一了百了！

Answer 22

产生楼主的问题的根源是：
　　楼主的类对象 这里 Set m_Childs ，那里 Set m_Parent ，造成对象之间的循环引用。
　　最终的后果就是：对象在运行期间无法被释放！
　　所以，运行时，内存占用越来越多。
　　楼主试一下下面的这段代码（按 32F 的窗体代码修改的，类代码没动），无论你点多少次按钮，开始时内存会增加（通过任务管理器来看的），但增加一定的数量后就不再增涨了（增加量不算多）。
　　但是，如果没有我添加的那几句代码，就会内存占用‘无限增涨’（也许是，我不可能让我的系统 GAME OVER）。
Private Sub Command1_Click()
    
    Me.Command1.Enabled = False
    
    Dim tCas As CAs
    Set tCas = New CAs
    
    Dim tCa As CA
    Dim iCa As Integer
    
    For iCa = 1 To 100   '我改到 100 了。
    
        Set tCa = New CA
        tCa.IndexKey = "a" & iCa
        Dim tCb As CB
        Dim iCb  As Long
        For iCb = 1 To 50
            Set tCb = New CB
            tCb.IndexKey = "b" & iCb
            tCa.Childs.Add tCb
            Set tCb = Nothing
        Next
        tCas.Add tCa
        Set tCa = Nothing
        
    Next
    
    '做要做的事
    Debug.Print tCas.Count, tCas.Item(1).Childs.Count
    
    '做完了释放
    ' ****** 楼主注意比较有这段代码和没这段代码的区别 ******
    Dim i&, k&
    For i = tCas.Count To 1 Step -1
        For k = tCas.Item(i).Childs.Count To 1 Step -1
            tCas.Item(i).Childs.Remove tCas.Item(i).Childs.Item(1).IndexKey
        Next
        Set tCas.Item(i).Childs.Category = Nothing
        tCas.Remove tCas.Item(i).IndexKey
    Next
    ' *******************************************************
    Set tCas = Nothing
    
    Me.Command1.Enabled = True
    
End Sub

Answer 23

我不清楚楼主的类代码为何要那样写。但觉得这种类代码，简单地 set Noting ，不能正确释放对象。

Answer 24

还是因为引用没释放，对象也不能被释放。类 cts 的 m_Colcts .............

Answer 25

我用22楼办法释放的，也没用。
cts是个典型的集合类，通常都是那样做的，我看不出有什么问题。

Answer 26

楼主 0F 的代码，对象是可以自动被释放的。
只要在代码中有个：Set ts = Nothing
或者 重新 New 一个 cts 给 ts。就可以让原来 New 的 ct 对象释放。你在 22F 的代码，似乎没有必要。还不如让程序自己完成释放操作。
（刚发现楼主 0F 的 Form_QueryUnload()　事件代码是错误的）
编译成 exe 文件后，每秒钟大概可以释放 7W 个 ct对象（xixi 怎么1000个要1、2分钟？），100W 要十几秒时间。
按楼主 0F 的代码（修正错误后），关闭程序时，窗口立即消失，但进程需要一段时间才销毁。
楼主说的“关闭程序时无响应，占用的一大块内存没有被释放。”应该是不存在的现象。

Answer 27

刚才试了一下，对象个数很多时，释放速度比较慢，速度很少时非常快。原因应该是：
m_Colcts对象 的 .Remove 在对象很多的时候很耗时。

Answer 28

end干什么？直接提升权限（Vista）然后强制终结System进程！

Answer 29

楼主的意思估计是,在不关闭的情况下释放内存占用.类似IIS的回收内存池功能一样......要是关闭程序来实现,讨论就没意义了不是?呵呵.....至于楼主的问题,我估计还是有对象未释放造成的.比如你的类里面有没有使用别的类?释放没?然后里面的"别的类"呢?有没有类似的递归引用问题?

Answer 30

确认一下，你的对象里面有没有用到模块级的不定数组？
如果有的话记住在对象使用完成以后 erase一下，否则即使set nothing了内存也不会释放的

Answer 31

尽量不要使用 doevents 语句慢就慢点吧~

Answer 32

显示工程的类结构非常庞大，运行时最多同时存在的也就20个左右（因为在服务器运行，连接数约为20个），0楼发的是模拟占用内存块的测试程序，没有人会在程序里傻不拉基的在FOR循环中New了那么多对象又释放。测试工程为了演示说明如何释放比较大的内存块。所以你在这里说工程与现实如何如何没有任何意义。虽然说的没有意思，还是感谢你的热心参与！

Answer 33

自己在明确不需要时加以释放吧.
Set obj=Nothing

Answer 34

每个对象一个线程
在客户端请求对象时，每个对象将创建在一个新的线程上。当最终客户端释放对某线程上的对象的最后一个引用后，该线程就终止。请注意，客户端可能会引用一个线程上的几个对象。假设客户端创建了一个 Widget 对象，该对象又依次创建了两个从属对象 Sprocket 和 Gear。如果客户端得到对 Sprocket 对象的引用后释放了该 Widget 对象，该线程仍将存在，直至 Sprocket 对象被释放。在这种方式下，如果保留了不被使用的线程，最终会导致系统性能下降。因此，在使用多线程部件时，避免对象引用悬空是十分关键的。

Answer 35

这个贴子,本来不想看的,看热闹了,就测试了一下,就1楼发布的程序而言,对于窗体中的测试(Form1),完全可以用下面的方式来做,速度差距不是一点点的在1000000的循环中,对文本赋值,重复创建对象,这种做法我觉得不科学,程序中对这种问题应该从根本上进行考虑,简单的来说就是:尽量不要制造垃圾,而不是先制造出一堆的垃圾,然后再考虑怎么处理垃圾,就象防冶污染一样的道理,一开始我们就不要污染,而不是等污染后再去治理.
'以下是Form中的改进后的部分
  
Option ExplicitPrivate ts As ctsPrivate Sub Command1_Click()    Set ts = New cts    Dim i        As Long
    Dim t        As ct
    Dim a(0 To 8) As Long
    
    Dim TimeLog As Double
    
    TimeLog = Timer    For i = 0 To 8
   
        a(i) = i
   
    Next    Me.Timer1.Enabled = True
    
    Set t = New ct
    t.SetValue a    For i = 1 To 1000000
   
        ts.Add t    Next
    
    Me.Text1.Text = i - 1 & "OK"
    
    Set t = Nothing    Me.Timer1.Enabled = False
    
     Debug.Print Timer - TimeLog
End SubPrivate Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
'    Dim p As ct
'    For Each p In ts
'
'       ' DoEvents
'
'        Set p = Nothing
'
'    Next
'
'    Set ts = Nothing   Set ts = Nothing
End Sub
测试的结果: .87518750000163 
 .781562500000291 
 .907062500002212 
 .782312499999534 
 .78143750000163 

Answer 36

To 76F :　　楼主是‘释放内存’的问题。对象很多时，释放内存需要很多时间。　　你那是“创建对象”的时间。创建时都很快。

Answer 37

i am here to learn

Answer 38

HAO TIAO  HAO LE 

Answer 39

HAO TIAO  HAO LE