home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / CODE_UPLOAD8564832000.psc / Module1.bas < prev    next >
Encoding:
BASIC Source File  |  2000-08-03  |  2.4 KB  |  88 lines
  1. Attribute VB_Name = "Module1"
  2. Option Explicit
  3.  
  4. Public Declare Function BitBlt Lib "gdi32" (ByVal hDestDC 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 dwRop As Long) As Long
  5. Public Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
  6. Public Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
  7. Public Declare Function GetDesktopWindow Lib _
  8.    "user32" () As Long
  9. Public Declare Function GetWindowDC Lib _
  10.    "user32" (ByVal hWnd As Long) As Long
  11. Public Declare Function ReleaseDC Lib "user32" _
  12.    (ByVal hWnd As Long, ByVal hdc As Long) As Long
  13.  
  14. Public SavePics As Long
  15.  
  16. Type Part
  17.     X As Integer
  18.     Y As Integer
  19.     drx As Double
  20.     dry As Double
  21.     'B As Long
  22.     Red As Long
  23.     Green As Long
  24.     Blue As Long
  25. End Type
  26.  
  27. Public QuitGame As Boolean
  28.  
  29. Public Sub Main()
  30.     Form1.Show
  31.     MainLoop
  32.     Unload Form1
  33.     End
  34. End Sub
  35.  
  36. Public Sub MainLoop()
  37.     Do
  38.         DoEvents
  39.         If QuitGame Then
  40.             Exit Do
  41.         End If
  42.         Form1.doParts
  43.         If SavePics > -1 Then
  44.             'Save a series of pictures here
  45.             PrintScreen
  46.             SavePicture Form1.buffer.Image, App.Path & "\G" & Format(SavePics, "00") & ".bmp"
  47.             'Stop once you've gotten 32 pictures
  48.             SavePics = SavePics + 1
  49.             If SavePics > 32 Then
  50.                 SavePics = -1
  51.                 Form1.AutoRedraw = False
  52.             End If
  53.         End If
  54.     Loop
  55. End Sub
  56.  
  57. Private Sub PrintScreen()
  58.  
  59.   Dim r As Long
  60.   Dim hWndDesk As Long
  61.   Dim hDCDesk As Long
  62.  
  63.   Dim LeftDesk As Long
  64.   Dim TopDesk As Long
  65.   Dim WidthDesk As Long
  66.   Dim HeightDesk As Long
  67.    
  68.  'define the screen coordinates (upper
  69.  'corner (0,0) and lower corner (Width, Height)
  70.   LeftDesk = 0
  71.   TopDesk = 0
  72.   WidthDesk = Screen.Width \ Screen.TwipsPerPixelX
  73.   HeightDesk = Screen.Height \ Screen.TwipsPerPixelY
  74.    
  75.  'get the desktop handle and display context
  76.   hWndDesk = GetDesktopWindow()
  77.   hDCDesk = GetWindowDC(hWndDesk)
  78.    
  79.  'copy the desktop to the picture box
  80.   r = BitBlt(Form1.buffer.hdc, 0, 0, _
  81.              WidthDesk, HeightDesk, hDCDesk, _
  82.              LeftDesk, TopDesk, vbSrcCopy)
  83.  
  84.   r = ReleaseDC(hWndDesk, hDCDesk)
  85.  
  86. End Sub
  87.  
  88.