我的程序具体步骤说明：
1.截屏生成1.bmp
2.隔两秒截屏生成2.bmp
3.对比两图片，一样，shape红色，向d:\1.txt内写入0；不一样，shape绿色，向d:\1.txt内写入1
4.把2.bmp改名为1.bmp
5.重复2--4
在我的定时截屏对比图片程序中（也就是说每隔2秒钟截一次屏对比一次）就会出错，现象是：就算是屏幕上没有任何变化，Shape也会一红一绿的闪，照我的的想法是应该常绿。有人说是比较部分有问题，又有人说，我的逻辑设计可能有问题，我现在把整个程序挂上，请大家帮我看看，是哪里错了。谢谢！

为什么要比较图片？

是这样，单位有一设备，要监控其是否运行，已知如其运行，其界面时时有变化，如其停机，其界面也停止无变化。要计算其24小时内运行了多少时间，停止了多少时间，故每2秒截一次屏，并与前一次所截图片比较，如有变化，运行时间加2秒，如没有变化，停机时间加2秒。我现在加时间的模块还没有加进程序，目前只是截屏和对比。我希望是在我个人电脑上试运行这个程序，在纯桌面上，双击出指针式时钟，由于其秒针不停在动，时时有变化，故程序上的shape常绿，如关闭时钟，桌面无变化，shape常红。为了防止任务栏右下角的时间有影响（其每分钟都在变化），我还裁去了所截图片下方的任务栏一条。不知我这样说您是否明白了。如还有疑问，QQ：380129304

明白是明白了，但是，不觉得绕了一大圈弯路吗？
那个设备就只能截取屏幕信息吗？

是，无其他方法监控，1，由于是商业软件，无法反编译；2，CPU使用率在运行和停止无任何差别；3，不产生任何临时文件；4，进程中无法判断试运行还是停止；5，不想通过硬件修改等方式。。。。。。没办法呀，恳请您帮我解决一下程序的问题。帮我修改一下。谢谢了！

'****************以下保存在窗体中，窗体中需要一个Picture图片框控件数组，一个按钮，一个计时器,一个Shape控件
'****************部分代码是楼主贴子中的，可能一些冗余的代码，我修改的只是比较图片过程的代码有变化
'Picture1(0)用于记录当前屏幕图像，Picture1(1)用于记录每隔两秒的屏幕新的图像，对这两个图像进行对比
'****************本示例工程意义：每两秒中截一幅屏幕画面，当发现新的画面与前一次截取的画面不同的时候，将新的截图写入D盘(顺着按钮事件一步一步看即可)

'在窗体上画好控件以后，将下面代码复制到窗体代码中即可
'本示例运行后，拖动本窗口，即可实时感觉楼主所说的Shape控件的颜色发生变化
Private Type PALETTEENTRY
   peRed As Byte
   peGreen As Byte
   peBlue As Byte
   peFlags As Byte
End Type

Private Type LOGPALETTE
   palVersion As Integer
   palNumEntries As Integer
   palPalEntry(255) As PALETTEENTRY  ' Enough for 256 colors.
End Type

Private Type GUID
   Data1 As Long
   Data2 As Integer
   Data3 As Integer
   Data4(7) As Byte
End Type

Private Const RASTERCAPS As Long = 38
Private Const RC_PALETTE As Long = &H100
Private Const SIZEPALETTE As Long = 104

Private Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type

Private Type PicBmp
   Size As Long
   Type As Long
   hBmp As Long
   hPal As Long
   Reserved As Long
