DirectX 7 程式設計初步 (轉)

DirectX 7 程式設計初步 (轉)[@more@]作者：（長沙 陳銳）


用VB編寫7.0遊戲（上）

　　DirectX7.0終於出現了，同前面DirectX6相同，版本7也帶了一個龐大（129M）的SDK開發庫，同DirectX6 SDK庫相比，DirectX7的SDK庫提供了以下新的功能：
　　＊ 對於的支援。可以使用類庫在Visual Basic環境下開發基於DirectX的。
　　＊ 提供更多DirectX3D立即（Immediate Mode）下的，以支援DirectX7中新的3D特效，包括立體環境對映、頂點混合等。
　　＊ DirectMusic支援able Sound Level 2標準。
　　＊ DirectInput支援8按鍵的遊戲杆裝置，同時支援的力反饋搖桿。SDK庫提供了讀取力反饋效果的方法。同時提供了Force Editor程式來建立效果。
　　對於VB愛好者來說，新的SDK庫終於提供了完整的對VB的支援，現在終於可以使用Visual Basic來編寫DirectX的程式了。

　　一、DirectX SDK庫的

　　提供的SDK庫是一個“重”達129M的dx7sdk.exe自解檔案，你可以上網或者從配套光碟上獲得這個檔案。雙擊檔案就會彈出自解壓縮對話方塊。在彈出的WinZSelf－Extract DK7SDK.EXE視窗中輸入解壓縮檔案的路徑，然後點選“Unzip”按鈕解壓縮SDK檔案：
　　要注意的是，dx7sdk.exe解壓縮之後的體積有220M，比較緊張的讀者在解壓縮之前首先看看你的硬碟的容量是否足夠。
　　解壓縮完畢之後，進入解壓縮的目錄中，雙擊Setup.exe檔案就可以安裝DirectX7.0 SDK檔案了。安裝是採用標準的InstallShield介面，玩的讀者應該對這種安裝介面駕輕就熟，只要跟著安裝提示一步一步地走就可以了。安裝完畢之後，安裝程式會在開始選單中新增一個Microsoft DirectX 7 SDK的選單，其中包括DirectX 7設定工具、VB範例和SDK Help等選單項。
　　現在開始進入VB，開始我們的DirectX的VB。在這裡我們使用的是企業版（英文）。Windows98中文版。
　　開啟VB，點選選單中的 Project | References 項，在 Library 列表中會有一項：DirectX 7.0 For Visual Basic Type Library 列表項，這個就是DirectX7.0 VB類庫，選中該項，再選“ok”按鈕，就可以將庫加入工程檔案中。

　　二、DirectX程式設計初步

　　1，DirectX7

　　DirectX7物件是DirectX VB物件中其他所有物件的服務和起始物件，這個物件包含了建立諸如DirectDraw、 Direct3D、 DirectSound、 DirectInput等物件的方法。同時該物件還包含了一系列的三維頂點和距陣的操作函式以及一些DirectX函式。在VB中可以透過Dim...New來直接定義和初始化一個DirectX7物件，例如：
　　 Dim DirectX As New DirectX7
　　當建立成功一個DirectX7物件之後，就可以使用該物件的DirectDrawCreate、Direct3DRMCreate等方法建立DirectDraw、Direct3D物件了。
　　DirectX7物件範例1：獲得系統中的DirectDraw和DirectSound
　　建立一個新的工程檔案，點選選單中的 Project | References 項，在Object Library 列表中選中DirectX 7.0 For Visual Basic Type Library 項後按確定按鈕（以下的程式都需要這個步驟，後面將不再做說明）。然後在Form1中加入一個ListBox控制元件和四個Commanutton控制元件，在Form1的程式碼視窗中加入以下程式碼：
　　Option Explicit
　　
　　Dim DirectX As New DirectX7
　　Dim DDEnum As DirectDrawEnum
　　Dim DDSound As DirectSoundEnum
　　
　　Private Sub Command1_Click()
　　 Dim Count, I As Integer
　　
　　 Set DDEnum = DirectX.GetDDEnum
　　 Count = DDEnum.GetCount
　　 List1.Clear
　　 For I = 1 To Count
　　 List1.AddItem DDEnum.GetDescription(I)
　　 Next I
　　
　　 Set DDEnum = Nothing
　　End Sub
　　
　　Private Sub Command2_Click()
　　 Dim Count, I As Integer
　　
　　 Set DDEnum = DirectX.GetDDEnum
　　 Count = DDEnum.GetCount
　　 List1.Clear
　　 For I = 1 To Count
　　 List1.AddItem DDEnum.GetName(I)
　　 Next I
　　 Set DDEnum = Nothing
　　End Sub
　　
　　Private Sub Command3_Click()
　　 Dim Count, I As Integer
　　
　　 Set DDSound = DirectX.GetDSEnum
　　 Count = DDSound.GetCount
　　 List1.Clear
　　 For I = 1 To Count
　　 List1.AddItem DDSound.GetDescription(I)
　　 Next I
　　End Sub
　　
　　Private Sub Command4_Click()
　　 Dim Count, I As Integer
　　
　　 Set DDSound = DirectX.GetDSEnum
　　 Count = DDSound.GetCount
　　 List1.Clear
　　 For I = 1 To Count
　　 List1.AddItem DDSound.GetName(I)
　　 Next I
　　End Sub
　　
　　Private Sub Form_Load()
　　 Command1.Caption = "DirectDraw驅動描述"
　　 Command2.Caption = "DirectDraw驅動名稱"
　　 Command3.Caption = "DirectSound驅動描述"
　　 Command4.Caption = "DirectSound驅動名稱"
　　End Sub
　　
　　Private Sub Form_Unload(Cancel As Integer)
　　 Set DirectX = Nothing
　　End Sub
　　執行程式，分別點選不同的按鈕，在列表框中就會出現相應的裝置驅動名和描述。

