DoEvents bRestore = True Loop DoEvents If bRestore Then bRestore = False Ddraw.RestoreAllSurfaces End If DDSBack.Lock AlphaRect, DDSBackDesc, DDLOCK_WAIT, 0 DDSBack.GetLockedArray Pict() For Y = 0 To 479 Pict(0, Y) = 0 Pict(639, Y) = 0 Next For X = 0 To 639 Pict(X, 477) = Rnd * 220 + 35 Pict(X, 478) = Rnd * 220 + 35 Pict(X, 479) = Rnd * 220 + 35 Next Accum = 0 For X = 1 To 638 For Y = 0 To 477 Accum = (Accum + Pict(X, Y + 1) + Pict(X, Y + 2) _ + Pict(X + 1, Y + 1) + Pict(X - 1, Y + 1)) \ 5 If Accum < 0 Then Accum = 0 ElseIf Accum > 255 Then Accum = 255 End If Pict(X, Y) = Accum Next Next For X = 0 To 639 Pict(X, 0) = 0 Pict(X, 1) = 0 Next X = Rnd * 639 For Y = 50 To 439 Next ''''Unlock DDSBack.Unlock AlphaRect If DX.TickCount() - lastTime > wait Then If Counter = 0 Then bDrawText = True Counter = 1 Xpos = Rnd * 200 Ypos = 300 + Rnd * 140 wait = 400 ElseIf Counter = 1 Then MsgIndex = MsgIndex + 1 If MsgIndex > 5 Then MsgIndex = 0 bDrawText = False Counter = 0 wait = 2000 End If lastTime = DX.TickCount End If
''''Draw Text to the backbuffer If bDrawText Then On Error Resume Next DDSBack.DrawText Xpos, Ypos, Msg(MsgIndex), False On Error GoTo 0 End If
MainForm.Form_Paint Wend
TerminateDX End End Sub
Function ExModeActive() As Boolean Dim TestCoopRes As Long TestCoopRes = Ddraw.TestCooperativeLevel Select Case TestCoopRes Case DDERR_NOEXCLUSIVEMODE ExModeActive = False Case DD_OK ExModeActive = True End Select End Function
Public Sub InitializeDX() MainForm.Left = 0 MainForm.Top = 0 MainForm.Height =640 * Screen.TwipsPerPixelY MainForm.Width = 480 * Screen.TwipsPerPixelX MainForm.Show
''''建立DirectDraw对象 Set Ddraw = DX.DirectDrawCreate("") ''''设定DirectDraw对象的协作层 Ddraw.SetCooperativeLevel MainForm.hWnd, DDSCL_EXCLUSIVE Or DDSCL_FULLSCREEN '''' DDSCL_NORMAL ''''设定显示模式位640×480×8位颜色 Ddraw.SetDisplayMode 640, 480, 8, 0, DDSDM_DEFAULT
''''设定DDSFrontDesc为主平面 With DDSFrontDesc .lFlags = DDSD_CAPS .ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE ''''Or DDSCAPS_SYSTEMMEMORY End With
''''设定DDSBackDesc为后台缓冲平面 With DDSBackDesc .ddsCaps.lCaps = DDSCAPS_SYSTEMMEMORY .lFlags = DDSD_CAPS Or DDSD_WIDTH Or DDSD_HEIGHT .lWidth = 640 .lHeight = 480 End With
''''建立平面 Set DDSFront = Ddraw.CreateSurface(DDSFrontDesc) Set DDSBack = Ddraw.CreateSurface(DDSBackDesc) Set Clipper = Ddraw.CreateClipper(0) Clipper.SetHWnd MainForm.hWnd DDSFront.SetClipper Clipper DDSBack.SetClipper Clipper
DoEvents Exit Sub ERRoUT: If Not (Ddraw Is Nothing) Then Ddraw.RestoreDisplayMode Ddraw.SetCooperativeLevel MainForm.hWnd, DDSCL_NORMAL DoEvents End If MsgBox “无法对DirectDraw进行初始化 ”＋Chr(13)＋“也许你的显示卡不支持 640×480×8 显示模式 ” End End Sub
Public Sub TerminateDX() ''''子程序TerminateDX回复原来的显示模式并且释放所有的DirectDraw有关对象 Ddraw.RestoreDisplayMode Ddraw.SetCooperativeLevel MainForm.hWnd, DDSCL_NORMAL DoEvents Set Clipper = Nothing Set DDSBack = Nothing Set DDSFront = Nothing Set Ddraw = Nothing Set DX = Nothing End Sub
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 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 Type PicBmp Size As Long Type As Long hBmp As Long hPal As Long Reserved As Long End Type
Private Declare Function OleCreatePictureIndirect Lib “olepro32.dll” (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, Ipic As Ipicture) As Long
Public Function SaveTohBmp(ByVal hdcSrc As Long, 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 hPal As Long Dim hPalPrev As Long Dim RasterCapsScrn As Long Dim HasPaletteScrn As Long Dim PaletteSizeScrn As Long Dim LogPal As LOOGPALETTE
If HasPaletteScrn And (PaletteSizeScrn = 256) Then hPal = SelectPalette(hDCMemory, hPalPrev, 0) End If
''''释放图形设备句柄 r = DeleteDC(hDCMemory) Debug.Print r
''''调用CreateBitmapPicture函数从指定的bitmap对象和调色板中建立一个picture对象 Set SaveTohBmp = CreateBitmapPicture(hBmp, hPal) End Function
Public Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture Dim r As Long Dim Pic As PicBmp Dim Ipic As Ipicture Dim IID_Idispatch As GUID
''''填充Idispatch界面 With IID_Idispatch .Data1 = &H20400 .Data4(0) = &HC0 .Data4(7) = &H46 End With
''''填充Pic结构 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
''''建立Picture对象 r = OleCreatePictureIndirect(Pic, IID_Idispatch, 1, Ipic)
''''返回Picture对象 Set CreateBitmapPicture = Ipic End Function
注：本站部分文章源于互联网，版权归原作者所有！如有侵权，请原作者与本站联系，本站将立即删除！ 本站文章除特别注明外均可转载，但需注明出处！ [MinTao学以致用网] 
