VB精密定时器的问题：

参照网友的一段代码，使用winmm.dll做精密定时，在VB6 IDE中可以正常运行，生成EXE之后运行出错，而且没有任何提示。咋办？

'共3个文件：
'控件工程：mduMMTimer.bas:
'控件工程：MMTimer.ctl:
'测试工程：frmTest.frm



'控件工程：mduMMTimer.bas:
 Option Explicit
    
Public 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 Function
    
  Public Sub RemoveTimer(ByVal TimerID As Long)
            timeKillEvent TimerID
  End Sub
    
  Public 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

'控件工程：MMTimer.ctl:
  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 Image1.Width, Image1.Height
  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

'测试工程：frmTest.frm

Option Explicit

Private Sub Form_Load()
    MMTimer1.Interval = 1
    MMTimer1.Enabled = True
    
    Timer1.Interval = 1
    Timer1.Enabled = True
End Sub

Private Sub MMTimer1_Timer()
            Static tCount     As Long
            tCount = tCount + 1
            If tCount > 100000 Then tCount = 0
            lbl(1).Caption = tCount
End Sub

  Private Sub Timer1_Timer()
            Static tCount     As Long
            tCount = tCount + 1
            If tCount > 100000 Then tCount = 0
            lbl(0).Caption = tCount
  End Sub

16 个解决方案

#1

没多的分了，欠个人情吧......

#2

vb 的 Timer1 精不到那里去 

#3

事实上只要回调函数中有代码，就会出问题，为什么呢？ 难道这个回调函数中不可以有代码 ？？？

#4

http://www.m5home.com/blog/article.asp?id=22

看看这个会不会出错.

#5

我也要学学

#6

我把它整成了控件，可以定时，但存在一个问题：鼠标拖动时，定时器被停止，而在窗体中就不会 ... 有办法吗？

Option Explicit
'**********************************************************************************************************
Private Declare Function QueryPerformanceCounter Lib "kernel32" (ByVal lpPerformanceCount As Long) As Long
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (ByVal lpFrequency As Long) As Long
Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const WM_KEYDOWN As Long = &H100

'**************************************************************************
Private Type LARGE_INTEGER
        lowPart   As Long
        highPart   As Long
End Type
'**********************************************************************************************************
Public Event Timer()
'**********************************************************************************************************
Private m_Hwnd As Long              '注册的消息接受体
Private msValue As Long             '1毫秒所需要的计数值
Private bOff As Boolean             '定时器过程是否已经退出

'**********************************************************************************************************
Public Sub Init(hwnd As Long, Interval As Long)
    Dim CountValue As Currency         '1秒的基准值
    m_Hwnd = hwnd
    Call QueryPerformanceFrequency(VarPtr(CountValue))      '得到1秒计数值
    CountValue = CountValue * 10000     '本来应该使用LARGE_INTEGER结构,懒得弄了...直接乘10000换成整数吧...
    Debug.Print CountValue
    msValue = CountValue / 1000             '得到1毫秒计数值
    
    Timer1.Interval = 1
    Timer1.Enabled = True
    bOff = False
End Sub

Public Sub Destroy()
    bOff = True
End Sub

Private Sub Timer1_Timer()
    Static cnt As Long
    Dim tmpTimeA As Currency, tmpTimeB As Currency, tmpTimeC As Currency, tmpTimeD As Currency     '单位是ms
    Timer1.Enabled = False
    Call QueryPerformanceCounter(VarPtr(tmpTimeA))
    tmpTimeA = tmpTimeA * 10000     '开始计时的基准值
    Do
        Call QueryPerformanceCounter(VarPtr(tmpTimeB))
        tmpTimeB = tmpTimeB * 10000
        tmpTimeC = tmpTimeB - tmpTimeA      '以后只需要计算经过多少秒,并换算成HH:MM:SS:MS格式就OK.
        If tmpTimeC > tmpTimeD + msValue Then       '以1毫秒为单位来更新界面吧...实际还是太快了点.
            tmpTimeD = tmpTimeC
            'RaiseEvent Timer
            'PostMessage m_Hwnd, WM_KEYDOWN, 1, 0
            cnt = cnt + 1
            frmMain.Text1 = cnt
            Sleep 1     '既然反正都是准的...小睡一会,降降CPU占用率....
            DoEvents    '处理一下界面堆积的消息
        End If

          Loop While bOff = False
End Sub

Private Sub UserControl_Resize()
        Size Image1.Width, Image1.Height
End Sub