　　2，DirectDraw7物件

　　DirectDraw是一個與Windows 圖形系統介面(GDI)相相容的直接操作顯示裝置的介面。DirectDraw提供與無關性的同時允許直接操作視訊記憶體。程式只要使用一些基本的標準硬體約定，如：RGB及YUV色彩格式及解析度。你無須特殊的過程來使用視訊記憶體塊移動(Blitter)及調色盤。使用DirectDraw，你可簡單操作視訊記憶體，完全使用各種硬體特性而不必理會各種不同硬體之間的差異。

　　2.1 建立DirectDraw物件
　　DirectDraw7物件是DirectX7中的DirectDraw物件，你需要首先建立一個DirectX7物件，然後使用該物件的DirectDrawCreate方法來建立DirectDraw7物件。例如：
　　 Dim DX As New DirectX7
　　 Dim Ddraw As DirectDraw7
　　 Set Ddraw = DX.DirectDrawCreate("")

　　2.2 建立協作層
　　當建立了一個DirectDraw物件之後，首先要設定DirectDraw的協作層。實現的方法是呼叫DirectDraw物件的SetCerativeLevel函式。該函式的定義是：
　　 object.SetCooperativeLevel( hdl As Long, flags As CONST_DDSCLFLAGS)
　　其中引數hdl指定程式的視窗控制程式碼，引數flag決定程式執行的方式，函式呼叫
　　 Ddraw.SetCooperativeLevel Me.hWnd, DDSCL_NORMAL
　　將使程式執行於普通的協作層即視窗模式之下。在這種協作層你無法改變主平面調色盤或進行頁，因為程式可以使用多視窗。而函式呼叫
　　Ddraw.SetCooperativeLevel MainForm.hWnd, DDSCL_EXCLUSIVE Or DDSCL_FULLSCREEN
　　將使程式執行於全螢幕模式之下。在全螢幕協作模式之下你可以完全使用硬體的一切。在這個模式之下，你可以設定使用定義及動態調色盤，改變顯示解析度及進行頁交換。


用VB編寫DirectX7.0遊戲（下）　（接上期）

　　2.3 設定顯示模式
　　設定顯示模式是使用SetDispalyMode函式實現的，函式的定義如下：

　　 object.SetDisplayMode (w As Long, h As Long, bpp As Long, ref As Long, mode As CONST_DDSDMFLAGS)

　　其中引數w、h分別指定螢幕的寬度和高度，bpp指定螢幕顯示的顏色位數，引數ref指定螢幕的重新整理頻率，設定為0使用顯示驅動的預設重新整理頻率，mode指定附加的引數。要獲得系統支援的顯示模式，可以使用DirectDraw物件的GetDisplayModesEnum函式來遍歷所有支援的顯示模式。

　　2.4 建立平面物件
　　一個平面或者說DirectDrawSurface物件是DirectDraw中圖形顯示和繪製物件。使用者可以在DirectDrawSurface上貼點陣圖、繪製圖形，還可以直接操作DirectDrawSurface物件使用視訊記憶體裡的內容。利用DirectDraw物件的CreateSurface方法可以建立一個DirectDrawSurface7物件。例如：

　　Public DDrontDesc As DDSURFACEDESC2
　　 With DDSFrontDesc
　　　.lFlags = DDSD_CAPS
　　　.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE
　　 End With
　　Set DDSFront = Ddraw.CreateSurface(DDSFrontDesc)

　　也可以利用DirectDraw物件的CreateSurfaceFromFile函式或者CreateSurfaceFromRe函式建立一個DirectDrawSurface7物件，同時將影像檔案或者資原始檔中的影像裝入建立的DirectDrawSurface中。如果上面的函式呼叫成功，函式將返回一個DirectDrawSurface物件。如果在設定DirectDraw物件的協作層時將其設定為全螢幕模式的話，為了改善影像，可以設立一個主平面和若干個屏下緩衝平面，首先在屏下平面中生成影像，然後將影像翻轉到主平面上，這樣可以有效地避免影像閃爍。

