魔塔之拯救白娘子~我的第一个VB6+DX8做的小游戏源码~24开始游戏-屏幕截图

魔塔之拯救白娘子 完整工程下载地址：
魔塔之拯救白娘子》流程分析8：屏幕截图和通用申明
有网友问我主窗口设计界面是什么样子？下图就是：frmMain.frm

设计界面非常清爽，只有一个tiemr控件（用来根据running的值 控制程序流程），一个Picture1控件，一个PictureClip1控件，这2个用来实现屏幕自动截图功能。（如果不需要自动截图连这个2个控件都不需要。自动截图主要是在读取游戏记录的显示当前关口好看一点。。。）
下边送上自动截图BAS源码：

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

Public Const RASTERCAPS As Long = 38
Public Const RC_PALETTE As Long = &H100
Public Const SIZEPALETTE As Long = 104
Public Const vbHiMetric As Integer = 8
Private Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type

Public 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
Public Declare Function SelectObject Lib "GDI32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Public 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
Public 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
'释放由调用GetDC或GetWindowDC函数获取的指定设备场景。它对类或私有设备场景无效（但这样的调用不会造成损害）
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 Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Public Const SRCCOPY = &HCC0020
Private Type PicBmp
   Size As Long
   Type As Long
   hBmp As Long
   hPal As Long
   Reserved As Long
End Type


 Private 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 gu As GUID
    With gu
      .Data1 = &H20400
      .Data4(0) = &HC0
      .Data4(7) = &H46
    End With

    With Pic
      .Size = Len(Pic)
      .Type = vbPicTypeBitmap
      .hBmp = hBmp
      .hPal = hPal
    End With
    r = OleCreatePictureIndirect(Pic, gu, 1, IPic)
    Set CreateBitmapPicture = IPic
End Function
 
Private Function CaptureWindow(ByVal hWndSrc As Long, ByVal Client As Boolean, 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 hDCSrc 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 LOGPALETTE
    If Client Then
        hDCSrc = GetDC(hWndSrc)
    Else
        hDCSrc = GetWindowDC(hWndSrc)
    End If
    hDCMemory = CreateCompatibleDC(hDCSrc)
    hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
    hBmpPrev = SelectObject(hDCMemory, hBmp)
    RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS)
    HasPaletteScrn = RasterCapsScrn And RC_PALETTE
    PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE)
    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)
    r = ReleaseDC(hWndSrc, hDCSrc)
    Set CaptureWindow = CreateBitmapPicture(hBmp, hPal)
End Function

Private Function CaptureScreen() As Picture
    Dim hWndScreen As Long
    '取得窗体句柄
    hWndScreen = GetDesktopWindow()
    '捕获窗体
    Set CaptureScreen = CaptureWindow(hWndScreen, False, 0, 0, Screen.Width \ Screen.TwipsPerPixelX, Screen.Height \ Screen.TwipsPerPixelY)
End Function
 
Public Function CaptureForm(frmSrc As Form) As Picture
    Set CaptureForm = CaptureWindow(frmSrc.hWnd, False, 0, 0, frmSrc.ScaleX(frmSrc.Width, vbTwips, vbPixels), frmSrc.ScaleY(frmSrc.Height, vbTwips, vbPixels))
End Function
 
Private Function CaptureClient(frmSrc As Form) As Picture
    Set CaptureClient = CaptureWindow(frmSrc.hWnd, True, 0, 0, frmSrc.ScaleX(frmSrc.ScaleWidth, frmSrc.ScaleMode, vbPixels), frmSrc.ScaleY(frmSrc.ScaleHeight, frmSrc.ScaleMode, vbPixels))
End Function

 
Private Function CaptureActiveWindow() As Picture
    Dim hWndActive As Long
    Dim r As Long
    Dim RectActive As RECT
    hWndActive = GetForegroundWindow()
    r = GetWindowRect(hWndActive, RectActive)
    Set CaptureActiveWindow = CaptureWindow(hWndActive, False, 0, 0, RectActive.Right - RectActive.Left, RectActive.Bottom - RectActive.Top)
