home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 5_2007-2008.ISO / data / Zips / Puzzle2082789102007.psc / Puzzle.Bas < prev    next >
BASIC Source File  |  2007-09-09  |  7KB  |  167 lines
  1. Attribute VB_Name = "Puzzle_Bas"
  2.  
  3. Option Explicit
  4.  
  5. Private Const mc_strModuleID        As String = "Puzzle_Bas."
  6. Private Const RASTERCAPS            As Long = 38
  7. Private Const RC_PALETTE            As Long = &H100
  8. Private Const SIZEPALETTE           As Long = 104
  9.  
  10. Public Const SPI_GETDESKWALLPAPER   As Long = 115
  11.  
  12. Public lngBoxes                     As Long
  13. Public lngBoxesOOO                  As Long
  14. Public lngH                         As Long
  15. Public lngLoop1                     As Long
  16. Public lngLoop2                     As Long
  17. Public lngMsgResp                   As Long
  18. Public lngPerRow                    As Long
  19. Public lngPicTo                     As Long
  20. Public lngSH                        As Long
  21. Public lngSW                        As Long
  22. Public lngSwap                      As Long
  23. Public lngSwap1                     As Long
  24. Public lngSwap2                     As Long
  25. Public lngSwap3                     As Long
  26. Public lngW                         As Long
  27.  
  28. Public strMsg                       As String
  29. Public strOldPaper                  As String
  30.  
  31. Public Type PALETTEENTRY
  32.     peRed                           As Byte
  33.     peGreen                         As Byte
  34.     peBlue                          As Byte
  35.     peFlags                         As Byte
  36. End Type
  37.  
  38. Public Type LOGPALETTE
  39.     palVersion                      As Integer
  40.     palNumEntries                   As Integer
  41.     palPalEntry(255)                As PALETTEENTRY        'Enough for 256 colors
  42. End Type
  43.  
  44. Public Type GUID
  45.     Data1                           As Long
  46.     Data2                           As Integer
  47.     Data3                           As Integer
  48.     Data4(7)                        As Byte
  49. End Type
  50.  
  51. Public Type PicBmp
  52.     size                            As Long
  53.     PicType                         As Long
  54.     hBmp                            As Long
  55.     hPal                            As Long
  56.     Reserved                        As Long
  57. End Type
  58.  
  59. Private 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
  60. Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
  61. Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
  62. Private Declare Function CreatePalette Lib "gdi32" (lpLogPalette As LOGPALETTE) As Long
  63. Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
  64. Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal iCapabilitiy As Long) As Long
  65. Private Declare Function GetSystemPaletteEntries Lib "gdi32" (ByVal hDC As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
  66. Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
  67. Private Declare Function RealizePalette Lib "gdi32" (ByVal hDC As Long) As Long
  68. Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
  69. Private Declare Function SelectPalette Lib "gdi32" (ByVal hDC As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
  70.  
  71. Public Declare Function DeleteFile Lib "kernel32" Alias "DeleteFileA" (ByVal lpFileName As String) As Long
  72. Public Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
  73. Public Declare Function GetTickCount Lib "kernel32" () As Long
  74.  
  75. Private Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture
  76.  
  77. Dim IID_IDispatch                   As GUID
  78. Dim IPic                            As IPicture
  79. Dim Pic                             As PicBmp
  80.  
  81.     On Error GoTo ExitHandler
  82.  
  83. '   Fill GUID info
  84.     With IID_IDispatch
  85.         .Data1 = &H20400
  86.         .Data4(0) = &HC0
  87.         .Data4(7) = &H46
  88.     End With
  89.  
  90. '   Fill picture info
  91.     With Pic
  92.         .size = Len(Pic)     'Length of structure
  93.         .PicType = vbPicTypeBitmap          'Type of Picture (bitmap)
  94.         .hBmp = hBmp         'Handle to bitmap
  95.         .hPal = hPal         'Handle to palette (may be null)
  96.     End With
  97.  
  98. '   Create the picture
  99.     OleCreatePictureIndirect Pic, IID_IDispatch, 1, IPic
  100. '   Return the new picture
  101.     Set CreateBitmapPicture = IPic
  102.  
  103. ExitHandler:
  104.  
  105. End Function
  106.  
  107. Public Function hDCToPicture(ByVal hDCSrc As Long, ByVal LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long) As Picture
  108.  
  109. Dim HasPaletteScrn                  As Long
  110. Dim hBmp                            As Long
  111. Dim hBmpPrev                        As Long
  112. Dim hDCMemory                       As Long
  113. Dim hPal                            As Long
  114. Dim hPalPrev                        As Long
  115. Dim LogPal                          As LOGPALETTE
  116. Dim PaletteSizeScrn                 As Long
  117.  
  118.     On Error GoTo ExitHandler
  119.  
  120. '   Create a compatible device context
  121.     hDCMemory = CreateCompatibleDC(hDCSrc)
  122. '   Create a compatible bitmap
  123.     hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
  124. '   Select the compatible bitmap into our compatible device context
  125.     hBmpPrev = SelectObject(hDCMemory, hBmp)
  126.  
  127. '   Does our picture use a palette?
  128.     HasPaletteScrn = (GetDeviceCaps(hDCSrc, RASTERCAPS)) And RC_PALETTE   'Palette
  129. '   What's the size of that palette?
  130.     PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE)   'Size of
  131.  
  132.     If HasPaletteScrn And (PaletteSizeScrn = 256) Then
  133. '       Set the palette version
  134.         With LogPal
  135.             .palVersion = &H300
  136. '           Number of palette entries
  137.             .palNumEntries = 256
  138. '           Retrieve the system palette entries
  139.             GetSystemPaletteEntries hDCSrc, 0, 256, .palPalEntry(0)
  140. '       Create the palette
  141.         End With             'LogPal
  142.  
  143.         hPal = CreatePalette(LogPal)
  144. '       Select the palette
  145.         hPalPrev = SelectPalette(hDCMemory, hPal, 0)
  146. '       Realize the palette
  147.         RealizePalette hDCMemory
  148.     End If
  149.  
  150. '   Copy the source image to our compatible device context
  151.     BitBlt hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, vbSrcCopy
  152. '   Restore the old bitmap
  153.     hBmp = SelectObject(hDCMemory, hBmpPrev)
  154.  
  155.     If HasPaletteScrn And (PaletteSizeScrn = 256) Then
  156. '       Select the palette
  157.         hPal = SelectPalette(hDCMemory, hPalPrev, 0)
  158.     End If
  159.  
  160. '   Delete our memory DC
  161.     DeleteDC hDCMemory
  162.     Set hDCToPicture = CreateBitmapPicture(hBmp, hPal)
  163.  
  164. ExitHandler:
  165.  
  166. End Function
  167.