网下找个精确计时的，IDE环境可以，生成EXE就报内存不能为.

网上找个精确计时的，IDE环境可以，生成EXE就报内存不能为...
MMTimer.ctl MMTimer

Option Explicit

Dim m_TID As Long

'Default Property Values:
Const m_def_Enabled = True
Const m_def_Interval = 0
'Property Variables:
Dim m_Enabled As Boolean
Dim m_Interval As Long
'Event Declarations:
Event Timer()


Public Property Get Enabled() As Boolean
     Enabled = m_Enabled
End Property
Public Property Let Enabled(ByVal New_Enabled As Boolean)
     m_Enabled = New_Enabled
     PropertyChanged "Enabled"
     If Ambient.UserMode Then
          If m_Enabled Then
               If m_TID Then
                    RemoveTimer m_TID
               End If
               m_TID = AddTimer(ObjPtr(Me), m_Interval)
          Else
               If m_TID Then
                    RemoveTimer m_TID
               End If
          End If
     End If
End Property

Friend Sub FireTimer()
     RaiseEvent Timer
End Sub

Public Property Get Interval() As Long
     Interval = m_Interval
End Property
Public Property Let Interval(ByVal New_Interval As Long)
     m_Interval = New_Interval
     PropertyChanged "Interval"

     If Ambient.UserMode Then
          If m_Enabled And m_Interval > 0 Then
               If m_TID Then
                    RemoveTimer m_TID
               End If
               m_TID = AddTimer(ObjPtr(Me), m_Interval)
          Else
               If m_TID Then
                    RemoveTimer m_TID
               End If
          End If
     End If
End Property


Private Sub UserControl_Initialize() 
 
     m_TID = 0
End Sub

'Initialize Properties for User Control
Private Sub UserControl_InitProperties()
     m_Enabled = m_def_Enabled
     m_Interval = m_def_Interval
End Sub

'Load property values from storage
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
m_Enabled = PropBag.ReadProperty("Enabled", m_def_Enabled)
m_Interval = PropBag.ReadProperty("Interval", m_def_Interval)

If Ambient.UserMode Then
     If m_Enabled Then
          If m_TID Then
               RemoveTimer m_TID
          End If
          m_TID = AddTimer(ObjPtr(Me), m_Interval)
     Else
          If m_TID Then
               RemoveTimer m_TID
          End If
     End If
End If
End Sub

Private Sub UserControl_Resize()
'Limit control to 16x15 pixels in size.
     Size 16 * Screen.TwipsPerPixelX, _
          15 * Screen.TwipsPerPixelY
End Sub

'Write property values to storage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
     Call PropBag.WriteProperty("Enabled", m_Enabled, m_def_Enabled)
     Call PropBag.WriteProperty("Interval", m_Interval, m_def_Interval)
End Sub

Private Sub UserControl_Terminate()
     If m_TID Then
          RemoveTimer m_TID
          m_TID = 0
     End If
End Sub

[解决办法]
这个计时应该可以。
不过，涉及到API函数timeSetEvent使用要编译成P代码才能正常运行。这是VB本身的问题，无法解决。


[解决办法]
给你一个简单的、更精确的计时，并且可以编译成本地代码运行。

Form1窗体代码：

Option Explicit

Dim t1 As Currency, t2 As Currency


Private Sub Command1_Click()
    Dim i As Long
    
    t1 = Utility.GetCurrentTime '开始计时
    
    For i = 0 To 6666666
       ''''''
    Next
    
    t2 = GetCurrentTime - t1
    Me.Caption = Format(t2 / 1000, "##,###,##0.000") & "秒"

End Sub

标准模块：

'Utility.bas

Option Explicit

Private Declare Function GetTickCount Lib "kernel32" () As Long 
 
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long
Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
Private Const ERRORINDEX    As Long = -1
Private SystemFrequency     As Currency

Public Function GetCurrentTime() As Currency
    If SystemFrequency = 0 Then '未初始化
        If QueryPerformanceFrequency(SystemFrequency) = 0 Then
            SystemFrequency = ERRORINDEX '无高精度计数器
        End If
    End If

    If SystemFrequency <> ERRORINDEX Then
        Dim CurCount As Currency
        QueryPerformanceCounter CurCount
        GetCurrentTime = CurCount * 1000@ / SystemFrequency
    Else
        GetCurrentTime = GetTickCount()
    End If
End Function

[解决办法]

查看更多 下一篇