用VB編寫DirectX7.0游戲
DirectX7.0終于出現了，同前面DirectX6相同，版本7也帶了一個龐大（129M）的SDK開發庫，同DirectX6 SDK庫相比，DirectX7的SDK庫提供了以下新的功能：
＊ 對于Visual Basic的支持。用戶可以使用類庫在Visual Basic環境下開發基于DirectX的程序。
＊ 提供更多DirectX3D立即模式（Immediate Mode）下的API函數，以支持DirectX7中新的3D特效，包括立體環境映射、頂點混合等。
＊ DirectMusic支持DownLoadable Sound Level 2標準。
＊ DirectInput支持8按鍵的游戲桿設備，同時支持Microsoft的力反饋搖桿。SDK庫提供了讀取力反饋效果文件的方法。同時提供了Force Editor程序來建立效果。
對于VB愛好者來說，新的SDK庫終于提供了完整的對VB的支持，現在終于可以使用Visual Basic來編寫DirectX的程序了。
一、DirectX SDK庫的安裝
微軟提供的SDK庫是一個“重”達129M的dx7sdk.exe自解壓縮文件，你可以上網下載或者從配套光盤上獲得這個文件。雙擊文件就會彈出Winzip自解壓縮對話框。在彈出的WinZip Self－Extract DK7SDK.EXE窗口中輸入解壓縮文件的路徑，然后點擊“Unzip”按鈕解壓縮SDK文件：
要注意的是，dx7sdk.exe解壓縮之后的體積有220M，硬盤比較緊張的讀者在解壓縮之前首先看看你的硬盤的容量是否足夠。
解壓縮完畢之后，進入解壓縮的目錄中，雙擊Setup.exe文件就可以安裝DirectX7.0 SDK文件了。安裝是采用標準的InstallShield界面，玩Windows的讀者應該對這種安裝界面駕輕就熟，只要跟著安裝提示一步一步地走就可以了。安裝完畢之后，安裝程序會在開始菜單中添加一個Microsoft DirectX 7 SDK的菜單，其中包括DirectX 7設置工具、VB范例和SDK Help等菜單項。
現在開始進入VB，開始我們的DirectX的VB編程。在這里我們使用的是VB6企業版（英文）。Windows98中文版。
打開VB，點擊菜單中的 Project | References 項，在Object 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對象，例如：
當建立成功一個DirectX7對象之后，就可以使用該對象的DirectDrawCreate、Direct3DRMCreate等方法建立DirectDraw、Direct3D對象了。
DirectX7對象范例1：獲得系統中的DirectDraw和DirectSound驅動建立一個新的工程文件，點擊菜單中的 Project | References 項，在Object Library 列表中選中DirectX 7.0 For Visual Basic Type Library 項后按確定按鈕（以下的程序都需要這個步驟，后面將不再做說明）。然后在Form1中加入一個ListBox控件和四個CommandButton控件，在Form1的代碼窗口中加入以下代碼：
運行程序，分別點擊不同的按鈕，在列表框中就會出現相應的設備驅動名和描述。
2 DirectDraw7對象
DirectDraw是一個與Windows 圖形系統接口(GDI)相兼容的直接操作顯示設備的軟件接口。DirectDraw提供與硬件無關性的同時允許直接操作顯存。程序只要使用一些基本的標準硬件約定，如：RGB及YUV色彩格式及解析度。你無須調用特殊的過程來使用顯存塊移動(Blitter)及調色板。使用DirectDraw，你可簡單操作顯存，完全使用各種硬件特性而不必理會各種不同硬件之間的差異。
2.1 建立DirectDraw對象
DirectDraw7對象是DirectX7中的DirectDraw對象，你需要首先建立一個DirectX7對象，然后使用該對象的DirectDrawCreate方法來建立DirectDraw7對象。例如：
2.2 建立協作層
當建立了一個DirectDraw對象之后，首先要設定DirectDraw的協作層。實現的方法是調用DirectDraw對象的SetCooperativeLevel函數。該函數的定義是：
其中參數hdl指定程序的窗口句柄，參數flag決定程序運行的方式，函數調用
將使程序運行于普通的協作層即窗口模式之下。在這種協作層你無法改變主平面調色板或進行頁交換，因為程序可以使用多窗口。而函數調用
將使程序運行于全屏幕模式之下。在全屏幕協作模式之下你可以完全使用硬件的一切。在這個模式之下，你可以設置使用定義及動態調色板，改變顯示分辨率及進行頁交換。
＊ 對于Visual Basic的支持。用戶可以使用類庫在Visual Basic環境下開發基于DirectX的程序。
＊ 提供更多DirectX3D立即模式（Immediate Mode）下的API函數，以支持DirectX7中新的3D特效，包括立體環境映射、頂點混合等。
＊ DirectMusic支持DownLoadable Sound Level 2標準。
＊ DirectInput支持8按鍵的游戲桿設備，同時支持Microsoft的力反饋搖桿。SDK庫提供了讀取力反饋效果文件的方法。同時提供了Force Editor程序來建立效果。
對于VB愛好者來說，新的SDK庫終于提供了完整的對VB的支持，現在終于可以使用Visual Basic來編寫DirectX的程序了。
一、DirectX SDK庫的安裝
微軟提供的SDK庫是一個“重”達129M的dx7sdk.exe自解壓縮文件，你可以上網下載或者從配套光盤上獲得這個文件。雙擊文件就會彈出Winzip自解壓縮對話框。在彈出的WinZip Self－Extract DK7SDK.EXE窗口中輸入解壓縮文件的路徑，然后點擊“Unzip”按鈕解壓縮SDK文件：
要注意的是，dx7sdk.exe解壓縮之后的體積有220M，硬盤比較緊張的讀者在解壓縮之前首先看看你的硬盤的容量是否足夠。
解壓縮完畢之后，進入解壓縮的目錄中，雙擊Setup.exe文件就可以安裝DirectX7.0 SDK文件了。安裝是采用標準的InstallShield界面，玩Windows的讀者應該對這種安裝界面駕輕就熟，只要跟著安裝提示一步一步地走就可以了。安裝完畢之后，安裝程序會在開始菜單中添加一個Microsoft DirectX 7 SDK的菜單，其中包括DirectX 7設置工具、VB范例和SDK Help等菜單項。
現在開始進入VB，開始我們的DirectX的VB編程。在這里我們使用的是VB6企業版（英文）。Windows98中文版。
打開VB，點擊菜單中的 Project | References 項，在Object 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控件和四個CommandButton控件，在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對象的SetCooperativeLevel函數。該函數的定義是：
| 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 |
將使程序運行于全屏幕模式之下。在全屏幕協作模式之下你可以完全使用硬件的一切。在這個模式之下，你可以設置使用定義及動態調色板，改變顯示分辨率及進行頁交換。
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 DDSFrontDesc As DDSURFACEDESC2 With DDSFrontDesc .lFlags = DDSD_CAPS .ddsCaps.lCaps=DDSCAPS_PRIMARYSURFACE ' End With Set DDSFront = DDraw.CreateSurface(DDSFrontDesc) |
也可以利用DirectDraw對象的CreateSurfaceFromFile函數或者CreateSurfaceFromResource函數建立一個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 Pos As 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 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 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 在工程文件中再加入一個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 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 '建立一個內存圖形設備句柄 hDCMemory=CreateCompatibleDC(hdcSrc) '建立一個bitmap并保存到hDCMemory中 hBmp = CreateCompatibleBitmap(hdcSrc, WidthSrc, HeightSrc) hBmpPrev = SelectObject(hDCMemory, hBmp) RasterCapsScrn = GetDeviceCaps(hdcSrc, RASTE圖CAPS) 'rRaste HasPaletteScrn = RasterCapsScrn And RC_PALtTTEic1 ' Palette PaletteSizeScrn = GetDeviceCaps(hdcSrc, SIZEPALETTE) ' Size of 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) 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 |
運行程序，在屏幕上會出現一些火焰字的特效，按Enter鍵可以將屏幕保存到“c:a.bmp”中，按Esc鍵退出程序回到Windows。
在上面的程序中，程序首先建立一個DirectDraw對象，然后設置該對象的協作層為全屏協作模式，接下來設置顯示模式為640×480×8位顏色，建立一個前臺DirectDrawSurface對象和一個后臺緩沖DirectDrawSurface對象，建立和設置DirectDrawClipper對象。
在主程序段中，程序首先對前臺繪圖平面的調色板（DirectDrawPalette）對象進行操作以改變顯示的文字的顏色，然后對后臺緩沖繪圖平面進行字節操作，以產生文字彌散的效果，然后再將后臺緩沖繪圖平面翻轉到前臺。當用戶按下Enter鍵之后，程序獲得與前臺繪圖平面相兼容的圖形設備句柄，然后再調用Windows API函數將繪圖平面內存中的內容保存到Windows位圖文件中。
上面粗略地介紹了DirectX7 SDK的新特性以及初步的DirectDraw編程，希望對大家能有所幫助。以上的程序在Windows98、VB6.0下運行通過。