#7

     查了好多资料，最后把它弄到了Active exe 里面，但不能Sleep,否则就与VB6的Timer控件一样的效果了.....唉，那就不Sleep了......但这样一来，CPU占用立刻达到100% ......

     打开作者原始代码文件，运行，CPU占用不到2%，晕！擦亮眼睛仔细查看作者是怎么Sleep的......添加代码测试了一下，大约是20ms的更新周期，越来越晕......细看之下，原来真不是以1ms为单位来更新的。光Sleep 1 就1ms了，更别说更新Text属性的时间，只是一大串数字给人一个精确的假象....
     看来要达到ms级的定时真得付出相当的代价？

#8

打算求助VC了，没办法...还得学写dll...恐怖!

#9

引用 7 楼 yingang2009 的回复:

    查了好多资料，最后把它弄到了Active exe 里面，但不能Sleep,否则就与VB6的Timer控件一样的效果了.....唉，那就不Sleep了......但这样一来，CPU占用立刻达到100% ......

    打开作者原始代码文件，运行，CPU占用不到2%，晕！擦亮眼睛仔细查看作者是怎么Sleep的......添加代码测试了一下，大约是20ms的更新周期，越来越晕......细看之下，原来真不是以1ms为单位来更新的。光Sleep 1 就1ms了，更别说更新Text属性的时间，只是一大串数字给人一个精确的假象....
    看来要达到ms级的定时真得付出相当的代价？

关键是你要这么精确的定时是干嘛的.

我给你的那个例子只是利用了CPU的计时器进当作参考,再来对比计时的,因此精度完全在1MS以上很多.

如果你只是要求"1MS的计时",那好啊,用我那代码已经能实现了啊.

问题在于你的应用.

需求不明白,用汇编也难有结果--------谁知道你想干嘛呢.

#10

用于实时曲线绘图啊，要达到“感觉不抖动”的效果，就要<10ms的定时(20ms都会感觉到绘制时的跳动)，嗷嗷叫的老马有什么良策吗？

#11

http://p.blog.csdn.net/images/p_blog_csdn_net/myjian/EntryImages/20090628/波形曲线.rar.jpg

曲线的话,是否抖动也与你绘制的方法有关.

并不一定是视觉暂留造成的.

用上面代码试下看看.

#12

哈哈，这样不错
      我是用Line方法省略第一个点直接画线，画完一屏再从头开始画，将一屏的时间分成（目标时间/定时器最小间隔）份，这样跑完一屏的时间就是准的，所以要准确的定时器...准确与速度又互相冲突，调和不了，所以有此疑问。满屏时间最短到1S（分为100份）


     老马的代码很很精简，而且不抖动，但不知时间刻度怎么整？

#13

刻度放在另一个同样大小的PICTUREBOX控件里,然后把代码改改,将每一列刻度与要绘的点合成一下即可:

Private Sub ShowValue(ByVal lValue As Long)
    '显示曲线并左移
    Static LastP As Long, pX As Long        '上一个点与上一条扫描线
    
    With Picture1
        Set .Picture = .Image
        
                    '每次绘图时,从底图里取一列图象来与要画的点相组合.
        .PaintPicture Picture2.Picture, .ScaleWidth - 2, 0, 2, .ScaleHeight, pX, 0, 2, .ScaleHeight
        pX = pX + 1                             '列数要与点同步
        If pX > .ScaleWidth Then pX = 0         '超过了宽度就置零
        
        .PaintPicture .Picture, 0, 0, .ScaleWidth - 1, .ScaleHeight, 1, 0, .ScaleWidth - 1, .ScaleHeight
        Picture1.Line (.ScaleWidth - 3, LastP)-(.ScaleWidth - 2, lValue), vbBlue
        LastP = lValue
    End With
End Sub

工程我上传到BLOG了:

http://www.m5home.com/blog/article.asp?id=282

#14

哈哈，老马真有才！...
只是这个接口好像难以实现：点击Combo1 中内容能使卷动速度改变而且不能抖动...



<img 123456 

src="http://p.blog.csdn.net/images/p_blog_csdn_net/yingang2009/EntryIm

ages/20090630/曲线.rar633820001062812500.jpg"   alt="曲线.rar" />

#15

怪了...



<img src="http://p.blog.csdn.net/images/p_blog_csdn_net/yingang2009/EntryImages/20090630/曲线.rar633820001062812500.jpg" alt="曲线.rar

#16

用链接发,不是用图片发:

http://p.blog.csdn.net/images/p_blog_csdn_net/yingang2009/EntryImages/20090630/曲线.rar633820001062812500.jpg

这样才可以直接另存为.