　　下面透過一個具體的範例來對DirectDraw進行說明：這個範例建立一個全螢幕的DirectDraw物件，透過操作主顯示平面的顯示在螢幕上顯示火焰字的特效，然後按Enter鍵可以將DirectDraw平面中的圖形儲存起來。程式的具體實現如下：

　　建立一個新的工程檔案，點選選單中的 Project | Reference 選項，開啟Object Library 列表視窗，將DirectX 7.0 For Visual Basic Type Library 加入工程檔案。將Form1的Name屬性改變為MainForm，在MainForm中加入一個PictureBox控制元件，將其的Visible屬性設定為False。然後在MainForm的程式碼視窗中加入以下程式碼：

　　Private Sub Form_KeyPress(KeyAscii As Integer)
　　 Dim sRect As RECT
　　 Dim hdcSrc As Long
　　 If KeyAscii = 27 Then
　　 ExitLoop = True
　　 'End
　　 ElseIf KeyAscii = vbKeyReturn Then
　　DDSFront.BltToDC Picture1.hDC, sRect, sRect
　　 With Picture1
　　 '獲得與主顯示平面相容的圖形裝置控制程式碼
　　 hdcSrc = DDSFront.GetDC
　　 '儲存影像
　　 Set .Picture = SaveTohBmp(hdcSrc, 0, 0, 640, 480)
　　 '釋放圖形控制程式碼
　　 DDSFront.ReleaseDC hdcSrc
　　 SavePicture Picture1, "c:a.bmp"
　　 End With
　　 End If
　　End Sub
　　
　　Public Sub Form_Paint()
　　 BlitRect.Right = DDSBackDesc.lWidth
　　 BlitRect.Bottom = DDSBackDesc.lHeight
　　 DDSFront.Blt BlitRect, DDSBack, BlitRect, DDBLT_WAIT
　　End Sub

　　在工程檔案中加入一個Module檔案，這個檔案中DirectDraw操作做出了定義，在這個Module中加入以下程式碼：

　　Option Explicit
　　Public DX As New DirectX7
　　Public Ddraw As DirectDraw7
　　Public DDSFront As DirectDrawSurface7
　　Public DDSFrontDesc As DDSURFACEDESC2
　　Public DDSBack As DirectDrawSurface7
　　Public DDSBackDesc As DDSURFACEDESC2
　　Public Clipper As DirectDrawClipper
　　Dim Pict() As Byte
　　Dim AlphaRect As RECT
　　Dim X As Long, Y As Long
　　Dim Temp As Long
　　Dim Index As Long
　　Dim Index2 As Long
　　Dim PAs Long
　　Dim PosPlus1 As Long
　　Dim PosPlus2 As Long
　　Dim PosPlus3 As Long
　　Public Pal(255) As PALETTEENTRY
　　Public Palette As DirectDrawPalette
　　Public BlitRect As RECT
　　Public FullSize As Boolean
　　Public ExitLoop As Boolean
　　Dim Accum As Long
　　Dim Msg(9) As String
　　Dim Counter As Long
　　Dim MsgIndex As Long
　　Dim bDrawText As Boolean
　　Dim lastTime As Long
　　Dim Xpos As Long, Ypos As Long
　　Dim wait As Long
　　Dim Angle As Single
　　Dim Flag As Boolean
　　Dim Count As Long
　　Dim CurModeActiveStatus As Boolean
　　Dim bRestore As Boolean
　　Dim Mode As Boolean


　　Private Sub Main()
　　 InitializeDX
　 　'初始化Picture1以獲得DirectDraw介面影像
　　　With MainForm.Picture1
　　　 .Width = 640 * Screen.TwipsPerPixelX
　　　 .Height = 480 * Screen.TwipsPerPixelY
　 　 End With
　　　DDSBack.SetForeColor RGB(255, 255, 255)
　　　MainForm.Font.Name = "宋體"
　　　DDSBack.SetFont MainForm.Font
　　　Msg(0) = "一個顯示火焰字的演示"
　　　Msg(1) = "演示"
　　　Msg(2) = "利用VB陣列"
　　　Msg(3) = "對顯示記憶體"
　　　Msg(4) = "進行直接存取"
　　　Msg(5) = "{Esc}鍵退出"
　　 '設定8位的調色盤
　　 For Index = 0 To 84
　　　 Pal(Index + 1).red = Index * 3 + 3
　　　 Pal(Index + 1).green = 0
　　　 Pal(Index + 1).blue = 0