End Type

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal iCapabilitiy As Long) As Long
Private Declare Function GetSystemPaletteEntries Lib "gdi32" (ByVal hdc As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
Private Declare Function CreatePalette Lib "gdi32" (lpLogPalette As LOGPALETTE) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDCDest As Long, ByVal XDest As Long, ByVal YDest As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hDCSrc As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function SelectPalette Lib "gdi32" (ByVal hdc As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
Private Declare Function RealizePalette Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Const nPercent As Integer = 100
Dim bit1() As Byte, bit2() As Byte

Private Sub Form_Load()
Show
Me.ScaleMode = 3
Picture1(0).ScaleMode = 3
Picture1(0).Move 10, 10, 400, 300
Picture1(0).AutoRedraw = True

Picture1(1).Move 420, 10, 400, 300
Picture1(1).AutoRedraw = True

Command1.Move 300, 320, 130, 30
Command1.Caption = "对比图片"
Command1.Tag = 0
Command1.Default = True

'Delay 2000
Set Picture1(0).Picture = CaptureScreen()
Timer1.Enabled = True
Timer1.Interval = 2000 '楼主需要两秒截个图
End Sub

Private Sub Picture1_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 And Index = 1 And Command1.Tag = 1 Then SetBitmapBits Picture1(1).Image, UBound(bit2), bit2(1)
End Sub
Private Sub Command1_Click()
'Dim r As Long
Dim sss As String
sss = "D:\" & Replace(Replace(Replace(Now, " ", ""), ":", ""), "-", "") & ".bmp"
  getbit Picture1(0).Image, bit1()
  getbit Picture1(1).Image, bit2()
For i = 1 To UBound(bit1) Step 4
    If Abs(CInt(bit1(i)) - CInt(bit2(i))) <= nPercent And Abs(CInt(bit1(i + 1)) - CInt(bit2(i + 1))) <= nPercent And Abs(CInt(bit1(i + 2)) - CInt(bit2(i + 2))) <= nPercent Then
        n = n + 1
    End If
Next
r = Round(400 * n / UBound(bit1), 2)

If r <> 100 Then '如果两个图片不同
Shape1.BackColor = vbGreen
Picture1(0).Picture = Picture1(1).Image
SavePicture Picture1(1).Image, sss
Else
Shape1.BackColor = vbRed
End If '向文本文件写入0和1我觉得没有实际意义，需要的话，你自已写吧

Command1.Tag = 1
End Sub
Function getbit(ByVal hBmp As Long, ByRef bit() As Byte)
Dim picinfo As BITMAP
GetObject hBmp, Len(picinfo), picinfo
ReDim bit(1 To picinfo.bmHeight * picinfo.bmWidth * 4)
GetBitmapBits hBmp, UBound(bit), bit(1)
End Function

Private Function CaptureScreen() As Picture
  Dim hWndScreen As Long

   hWndScreen = GetDesktopWindow()

   Set CaptureScreen = CaptureWindow(hWndScreen, False, 0, 0, Screen.Width \ Screen.TwipsPerPixelX, Screen.Height \ Screen.TwipsPerPixelY - GetTrayHeight)
End Function

  Private Function CaptureWindow(ByVal hWndSrc As Long, ByVal Client As Boolean, ByVal LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long) As Picture

  Dim hDCMemory As Long
  Dim hBmp As Long
  Dim hBmpPrev As Long
  Dim r As Long
  Dim hDCSrc As Long
  Dim hPal As Long
  Dim hPalPrev As Long
  Dim RasterCapsScrn As Long
  Dim HasPaletteScrn As Long
  Dim PaletteSizeScrn As Long
  Dim LogPal As LOGPALETTE

   If Client Then
      hDCSrc = GetDC(hWndSrc)
   Else
      hDCSrc = GetWindowDC(hWndSrc)
                                   
   End If

   hDCMemory = CreateCompatibleDC(hDCSrc)
   hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
   hBmpPrev = SelectObject(hDCMemory, hBmp)

   RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS)
                                                     
   HasPaletteScrn = RasterCapsScrn And RC_PALETTE
                                                      
   PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE)
                                                        

   If HasPaletteScrn And (PaletteSizeScrn = 256) Then
      LogPal.palVersion = &H300
      LogPal.palNumEntries = 256
      r = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
      hPal = CreatePalette(LogPal)
      ' Select the new palette into the memory DC and realize it.
      hPalPrev = SelectPalette(hDCMemory, hPal, 0)
      r = RealizePalette(hDCMemory)
   End If

   ' Copy the on-screen image into the memory DC.
   r = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, vbSrcCopy)

