窗体DDTut1
Option Explicit
Option Compare Text'Module level variables
Dim objDX As New DirectX7
Dim objDD As DirectDraw7
Dim objDDSurf As DirectDrawSurface7
Dim objDDPrimSurf As DirectDrawSurface7
Dim ddsd1 As DDSURFACEDESC2
Dim ddsd2 As DDSURFACEDESC2
Dim ddClipper As DirectDrawClipperDim bInit As BooleanPrivate Sub Form_Load()
init
End SubSub init()
Dim sMedia As String
'Initialization procedure
'The empty string parameter means to use the active display driver
Set objDD = objDX.DirectDrawCreate("")
'Notice that the show event calls Form_Resize
'Indicate this app will be a normal windowed app
'with the same display depth as the current display
Call objDD.SetCooperativeLevel(Me.hWnd, DDSCL_NORMAL)
'Indicate that the ddsCaps member is valid in this type
ddsd1.lFlags = DDSD_CAPS
'This surface is the primary surface (what is visible to the user)
ddsd1.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE
'Your creating the primary surface now with the surface description you just set
Set objDDPrimSurf = objDD.CreateSurface(ddsd1)
'Call the FindMediaDir procedure
sMedia = FindMediaDir("lake.bmp")
If sMedia = vbNullString Then sMedia = AddDirSep(CurDir)
'Now let's set the second surface description
ddsd2.lFlags = DDSD_CAPS
'This is going to be a plain off-screen surface
ddsd2.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
'Now we create the off-screen surface
Set objDDSurf = objDD.CreateSurfaceFromFile(sMedia & "lake.bmp", ddsd2)
Set ddClipper = objDD.CreateClipper(0)
ddClipper.SetHWnd Picture1.hWnd
objDDPrimSurf.SetClipper ddClipper
'Yes it has been initialized and is ready to blit
bInit = True
'Ok now were ready to blit this thing, call the blt procedure
bltEnd Sub
Private Sub Form_Resize()
'This procedure is called by the me.show event or when
'The form is resized during runtime.
'Since DX uses pixels and VB uses twips this procedure
'Syncs up the two scales
'Remember to change the ScaleMode property on the
'Form to Pixels. Notice the Width and Height of the form
'Stay in twips even after you change the ScaleMode, but
'The ScaleWidth and the ScaleHeight are now in pixels.
Picture1.Width = Me.ScaleWidth
Picture1.Height = Me.ScaleHeight
blt
End Sub
Sub blt()
'Has it been initialized? If not let's get out of this procedure
If bInit = False Then Exit Sub
'Some local variables
Dim ddrval As Long
Dim r1 As RECT
Dim r2 As RECT
'Gets the bounding rect for the entire window handle, stores in r1
objDX.GetWindowRect Picture1.hWnd, r1
r2.Bottom = ddsd2.lHeight
r2.Right = ddsd2.lWidth
ddrval = objDDPrimSurf.blt(r1, objDDSurf, r2, DDBLT_WAIT)
End SubPrivate Sub Picture1_Paint()
'This procedure is called during runtime when the form
'is moved or resized.
objDD.RestoreAllSurfaces
init
blt
End Sub
模块MediaDir
Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Copyright (C) 2000 Microsoft Corporation. All Rights Reserved.
'
' File: media.bas
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Registry constants
Private Const KEY_READ = 131097
Private Const REG_SZ = 1
Private Const HKEY_LOCAL_MACHINE = &H80000002
'Registry API's
Private Declare Function RegConnectRegistry Lib "advapi32.dll" Alias "RegConnectRegistryA" (ByVal lpMachineName As String, ByVal hKey As Long, phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As LongPublic Function FindMediaDir(ByVal sFile As String, Optional ByVal fUseCMedia As Boolean = False) As String
If Dir$(sFile, vbNormal) <> vbNullString Then 'This file is the current folder
FindMediaDir = AddDirSep(CurDir)
Exit Function
End If
If fUseCMedia Then
FindMediaDir = AddDirSep(GetDXSampleFolder) & "media\"
Else
FindMediaDir = AddDirSep(GetDXSampleFolder) & "vbsamples\media\"
End If
End FunctionPublic Function AddDirSep(ByVal sPath As String) As String
AddDirSep = sPath
If Right$(sPath, 1) <> "\" Then
AddDirSep = sPath & "\"
End If
End FunctionPublic Function GetDXSampleFolder() As String
Dim lHandle As Long
Dim lNewHandle As Long, sValue As String
Dim lNewKey As Long
RegConnectRegistry vbNullString, HKEY_LOCAL_MACHINE, lHandle
RegOpenKeyEx lHandle, "SOFTWARE\Microsoft\DirectX", 0, KEY_READ, lNewHandle
sValue = Space$(255)
RegQueryValueEx lNewHandle, "DX8SDK Samples Path", 0, REG_SZ, sValue, 255
If sValue <> Space$(255) Then
sValue = Left$(sValue, InStr(sValue, Chr$(0)) - 1)
Else
sValue = vbNullString
End If
RegCloseKey lNewHandle
RegCloseKey lHandle
GetDXSampleFolder = sValue
End Function引用directx7,其中用到一个bmp图片,你自己加到路径里去吧
Option Explicit
Option Compare Text'Module level variables
Dim objDX As New DirectX7
Dim objDD As DirectDraw7
Dim objDDSurf As DirectDrawSurface7
Dim objDDPrimSurf As DirectDrawSurface7
Dim ddsd1 As DDSURFACEDESC2
Dim ddsd2 As DDSURFACEDESC2
Dim ddClipper As DirectDrawClipperDim bInit As BooleanPrivate Sub Form_Load()
init
End SubSub init()
Dim sMedia As String
'Initialization procedure
'The empty string parameter means to use the active display driver
Set objDD = objDX.DirectDrawCreate("")
'Notice that the show event calls Form_Resize
'Indicate this app will be a normal windowed app
'with the same display depth as the current display
Call objDD.SetCooperativeLevel(Me.hWnd, DDSCL_NORMAL)
'Indicate that the ddsCaps member is valid in this type
ddsd1.lFlags = DDSD_CAPS
'This surface is the primary surface (what is visible to the user)
ddsd1.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE
'Your creating the primary surface now with the surface description you just set
Set objDDPrimSurf = objDD.CreateSurface(ddsd1)
'Call the FindMediaDir procedure
sMedia = FindMediaDir("lake.bmp")
If sMedia = vbNullString Then sMedia = AddDirSep(CurDir)
'Now let's set the second surface description
ddsd2.lFlags = DDSD_CAPS
'This is going to be a plain off-screen surface
ddsd2.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
'Now we create the off-screen surface
Set objDDSurf = objDD.CreateSurfaceFromFile(sMedia & "lake.bmp", ddsd2)
Set ddClipper = objDD.CreateClipper(0)
ddClipper.SetHWnd Picture1.hWnd
objDDPrimSurf.SetClipper ddClipper
'Yes it has been initialized and is ready to blit
bInit = True
'Ok now were ready to blit this thing, call the blt procedure
bltEnd Sub
Private Sub Form_Resize()
'This procedure is called by the me.show event or when
'The form is resized during runtime.
'Since DX uses pixels and VB uses twips this procedure
'Syncs up the two scales
'Remember to change the ScaleMode property on the
'Form to Pixels. Notice the Width and Height of the form
'Stay in twips even after you change the ScaleMode, but
'The ScaleWidth and the ScaleHeight are now in pixels.
Picture1.Width = Me.ScaleWidth
Picture1.Height = Me.ScaleHeight
blt
End Sub
Sub blt()
'Has it been initialized? If not let's get out of this procedure
If bInit = False Then Exit Sub
'Some local variables
Dim ddrval As Long
Dim r1 As RECT
Dim r2 As RECT
'Gets the bounding rect for the entire window handle, stores in r1
objDX.GetWindowRect Picture1.hWnd, r1
r2.Bottom = ddsd2.lHeight
r2.Right = ddsd2.lWidth
ddrval = objDDPrimSurf.blt(r1, objDDSurf, r2, DDBLT_WAIT)
End SubPrivate Sub Picture1_Paint()
'This procedure is called during runtime when the form
'is moved or resized.
objDD.RestoreAllSurfaces
init
blt
End Sub
模块MediaDir
Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Copyright (C) 2000 Microsoft Corporation. All Rights Reserved.
'
' File: media.bas
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Registry constants
Private Const KEY_READ = 131097
Private Const REG_SZ = 1
Private Const HKEY_LOCAL_MACHINE = &H80000002
'Registry API's
Private Declare Function RegConnectRegistry Lib "advapi32.dll" Alias "RegConnectRegistryA" (ByVal lpMachineName As String, ByVal hKey As Long, phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As LongPublic Function FindMediaDir(ByVal sFile As String, Optional ByVal fUseCMedia As Boolean = False) As String
If Dir$(sFile, vbNormal) <> vbNullString Then 'This file is the current folder
FindMediaDir = AddDirSep(CurDir)
Exit Function
End If
If fUseCMedia Then
FindMediaDir = AddDirSep(GetDXSampleFolder) & "media\"
Else
FindMediaDir = AddDirSep(GetDXSampleFolder) & "vbsamples\media\"
End If
End FunctionPublic Function AddDirSep(ByVal sPath As String) As String
AddDirSep = sPath
If Right$(sPath, 1) <> "\" Then
AddDirSep = sPath & "\"
End If
End FunctionPublic Function GetDXSampleFolder() As String
Dim lHandle As Long
Dim lNewHandle As Long, sValue As String
Dim lNewKey As Long
RegConnectRegistry vbNullString, HKEY_LOCAL_MACHINE, lHandle
RegOpenKeyEx lHandle, "SOFTWARE\Microsoft\DirectX", 0, KEY_READ, lNewHandle
sValue = Space$(255)
RegQueryValueEx lNewHandle, "DX8SDK Samples Path", 0, REG_SZ, sValue, 255
If sValue <> Space$(255) Then
sValue = Left$(sValue, InStr(sValue, Chr$(0)) - 1)
Else
sValue = vbNullString
End If
RegCloseKey lNewHandle
RegCloseKey lHandle
GetDXSampleFolder = sValue
End Function引用directx7,其中用到一个bmp图片,你自己加到路径里去吧
解决方案 »
免费领取超大流量手机卡,每月29元包185G流量+100分钟通话, 中国电信官方发货