　　　 Pal(Index + 86).red = 255
　　　 Pal(Index + 86).green = Index * 3 + 3
　　　 Pal(Index + 86).blue = 0

　　　 Pal(Index + 171).red = 255
　　　 Pal(Index + 171).green = 255
　　　 Pal(Index + 171).blue = Index * 3 + 3
　　 Next
　　　Set Palette = Ddraw.CreatePalette(DDPCAPS_8BIT Or DDPCAPS_ALLOW256, Pal())
　　　DDSFront.SetPalette Palette

　　　AlphaRect.Right = DDSBackDesc.lWidth - 1
　　　AlphaRect.Bottom=DDSBackDesc.lHeight - 1

　　　DDSBack.Lock AlphaRect, DDSBackDesc, DDLOCK_WAIT, 0
　　　DDSBack.GetLockedArray Pict()
　 　 For X = 0 To 639
　　　 For Y = 0 To 479
　　　　 Pict(X, Y) = 0
　　　 Next
　　　Next
　　 'Corresponding unlock
　　 DDSBack.Unlock AlphaRect

　 　 While Not ExitLoop
　　　 Mode = ExModeActive
　 　　 bRestore = False
　　 　 Do Until ExModeActive
　 　　　 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

　　 TenateDX
　　　End
　　End Sub


　　Function ExModeActive() As Boolean
　　 Dim TestCoopRes As Long
　 　TestCoopRes = Ddraw.TestCooperativeLevel
　　 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


　　在工程檔案中再加入一個Module，這個Module主要定義與影像儲存相關的操作，在建立的Module中加入以下程式碼：

　　Option Explicit
　　Option Base 0

　　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 HaletteScrn As Long
　 Dim PaletteSizeScrn As Long
　 Dim LogPal As LOOGPALETTE

　 '建立一個記憶體圖形裝置控制程式碼
　　hDCMemory=CreateCompatibleDC(hdcSrc)
　'建立一個bitmap並儲存到hDCMemory中
　　hBmp = CreateCompatibleBitmap(hdcSrc, WidthSrc, HeightSrc)
　　hBmpPrev = SelectObject(hDCMemory, hBmp)

　 ' Get screen properties.
　　 RasterCapsScrn = GetDeviceCaps(hdcSrc, RASTERCAPS) 'Raste capabilities.
　　 HasPaletteScrn = RasterCapsScrn And RC_PALtTTEic1 ' Palette support.
　　 PaletteSizeScrn = GetDeviceCaps(hdcSrc, SIZEPALETTE) ' Size of palette.
　　 If HasPaletteScrn And (PaletteSizeScrn = 256) Then
　 　 '建立系統調色盤的複製
　　　 LogPal.palVersion = &H300
　　　 LogPal.palNumEntries = 256
　　　 r = GetSystemPaletteEntries(hdcSrc, 0, 256, LogPal.palPalEntry(0))
　　　 hPal = CreatePalette(LogPal)
　　　 hPalPrev = SelectPalette(hDCMemory, hPal, 0)
　　　 r = RealizePalette(hDCMemory)
　　 End If
　　
　　 '將螢幕圖形複製到記憶體圖形裝置控制程式碼中
　　 r = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hdcSrc, LeftSrc, TopSrc, vbSrcCopy)
　　
　　 hBmp = SelectObject(hDCMemory, hBmpPrev)
　　
　　 If HasPaletteScrn And (PaletteSizeScrn = 256) Then
　　　 hPal = SelectPalette(hDCMemory, hPalPrev, 0)
　　 End If
　　
　　 '釋放圖形裝置控制程式碼
　　 r = DeleteDC(hDCMemory)
　　 De.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

　　執行程式，在螢幕上會出現一些火焰字的特效，按Enter鍵可以將螢幕儲存到“c:a.bmp”中，按Esc鍵退出程式回到Windows。

　　在上面的程式中，程式首先建立一個DirectDraw物件，然後設定該物件的協作層為全屏協作模式，接下來設定顯示模式為640×480×8位顏色，建立一個前臺DirectDrawSurface物件和一個後臺緩衝DirectDrawSurface物件，建立和設定DirectDrawClipper物件。
　　在主程式段中，程式首先對前臺繪圖平面的調色盤（DirectDrawPalette）物件進行操作以改變顯示的文字的顏色，然後對後臺緩衝繪圖平面進行位元組操作，以產生文字彌散的效果，然後再將後臺緩衝繪圖平面翻轉到前臺。當使用者按下Enter鍵之後，程式獲得與前臺繪圖平面相相容的圖形裝置控制程式碼，然後再呼叫Windows API函式將繪圖平面記憶體中的內容儲存到Windows位件中。

　　上面粗略地介紹了DirectX7 SDK的新特性以及初步的DirectDraw程式設計，希望對大家能有所幫助。以上的程式在Windows98、VB6.0下執行透過。