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

Question

MMTimer.ctl MMTimerOption ExplicitDim 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 PropertyFriend Sub FireTimer()
     RaiseEvent Timer
End SubPublic 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 SubPrivate 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 SubPrivate Sub UserControl_Terminate()
     If m_TID Then
          RemoveTimer m_TID
          m_TID = 0
     End If
End Sub

Answer 1

Module1.bas Option ExplicitPublic Declare Function timeSetEvent Lib "winmm.dll" _
    (ByVal dwInterval As Long, ByVal dwPrecision As Long, _
    ByVal TimeProcAddr As Long, ByVal dwUserData As Long, _
    ByVal fuEvent As Long) As Long
Public Declare Function timeKillEvent Lib "winmm.dll" _
    (ByVal TimerID As Long) As Long'/* flags for fuEvent parameter of timeSetEvent() function */
Public Const TIME_ONESHOT = &H0 '/*program timer for single event*/
Public Const TIME_PERIODIC = &H1 '/*program for continuous periodic event*/Private Declare Sub CopyMem Lib "kernel32" Alias _
     "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal ByteLen As Long)
Public Function AddTimer(ByVal ObjectPointer As Long, _
dwInt As Long) As Long
     AddTimer = timeSetEvent(dwInt, 0, AddressOf TimeProc, _
          ObjectPointer, TIME_PERIODIC)
End FunctionPublic Sub RemoveTimer(ByVal TimerID As Long)
     timeKillEvent TimerID
End SubPublic Sub TimeProc(ByVal uID As Long, ByVal uMsg As Long, _
ByVal dwUser As Long, ByVal dw1 As Long, ByVal dw2 As Long)
     Dim tmpobj As MMTimer     CopyMem tmpobj, dwUser, 4
     tmpobj.FireTimer
     CopyMem tmpobj, 0&, 4
End Sub

Answer 2

Form1.frmOption ExplicitPrivate Sub Form_Load()
MMTimer1.Interval = 60
End SubPrivate Sub MMTimer1_Timer()
     Static tCount As Long
     tCount = tCount + 1
     If tCount > 5000 Then tCount = 0
     Label1.Caption = CStr(tCount)
End Sub

Answer 3

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

Answer 4

给你一个简单的、更精确的计时，并且可以编译成本地代码运行。Form1窗体代码：
Option ExplicitDim 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.basOption ExplicitPrivate 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 CurrencyPublic 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