End Function

 
Private Sub Printwindow(Prn As Printer, Pic As Picture)
    Dim PicRatio As Double
    Dim PrnWidth As Double
    Dim PrnHeight As Double
    Dim PrnRatio As Double
    Dim PrnPicWidth As Double
    Dim PrnPicHeight As Double
    If Pic.Height >= Pic.Width Then
        Prn.Orientation = vbPRORPortrait
    Else
        Prn.Orientation = vbPRORLandscape
    End If
    PicRatio = Pic.Width / Pic.Height
    PrnWidth = Prn.ScaleX(Prn.ScaleWidth, Prn.ScaleMode, vbHiMetric)
    PrnHeight = Prn.ScaleY(Prn.ScaleHeight, Prn.ScaleMode, vbHiMetric)
    PrnRatio = PrnWidth / PrnHeight
    If PicRatio >= PrnRatio Then
        PrnPicWidth = Prn.ScaleX(PrnWidth, vbHiMetric, Prn.ScaleMode)
        PrnPicHeight = Prn.ScaleY(PrnWidth / PicRatio, vbHiMetric, Prn.ScaleMode)
    Else
        PrnPicHeight = Prn.ScaleY(PrnHeight, vbHiMetric, Prn.ScaleMode)
        PrnPicWidth = Prn.ScaleX(PrnHeight * PicRatio, vbHiMetric, Prn.ScaleMode)
    End If
    Prn.PaintPicture Pic, 0, 0, PrnPicWidth, PrnPicHeight
End Sub

下边送上通用声明BAS：

Option Explicit
Public 播放音乐 As New xShow
Public 播放音效 As New xAudio


Public Running As Integer  '游戏运行状态标志
Public BackPic As New xGraphPool


Public 读档标志 As Boolean
Public 手动存档数量 As Integer
Public 自动存档数量 As Integer

Public 对话窗口显示标志 As Boolean
Public 跳楼对话窗口显示标志 As Boolean
Public 对话文件名编号 As Integer
Public 商店对话ID As Integer
Public 商店对话窗口显示标志 As Boolean
Public 地图层号 As Integer
Public 已走过的地图层号 As Integer
Public 怪物信息(50) As String
Public 地图数据(12) As String
Public 地图最大层号 As Integer
Public 自动寻路开始坐标 As POINTS

Public 自动寻路成功标志 As Boolean
Public 自动寻路终点坐标 As POINTS
'以下用于窗口透明
Public Declare Function GetWindowLong Lib "USER32" Alias "GetWindowLongA" (ByVal hWnd As Long, _
ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "USER32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, _
 ByVal dwNewLong As Long) As Long