' Remove the new copy of the  on-screen image.
   hBmp = SelectObject(hDCMemory, hBmpPrev)

   ' If the screen has a palette get back the palette that was
   ' selected in previously.
   If HasPaletteScrn And (PaletteSizeScrn = 256) Then
      hPal = SelectPalette(hDCMemory, hPalPrev, 0)
   End If

   ' Release the device context resources back to the system.
   r = DeleteDC(hDCMemory)
   r = ReleaseDC(hWndSrc, hDCSrc)

   ' Call CreateBitmapPicture to create a picture object from the
   ' bitmap and palette handles. Then return the resulting picture
   ' object.
   Set CaptureWindow = CreateBitmapPicture(hBmp, hPal)
End Function

Private Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture
  Dim r As Long

   Dim Pic As PicBmp
   ' IPicture requires a reference to "Standard OLE Types."
   Dim IPic As IPicture
   Dim IID_IDispatch As GUID

   ' Fill in with IDispatch Interface ID.
   With IID_IDispatch
      .Data1 = &H20400
      .Data4(0) = &HC0
      .Data4(7) = &H46
   End With

   ' Fill Pic with necessary parts.
   With Pic
      .Size = Len(Pic)          ' Length of structure.
      .Type = vbPicTypeBitmap   ' Type of Picture (bitmap).
      .hBmp = hBmp              ' Handle to bitmap.
      .hPal = hPal              ' Handle to palette (may be null).
   End With

   ' Create Picture object.
   r = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)

   ' Return the new Picture object.
   Set CreateBitmapPicture = IPic
End Function

Function GetTrayHeight() As Double
         Dim hTrayWnd     As Long, rc       As RECT
          hTrayWnd = FindWindow("Shell_TrayWnd", vbNullString)
           
          GetWindowRect hTrayWnd, rc
          GetTrayHeight = rc.Bottom - rc.Top

End Function

Private Sub Timer1_Timer()
Set Picture1(1).Picture = CaptureScreen()
Command1_Click
DoEvents
End Sub

上述代码加工一下，就可以判断主人离开机器后，是否有人动过“我的电脑”了，呵呵。

楼主贴子的标题不便于新的网友进行搜索，不如改成“如何比较两幅图片是否一样”

不好意思，给楼主的例子中，自定义模块代码复制忘掉了


程序代码：

'以下代码在Module1中
Public Declare Function SetStretchBltMode Lib "gdi32" (ByVal hdc As Long, ByVal nStretchMode As Long) As Long
Public Const STRETCH_HALFTONE = 4
Public Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Public Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Public Declare Function SetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long

Public Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type

Public Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

另外，Shape1控件的BackStyle属性请设为1,不然颜色没变化的

谢谢您，“不说也罢”，正确了，非常感谢您！
针对您给我的这段程序，我想再作出一些修改，但我很菜菜，能分别告诉我怎么修改么？
1，不需要保存以时间命名的那么多文件，我只需要两个，能否只保存用来对比的两个文件，其他用过的都删除？
2，截屏大小为“全屏-下方任务条高度，任务条高度大约为500”
3，picture1（1）和picture1（2）的大小能不变化么？意思是，虽然我截的是全屏，但不需要picture1（1）和picture1（2）也显示全屏，也许能省些内存呢。呵呵

3，picture1（1）和picture1（2）的大小能不变化么？意思是，虽然我截的是全屏，但不需要picture1（1）和picture1（2）也显示全屏，也许能省些内存呢。呵呵

不能.因为要根据 picture1 来确定图像大小.
但你可以把 picture1 设为 隐藏.