Public Declare Function SetLayeredWindowAttributes Lib "USER32" (ByVal hWnd As Long, ByVal crKey As Long, _
ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long

Public Const WS_EX_LAYERED = &H80000
Public Const GWL_EXSTYLE = (-20)
Public Const LWA_ALPHA = &H2
Public Const LWA_COLORKEY = &H1
'以上用于窗口透明
'窗口置顶
Declare Function SetWindowPos& Lib "USER32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long)

Public Declare Sub keybd_event Lib "USER32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)


Public Declare Sub Sleep Lib "Kernel32" (ByVal dwMilliseconds As Long)
'检查文件是否存在
Public Declare Function PathFileExists Lib "shlwapi.dll" Alias "PathFileExistsA" (ByVal pszPath As String) As Long

Type 谈话对象列表
 NPC对话标志_小偷 As Integer
 NPC对话标志_小青 As Integer
 NPC对话标志_白娘子 As Integer
 NPC对话标志_老人 As Integer
 NPC对话标志_商人 As Integer
 NPC对话标志_冥灵魔王 As Integer
 NPC对话标志_红衣魔王 As Integer
 NPC对话标志_红衣大魔王 As Integer
 NPC对话标志_血影 As Integer
End Type


 Type 地图状态
        新地图(99) As Boolean
        读系统档(99) As Boolean
        读玩家档 As Boolean
        上楼处理标志(99) As Boolean
        下楼处理标志(99) As Boolean
        地图当前层号 As Integer
        到过的最大层号 As Integer
        J坐标 As Integer
        K坐标 As Integer
 End Type



 Type 包裹
        红钥匙数量 As Integer
        蓝钥匙数量 As Integer
        黄钥匙数量 As Integer
        铁榔头数量 As Boolean
        星光神锒数量 As Boolean
        风之罗盘数量 As Boolean
        怪物手册数量 As Boolean
        幸运十字架数量 As Boolean
        圣光徽的数量 As Integer
 End Type
 
 Type 怪物属性
    怪物名 As String
    怪物等级 As Integer
    怪物生命值 As Long
    怪物攻击力 As Long
    怪物防御值 As Long
    怪物持有的金币 As Currency
    怪物的经验值 As Single
 End Type

 Type 人物属性
    角色名 As String
    角色等级 As Integer
    角色生命值 As Long
    角色攻击力 As Long
    角色防御值 As Long
    角色持有的金币 As Currency
    角色的经验值 As Single
 End Type

 Type 角色移动
    x As Integer
    y As Integer
    移动步数 As Integer
    移动方向 As Integer '上下左右
    移动速度 As Integer
    x行 As Integer
    y列 As Integer
 End Type
 
Public 男主角移动 As 角色移动
Public 小青的移动 As 角色移动

Public 人物信息 As 人物属性
Public 怪物相关属性 As 怪物属性

Public 勇者包裹 As 包裹
Public 游戏进度 As 地图状态  '存放当前游戏角色的进度
Public 谈话对象 As 谈话对象列表
Public 战斗胜利标志 As Boolean



'产生一个范围内的随机数
Public Function Rndnum(Min As Long, max As Long) As Long
   Randomize
     Rndnum = Int((max - Min + 1) * Rnd + Min)
  End Function

'延时子程序
Public Function 延时(DT As Long)
    Dim i As Integer
    For i = 0 To DT Step 2
        DoEvents                                                                '操作权交给系统 否则程序会暂时无响应
        Sleep 1
    Next i
End Function

'---------------------------------
Public Function CheckPathFile(myPath As String) As Boolean
    Dim i     As Integer
    If myPath = "" Then
        'MsgBox "文件路径不能为空。", vbInformation
    Else
        CheckPathFile = CBool(PathFileExists(myPath))
    End If
End Function

Public Sub 自动截图(ByVal sFileName As String)

'模块中
'Public Sub SaveScreenShot(ByVal sFilename As String)
    Dim DXForm As Form
    Dim D3DPresentParam As D3DPRESENT_PARAMETERS
    Dim DX As New DirectX8
    Dim D3D As Direct3D8
    Dim D3DDevice As Direct3DDevice8
    Dim D3DX As New D3DX8
    
    Dim oSurface As Direct3DSurface8
    Dim SrcPalette As PALETTEENTRY             '因为256 色索引颜色已淘汰所以不再讨论调色板
    Dim SrcRect As RECT                        '保存表面的区域
    Dim DispMode As D3DDISPLAYMODE             '显示模式
    
    Set D3D = DX.Direct3DCreate
    
    D3DPresentParam.BackBufferWidth = frmMain.ScaleWidth
    D3DPresentParam.BackBufferHeight = frmMain.ScaleHeight         '这两句设置分辨率，BackBufferWidth、BackBufferHeight分别是游戏中使用分辨率的宽度、高度，分辨率的设计必须是机子上有的才可以，否则会报错
    D3DPresentParam.BackBufferFormat = D3DFMT_A8R8G8B8          '这句设置显示模式，属于CONST_D3DFORMAT常数类型，里面可以根据需要定义不同的A、R、G、B的位数，本教程使用D3DFMT_A8R8G8B8。
    D3DPresentParam.SwapEffect = D3DSWAPEFFECT_DISCARD          '设置换页效果为丢弃后台缓存
    D3DPresentParam.Windowed = 1                '这句设置是否是窗体，如果为1是窗体，为0是全屏
    Set D3DDevice = D3D.CreateDevice(D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, frmMain.hWnd, D3DCREATE_SOFTWARE_VERTEXPROCESSING, D3DPresentParam)
    D3DDevice.GetDisplayMode DispMode          '取得显示模式
'
    '创建一个surface对象存放前景缓冲。
    '因为GetFrontBuffer函数不管当前背景缓冲是什么格式总是返回 D3DFMT_A8R8G8B8，所以oSurface也要定义成D3DFMT_A8R8G8B8（32位真彩色格式）
    Set oSurface = D3DDevice.CreateImageSurface(DispMode.Width, DispMode.Height, D3DFMT_A8R8G8B8)
    
    '取得前景缓冲数据（这是唯一获得抗锯齿输出的方法）
    D3DDevice.GetFrontBuffer oSurface
    
    '我们保存这个表面全部区域
    With SrcRect
    .Left = 0 '0
    .Top = 0 '0
    .Right = DispMode.Width
    .Bottom = DispMode.Height
    End With
    
    '保存这个表面到一BMP文件
    '这里 SrcPalette 提示 只有定义在公共模块中用户定义类型和变体类型相互转换或传奇后期绑定功能
    D3DX.SaveSurfaceToFile sFileName, D3DXIFF_BMP, oSurface, SrcPalette, SrcRect
  
 
End Sub