DX7下如何实现半透明？

nogood

Sub EndIt(Optional hWnd As Long = 0) '//* DX 过程结速时的过程式！
    gT_Dx_Start_Ok = False
    If hWnd = 0 Then hWnd = gL_mFromHwnd
    Call Err_Msg_Log.AppendToLog("结束 DirectX", True, False) '//*  调试用过程
    Call Err_Msg_Log.CheckComputer(True) '//*  调试用过程
        binit = False
        brunning = False
        DD.RestoreDisplayMode
        DD.SetCooperativeLevel hWnd, DDSCL_NORMAL
    Call Err_Msg_Log.AppendToLog("恢复显示模式......", True, True) '//*  调试用过程
    DoEvents
       Set ClipperObj = Nothing
       Set Primary = Nothing
       Set BackBuffer = Nothing
    Call Err_Msg_Log.AppendToLog("清空设备....", True, True) '//*  调试用过程
    Dim i As Integer
    For i = 0 To UBound(BackGround)
        Set BackGround(i).DDSface7 = Nothing
    Next
    For i = 0 To UBound(Sprite)
        Set Sprite(i).DDSface7 = Nothing
    Next
       Erase BackGround
       Erase Sprite()
       Set DD = Nothing
       Set D3d = Nothing
       Set dx = Nothing
       Set Dev = Nothing
       'Call DInput.Terminate '//*  输入过程清空！！！！！
    Call Err_Msg_Log.AppendToLog("OK ....", True, True) '//*  调试用过程
    Call Err_Msg_Log.SaveLog '//*  写到 Log 文件里 '//*  调试用过程
      '子程序TerminateDX回复原来的显示模式并且释放所有的DirectDraw有关对象
    'End
End Sub


Sub Gamma_UpdateGamma(intRed As Integer, intGreen As Integer, intBlue As Integer)
    On Error GoTo GamOut:
    Dim i As Integer
   If gT_Gamma_Run = False Then Exit Sub
   If GammaSupport = True Then
        Do
            If intRed < 0 Then GammaRamp.red(i) = ConvToSignedValue(ConvToUnSignedValue(OriginalRamp.red(i)) * (100 - Abs(intRed)) / 100)
            If intRed = 0 Then GammaRamp.red(i) = OriginalRamp.red(i)
            If intRed > 0 Then GammaRamp.red(i) = ConvToSignedValue(65535 - ((65535 - ConvToUnSignedValue(OriginalRamp.red(i))) * (100 - intRed) / 100))
            If intGreen < 0 Then GammaRamp.green(i) = ConvToSignedValue(ConvToUnSignedValue(OriginalRamp.green(i)) * (100 - Abs(intGreen)) / 100)
            If intGreen = 0 Then GammaRamp.green(i) = OriginalRamp.green(i)
            If intGreen > 0 Then GammaRamp.green(i) = ConvToSignedValue(65535 - ((65535 - ConvToUnSignedValue(OriginalRamp.green(i))) * (100 - intGreen) / 100))
            If intBlue < 0 Then GammaRamp.blue(i) = ConvToSignedValue(ConvToUnSignedValue(OriginalRamp.blue(i)) * (100 - Abs(intBlue)) / 100)
            If intBlue = 0 Then GammaRamp.blue(i) = OriginalRamp.blue(i)
            If intBlue > 0 Then GammaRamp.blue(i) = ConvToSignedValue(65535 - ((65535 - ConvToUnSignedValue(OriginalRamp.blue(i))) * (100 - intBlue) / 100))
            i = i + 1
            If i > 255 Then Exit Do
        Loop
        GammaControler.SetGammaRamp DDSGR_DEFAULT, GammaRamp
   End If
        Exit Sub
GamOut:
End Sub



Private Function ConvToSignedValue(lngValue As Long) As Integer
'This was written by the same person who did the "Gamma_UpdateGamma" code
    If lngValue <= 32767 Then
        ConvToSignedValue = CInt(lngValue)
        Exit Function
    End If
    ConvToSignedValue = CInt(lngValue - 65535)
End Function
Private Function ConvToUnSignedValue(intValue As Integer) As Long
'This was written by the same person who did the "Gamma_UpdateGamma" code
    If intValue >= 0 Then
        ConvToUnSignedValue = intValue
        Exit Function
    End If
    ConvToUnSignedValue = intValue + 65535
End Function

nogood

Sub Gamma_CheckForHard() '//*  测试是否支持 伽?刂?Gamma)
    Dim Hard As DDCAPS, Soft As DDCAPS
    Dim lVal As Long
    DD.GetCaps Hard, Soft
    If (Hard.lCaps2 And DDCAPS2_PRIMARYGAMMA) = 0 Then
       GammaSupport = False
    Else
       GammaSupport = True
      Call DxDDraw.Gamma_CreateGamma
    End If
End Sub


Sub Gamma_CreateGamma()
    If gT_Gamma_Run = False Then Exit Sub
    If GammaSupport = False Then Exit Sub
    'If GammaSupport = True Then
       Set GammaControler = Primary.GetDirectDrawGammaControl
       GammaControler.GetGammaRamp DDSGR_DEFAULT, OriginalRamp
    'End If
End Sub

Sub ClearBuffer() '//* 清除底色
    Dim destRect As RECT
    'Set up a rectangle as big as the screen
    With destRect
        .Bottom = gE_formScreen.ScreenHeight 'DisplayHeight
        .Left = 0
        .Right = gE_formScreen.ScreenWidth
        .Top = 0
    End With
    'Fill the backbuffer with black BackBuffer
    BackBuffer.BltColorFill destRect, gL_SystemColorKey 'vbRed 'BGR(255, 0, 0)
End Sub

'//*  ***********************************************************
'//*  *  这个过程是当失去焦点时 ，重新刷新 精灵块 ！！！        *
'//*  ***********************************************************

Sub BLT_Lose(Optional hWnd As Long = 0) '//*  没有字显示的过程
   If hWnd = 0 Then hWnd = gL_mFromHwnd
'//*  Beginning, head, first
    On Local Error GoTo errOutA '//*  this will keep us from trying to blt in case we lose the surfaces (alt-tab)
'//*  这将会使我们不尝试到 blt ，以防万一我们失去表面 (alt-tab键)
    bRestore = False
    Do Until ExModeActive
        'DoEvents
        If GetInputState() Then DoEvents
        bRestore = True
    Loop
    '// if we lost and got back the surfaces, then restore them
    If bRestore Then
        bRestore = False
        DD.RestoreAllSurfaces
        '//这个过程没有写完
        'DxDDraw.LoadSurfaces3D BackGround(1), App.Path & "\001.bmp", False, True

        Dim caps As DDSCAPS2
        caps.lCaps = DDSCAPS_BACKBUFFER
        Set BackBuffer = Primary.GetAttachedSurface(caps)
        'Primary.BltColorFill EmptyRect, 0
        'BackBuffer.BltColorFill EmptyRect, 0
        'BackBuffer.SetForeColor RGB(255, 0, 0)
        'BackBuffer.SetFont g_XFont
        
        If GetInputState() Then DoEvents
        binit = True
        brunning = True
    End If
    Exit Sub
errOutA:
'    If Not (DD Is Nothing) Then
     Call Err_Msg_Log.AT_Error_Run("显示模式 BLT_Lose 无法 进行", Err.Number)
End Sub
'//* 可以让它响应本程序事件动作 , 需要用到api函数GetInputState
'//* 例如用: If GetInputState() Then DoEvents '来代替doevents可使循环运行更快



'//*  *******************************************************
'//*  *  显示 2D 一级 地面 (0层) 无特效 有透明              *
'//*  *                                                     *
'//*  *******************************************************
Sub DisplaySurface_0D1(DDSurface As My_Surface, _
    Optional ByVal iLeft As Integer = 0, Optional ByVal iTop As Integer = 0, _
    Optional ByVal iExsitWidth As Integer, Optional ByVal iExsitHeight As Integer, _
    Optional ByVal iCutLeft As Integer, Optional ByVal iCutTop As Integer)
   Dim srcRect As RECT    '//* Exsit 存在，剩余，剩下 的
   On Error GoTo ErrOut01
        srcRect.Top = iCutTop
        srcRect.Bottom = iExsitHeight
        srcRect.Left = iCutLeft '//*  管偏移地址
        srcRect.Right = iExsitWidth
        BackBuffer.BltFast iLeft, iTop, DDSurface.DDSface7, srcRect, DDBLTFAST_SRCCOLORKEY Or DDBLTFAST_DONOTWAIT 'DDBLTFAST_WAIT
    Exit Sub
ErrOut01:
   Call Err_Msg_Log.AT_Error_Run("DisplaySurface_0D1 调用错误：" & Err.Number, Err.Number)
   Exit Sub
End Sub

'//*  *******************************************************
'//*  *  显示 2D 一级 地面 (0层) 无特效 无透明              *
'//*  *                                                     *
'//*  *******************************************************
Sub DisplaySurface_0D0(DDSurface As My_Surface, _
    Optional ByVal iLeft As Integer = 0, Optional ByVal iTop As Integer = 0, _
    Optional ByVal iExsitWidth As Integer, Optional ByVal iExsitHeight As Integer, _
    Optional ByVal iCutLeft As Integer, Optional ByVal iCutTop As Integer)
    '//* Exsit 存在，剩余，剩下 的
    Dim srcRect As RECT
   On Error GoTo ErrOut00
'//* If this is a D3D surface (These surfaces need to be square, power of 2 sized)
        srcRect.Top = iCutTop
        srcRect.Bottom = iExsitHeight
        srcRect.Left = iCutLeft '//*  管偏移地址
        srcRect.Right = iExsitWidth
        BackBuffer.BltFast iLeft, iTop, DDSurface.DDSface7, srcRect, DDBLTFAST_DONOTWAIT ' DDBLTFAST_WAIT
    Exit Sub
ErrOut00:
   Call Err_Msg_Log.AT_Error_Run("DisplaySurface_0D0 调用错误：" & Err.Number, Err.Number)
   Exit Sub
End Sub





'//*  *******************************************************
'//*  *  显示 2D 一级 地面 (0层) 无特效  可自动裁减         *
'//*  *           Revise(修正)  区域修正                    *
'//*  *******************************************************
Sub DisplaySurface_1D0(DDSurface As My_Surface, _
       Optional ByVal iLeft As Integer = 0, Optional ByVal iTop As Integer = 0, _
       Optional ByVal iExsitWidth As Integer, Optional ByVal iExsitHeight As Integer, _
       Optional ByVal iCutLeft As Integer, Optional ByVal iCutTop As Integer)

'//*  ************************************************************
    If DDSurface.iWidth + iLeft < gE_ScreenRevise_A.scrLeft Then Exit Sub '//*  大了不调用 (应该是<=0)
    If iLeft > gE_ScreenRevise_A.scrRight Then Exit Sub
    If iTop > gE_ScreenRevise_A.scrHeight Then Exit Sub
    If DDSurface.iHeight + iTop < gE_ScreenRevise_A.scrTop Then Exit Sub '//*  (应该是<=0)

        On Error GoTo ErrOut10
'//*  No scaling info. is given, so assume source and dest. sizes are equal
        If iExsitWidth = 0 Then iExsitWidth = DDSurface.iWidth
        If iExsitHeight = 0 Then iExsitHeight = DDSurface.iHeight
    Dim srcRect As RECT
'//* If this is a D3D surface (These surfaces need to be square, power of 2 sized)
          If iTop > 0 Then
             srcRect.Top = iCutTop: srcRect.Bottom = iExsitHeight
             If (iExsitHeight + iTop > gE_ScreenRevise_A.scrHeight) Then srcRect.Bottom = (gE_ScreenRevise_A.scrHeight - iTop)
             'If (iTop + iExsitHeight) > gE_formScreen.ScreenHeight Then SrcRect.Bottom = (gE_formScreen.ScreenHeight - iTop)
          ElseIf iTop < 0 Then
             srcRect.Top = Abs(iTop): srcRect.Bottom = iExsitHeight ' - Abs(Top)  '(SrcHeight - (DisplayHeight - Top))
             iTop = 0
          ElseIf iTop = 0 Then
              srcRect.Top = iCutTop: srcRect.Bottom = iExsitHeight
              If iExsitHeight + iTop > gE_ScreenRevise_A.scrHeight Then srcRect.Bottom = gE_ScreenRevise_A.scrHeight - iTop
              'If iExsitHeight + iTop > gE_formScreen.ScreenHeight Then SrcRect.Bottom = gE_formScreen.ScreenHeight - iTop
          End If
          If iLeft > 0 Then
            srcRect.Left = iCutLeft '//*  管偏移地址
            If iExsitWidth + iLeft > gE_formScreen.ScreenWidth Then
               srcRect.Right = iExsitWidth - (iExsitWidth - (gE_formScreen.ScreenWidth - iLeft))
            Else
               srcRect.Right = iExsitWidth
            End If
          ElseIf iLeft < 0 Then
                srcRect.Left = Abs(iLeft)
                srcRect.Right = iExsitWidth: iLeft = 0
          Else
             srcRect.Left = iCutLeft
             srcRect.Right = iExsitWidth '//*  管 宽度  裁去 右边多少
          End If
           'BackBuffer.Blt DestRect, DDSurface.iSurface, SrcRect, DDBLT_KEYSRC Or DDBLT_WAIT
            BackBuffer.BltFast iLeft, iTop, DDSurface.DDSface7, srcRect, DDBLTFAST_DONOTWAIT ' DDBLTFAST_WAIT
           'BackBuffer.Blt RecB, DDSurface.iSurface, RecB, DDBLT_WAIT '//*  效果可能一样
    Exit Sub
ErrOut10:
   Call Err_Msg_Log.AT_Error_Run("DisplaySurface_1D0 调用错误：" & Err.Number, Err.Number)
   Exit Sub
End Sub

nogood

'//*  ************************************************************************
'//*  *  (iWidthZoom)只管缩放宽,(iHeightZoom)只管缩放高) , False,            *
'//*  *  32,(显示一部分) 64,裁减 X 坐标 ,裁减 Y 坐标, (iWidthZoom)缩放宽,    *
'//*  *  iLeft 相当于 X    iTop 相当于 Y                                     *
'//*  *  在用放大时 要 把 iExsitWidth - 1,iExsitHeight - 1                   *
'//*  *  iExsitWidth  精灵图显示的宽度，iExsitHeight 精灵图显示的高度        *
'//*  *  nAngle 为旋转角度                                                   *
'//*  *  iCutLeft 从左裁减值 ,iCutTop 从上裁减值                             *
'//*  ************************************************************************
Sub DisplaySurface_2D0(DDSurface As My_Surface, _
    Optional ByVal iLeft As Integer, Optional ByVal iTop As Integer, _
    Optional ByVal iExsitWidth As Integer, Optional ByVal iExsitHeight As Integer, _
    Optional ByVal iCutLeft As Single, Optional ByVal iCutTop As Single, _
    Optional ByVal iWidthZoom As Integer, Optional ByVal iHeightZoom As Integer, _
    Optional ByVal tABOne As Byte, Optional ByVal nAlpha As Single = 1, _
    Optional ByVal nRed As Single = 1, Optional ByVal nGreen As Single = 1, Optional ByVal nBlue As Single = 1, _
    Optional ByVal nAngle As Single = 0) 'Angle 角度
'//*  nAlpha 取值范围 (0、0.1 至 1)  值 1 和 1000 好相一样，(0.0 和 0.001 一样)

'//*  ************************  Revise_0 (修改) 区域修正  *********************
    If DDSurface.iWidth + iLeft < gE_ScreenRevise_A.scrLeft Then Exit Sub '//*  大了不调用 (应该是<=0)
    If iLeft > gE_ScreenRevise_A.scrRight Then Exit Sub
    If iTop > gE_ScreenRevise_A.scrHeight Then Exit Sub
    If DDSurface.iHeight + iTop < gE_ScreenRevise_A.scrTop Then Exit Sub '//*  (应该是<=0)

    On Error GoTo ErrOut20
'//*  No scaling info. is given, so assume source and dest. sizes are equal
        If iExsitWidth = 0 Then iExsitWidth = DDSurface.iWidth
        If iExsitHeight = 0 Then iExsitHeight = DDSurface.iHeight
        If iWidthZoom = 0 Then iWidthZoom = iExsitWidth
        If iHeightZoom = 0 Then iHeightZoom = iExsitHeight
'//* If this is a D3D surface (These surfaces need to be square, power of 2 sized)
    Dim srcRect As RECT
    Dim destRect As RECT
    Dim TempVerts(3) As D3DTLVERTEX
'//*  建立目的站长方形
'       If HeightZoom > SrcHeight Then SrcHeight = SrcHeight - 1
'       If WidthZoom > SrcWidth Then SrcWidth = SrcWidth - 1
        With srcRect
            .Left = iCutLeft
            .Top = iCutTop
            .Right = iCutLeft + iExsitWidth '
            .Bottom = iCutTop + iExsitHeight '//*  原来的
        End With
'//*  建立源长方形
        With destRect
            .Left = iLeft
            .Top = iTop
            .Bottom = iTop + iHeightZoom '
            .Right = iLeft + iWidthZoom '
        End With
'//* Set up the TempVerts(3) vertices
        SetUpGeom TempVerts, DDSurface, srcRect, destRect, nRed, nGreen, nBlue, nAlpha, nAngle
        Dev.SetRenderState D3DRENDERSTATE_ALPHABLENDENABLE, True 'Enable alpha-blending
        '//* Enable color-keying (ColorKey is drawn transparent)
        Dev.SetRenderState D3DRENDERSTATE_COLORKEYENABLE, True
'//* 不明什么意思
        'Dev.SetRenderState D3DRENDERSTATE_COLORKEYBLENDENABLE, True
        If tABOne = True Then        'Use Alpha Blend One alpha blending
            Dev.SetRenderState D3DRENDERSTATE_SRCBLEND, D3DBLEND_ONE
            Dev.SetRenderState D3DRENDERSTATE_DESTBLEND, D3DBLEND_ONE
        Else '//* Alpha blend to a certain fade value (0 - 1)
            Dev.SetRenderState D3DRENDERSTATE_SRCBLEND, D3DBLEND_SRCALPHA
            Dev.SetRenderState D3DRENDERSTATE_DESTBLEND, D3DBLEND_INVSRCALPHA
            Dev.SetRenderState D3DRENDERSTATE_TEXTUREFACTOR, dx.CreateColorRGBA(1, 1, 1, nAlpha)
            Dev.SetTextureStageState 0, D3DTSS_ALPHAOP, D3DTOP_MODULATE 'D3DTA_TFACTOR
        End If        '//* Set the texture on the D3D device
        Dev.SetTexture 0, DDSurface.DDSface7
'         Dev.SetTextureStageState 0, D3D_TEXTURESTAGE_STATETYPE, 3 '//*  D3DTSS_MIPFILTER  '//*  基于 DrawPrimitive 的渲染功能
        Dev.DrawPrimitive D3DPT_TRIANGLESTRIP, D3DFVF_TLVERTEX, TempVerts(0), 4, D3DDP_DEFAULT Or D3DDP_WAIT
        Dev.SetRenderState D3DRENDERSTATE_ALPHABLENDENABLE, False
        Dev.SetTexture 0, Nothing
    Exit Sub
ErrOut20:
   Call Err_Msg_Log.AT_Error_Run("DisplaySurface_2D0 调用错误：" & Err.Number, Err.Number)
   Exit Sub
End Sub

'//*  ************************************************************************
'//*  *  (iWidthZoom)只管缩放宽,(iHeightZoom)只管缩放高) , False,            *
'//*  *  32,(显示一部分) 64,裁减 X 坐标 ,裁减 Y 坐标, (iWidthZoom)缩放宽,    *
'//*  *  iLeft 相当于 X    iTop 相当于 Y                                     *
'//*  *  在用放大时 要 把 iExsitWidth - 1,iExsitHeight - 1                   *
'//*  *  iExsitWidth  精灵图显示的宽度，iExsitHeight 精灵图显示的高度        *
'//*  *  nAngle 为旋转角度                                                   *
'//*  *  iCutLeft 从左裁减值 ,iCutTop 从上裁减值                             *
'//*  *                Revise(修改)  区域修正 (小于 Revise_0 )               *
'//*  ************************************************************************
Sub DisplaySurface_2D1(DDSurface As My_Surface, _
    Optional ByVal iLeft As Integer, Optional ByVal iTop As Integer, _
    Optional ByVal iExsitWidth As Integer, Optional ByVal iExsitHeight As Integer, _
    Optional ByVal iCutLeft As Single, Optional ByVal iCutTop As Single, _
    Optional ByVal iWidthZoom As Integer, Optional ByVal iHeightZoom As Integer, _
    Optional ByVal tABOne As Byte, Optional ByVal nAlpha As Single = 1, _
    Optional ByVal nRed As Single = 1, Optional ByVal nGreen As Single = 1, Optional ByVal nBlue As Single = 1, _
    Optional ByVal nAngle As Single = 0) 'Angle 角度
'//*  nAlpha 取值范围 (0、0.1 至 1)  值 1 和 1000 好相一样，(0.0 和 0.001 一样)

'//*  ************************  Revise(修改)  区域修正  *********************
    If DDSurface.iWidth + iLeft < gE_ScreenRevise_B.scrLeft Then Exit Sub '//*  大了不调用 (应该是<=30)
    If iLeft > gE_ScreenRevise_B.scrRight Then Exit Sub
    If iTop > gE_ScreenRevise_B.scrHeight Then Exit Sub
    If DDSurface.iHeight + iTop < gE_ScreenRevise_B.scrTop Then Exit Sub '//*  (应该是<=30)

    On Error GoTo ErrOut21
'//*  No scaling info. is given, so assume source and dest. sizes are equal
        If iExsitWidth = 0 Then iExsitWidth = DDSurface.iWidth
        If iExsitHeight = 0 Then iExsitHeight = DDSurface.iHeight
        If iWidthZoom = 0 Then iWidthZoom = iExsitWidth
        If iHeightZoom = 0 Then iHeightZoom = iExsitHeight
'//* If this is a D3D surface (These surfaces need to be square, power of 2 sized)
    Dim srcRect As RECT
    Dim destRect As RECT
    Dim TempVerts(3) As D3DTLVERTEX
'//*  建立目的站长方形
'       If HeightZoom > SrcHeight Then SrcHeight = SrcHeight - 1
'       If WidthZoom > SrcWidth Then SrcWidth = SrcWidth - 1
        With srcRect
            .Left = iCutLeft
            .Top = iCutTop
            .Right = iCutLeft + iExsitWidth '
            .Bottom = iCutTop + iExsitHeight '//*  原来的
        End With
'//*  建立源长方形
        With destRect
            .Left = iLeft
            .Top = iTop
            .Bottom = iTop + iHeightZoom '
            .Right = iLeft + iWidthZoom '
        End With
'//* Set up the TempVerts(3) vertices
        SetUpGeom TempVerts, DDSurface, srcRect, destRect, nRed, nGreen, nBlue, nAlpha, nAngle
        Dev.SetRenderState D3DRENDERSTATE_ALPHABLENDENABLE, True 'Enable alpha-blending
        Dev.SetRenderState D3DRENDERSTATE_COLORKEYENABLE, True
        'Dev.SetRenderState D3DRENDERSTATE_COLORKEYBLENDENABLE, True
        If tABOne = True Then
            Dev.SetRenderState D3DRENDERSTATE_SRCBLEND, D3DBLEND_ONE
            Dev.SetRenderState D3DRENDERSTATE_DESTBLEND, D3DBLEND_ONE
        Else '//* Alpha blend to a certain fade value (0 - 1)
            Dev.SetRenderState D3DRENDERSTATE_SRCBLEND, D3DBLEND_SRCALPHA
            Dev.SetRenderState D3DRENDERSTATE_DESTBLEND, D3DBLEND_INVSRCALPHA
            Dev.SetRenderState D3DRENDERSTATE_TEXTUREFACTOR, dx.CreateColorRGBA(1, 1, 1, nAlpha)
            Dev.SetTextureStageState 0, D3DTSS_ALPHAOP, D3DTOP_MODULATE 'D3DTA_TFACTOR
        End If        '//* Set the texture on the D3D device
        Dev.SetTexture 0, DDSurface.DDSface7
'         Dev.SetTextureStageState 0, D3D_TEXTURESTAGE_STATETYPE, 3 '//*  D3DTSS_MIPFILTER  '//*  基于 DrawPrimitive 的渲染功能
        Dev.DrawPrimitive D3DPT_TRIANGLESTRIP, D3DFVF_TLVERTEX, TempVerts(0), 4, D3DDP_DEFAULT Or D3DDP_WAIT
        Dev.SetRenderState D3DRENDERSTATE_ALPHABLENDENABLE, False
        Dev.SetTexture 0, Nothing
    Exit Sub
ErrOut21:
   Call Err_Msg_Log.AT_Error_Run("DisplaySurface_2D1 调用错误：" & Err.Number, Err.Number)
   Exit Sub
End Sub

nogood

'//*  *******************************************************
'//*  *  显示 2D 一级 地面 (0层) 无特效  可自动裁减         *
'//*  *               二次屏幕显示修正   可透明             *
'//*  *******************************************************
Sub DisplaySurface_1D1(DDSurface As My_Surface, _
       Optional ByVal iLeft As Integer = 0, Optional ByVal iTop As Integer = 0, _
       Optional ByVal iExsitWidth As Integer, Optional ByVal iExsitHeight As Integer, _
       Optional ByVal iCutLeft As Integer, Optional ByVal iCutTop As Integer)
'//*  ************************************************************
    If DDSurface.iWidth + iLeft < gE_ScreenRevise_A.scrLeft Then Exit Sub '//*  大了不调用 (应该是<=0)
    If iLeft > gE_ScreenRevise_A.scrRight Then Exit Sub
    If iTop > gE_ScreenRevise_A.scrHeight Then Exit Sub
    If DDSurface.iHeight + iTop < gE_ScreenRevise_A.scrTop Then Exit Sub '//*  (应该是<=0)
      On Error GoTo ErrOut11
'//*  No scaling info. is given, so assume source and dest. sizes are equal
        If iExsitWidth = 0 Then iExsitWidth = DDSurface.iWidth
        If iExsitHeight = 0 Then iExsitHeight = DDSurface.iHeight
    Dim srcRect As RECT
'//* If this is a D3D surface (These surfaces need to be square, power of 2 sized)
          If iTop > 0 Then
             srcRect.Top = iCutTop: srcRect.Bottom = iExsitHeight
             If (iExsitHeight + iTop > gE_ScreenRevise_A.scrHeight) Then srcRect.Bottom = (gE_ScreenRevise_A.scrHeight - iTop)
             'If (iTop + iExsitHeight) > gE_formScreen.ScreenHeight Then SrcRect.Bottom = (gE_formScreen.ScreenHeight - iTop)
          ElseIf iTop < 0 Then
             srcRect.Top = Abs(iTop): srcRect.Bottom = iExsitHeight ' - Abs(Top)  '(SrcHeight - (DisplayHeight - Top))
             iTop = 0
          ElseIf iTop = 0 Then
              srcRect.Top = iCutTop: srcRect.Bottom = iExsitHeight
              If iExsitHeight + iTop > gE_ScreenRevise_A.scrHeight Then srcRect.Bottom = gE_ScreenRevise_A.scrHeight - iTop
              'If iExsitHeight + iTop > gE_formScreen.ScreenHeight Then SrcRect.Bottom = gE_formScreen.ScreenHeight - iTop
          End If
          If iLeft > 0 Then
            srcRect.Left = iCutLeft '//*  管偏移地址
            If iExsitWidth + iLeft > gE_formScreen.ScreenWidth Then
               srcRect.Right = iExsitWidth - (iExsitWidth - (gE_formScreen.ScreenWidth - iLeft))
            Else
               srcRect.Right = iExsitWidth
            End If
          ElseIf iLeft < 0 Then
                srcRect.Left = Abs(iLeft)
                srcRect.Right = iExsitWidth: iLeft = 0
          Else
             srcRect.Left = iCutLeft
             srcRect.Right = iExsitWidth '//*  管 宽度  裁去 右边多少
          End If
          BackBuffer.BltFast iLeft, iTop, DDSurface.DDSface7, srcRect, DDBLTFAST_SRCCOLORKEY Or DDBLTFAST_DONOTWAIT 'DDBLTFAST_WAIT
    Exit Sub '//*  这个是可用透明的
ErrOut11:
   Call Err_Msg_Log.AT_Error_Run("DisplaySurface_1D1 调用错误：" & Err.Number, Err.Number)
   Exit Sub
End Sub






'//*  ************************************************************************
'//*  *  (iWidthZoom)只管缩放宽,(iHeightZoom)只管缩放高) , False,            *
'//*  *  32,(显示一部分) 64,裁减 X 坐标 ,裁减 Y 坐标, (iWidthZoom)缩放宽,    *
'//*  *  nLeft 相当于 X    nTop 相当于 Y                                     *
'//*  *  在用放大时 要 把 iSrcWidth - 1,iSrcHeight - 1                       *
'//*  *  iSrcWidth  精灵图显示的宽度，iSrcHeight 精灵图显示的高度            *
'//*  *  nAngle 为旋转角度                                                   *
'//*  *  nOffsetX 左右偏移值 ,nOffsetY 上下偏移值                            *
'//*  ************************************************************************
Sub 显示表面原型DisplaySurface4(DDSurface As My_Surface, _
    Optional ByVal nLeft As Single, Optional ByVal nTop As Single, _
    Optional ByVal iSrcWidth As Integer, Optional ByVal iSrcHeight As Integer, _
    Optional ByVal nOffsetX As Single, Optional ByVal nOffsetY As Single, _
    Optional ByVal iWidthZoom As Integer, Optional ByVal iHeightZoom As Integer, _
    Optional ByVal tABOne As Boolean, Optional ByVal nAlpha As Single = 1, _
    Optional ByVal nRed As Single = 1, Optional ByVal nGreen As Single = 1, Optional ByVal nBlue As Single = 1, _
    Optional ByVal nAngle As Single = 0) 'Angle 角度
'//*  ************************************************************
    If DDSurface.iWidth + nLeft <= 4 Then Exit Sub '//*  大了不调用 (应该是<=0)
    If nLeft >= gE_formScreen.ScreenWidth Then Exit Sub
    If (nTop >= gE_formScreen.DisplayHeight) Then
        ''If (DDSurface.iBGround = False) Then Exit Sub
        Exit Sub
    End If
    'If Top >= gE_formScreen.DisplayHeight Then Exit Sub
    If DDSurface.iHeight + nTop <= 4 Then Exit Sub '//*  (应该是<=0)

        On Error GoTo ErrOut3
'//*  No scaling info. is given, so assume source and dest. sizes are equal
        If iSrcWidth = 0 Then iSrcWidth = DDSurface.iWidth
        If iSrcHeight = 0 Then iSrcHeight = DDSurface.iHeight
        If iWidthZoom = 0 Then iWidthZoom = iSrcWidth
        If iHeightZoom = 0 Then iHeightZoom = iSrcHeight
    Dim srcRect As RECT
'//* If this is a D3D surface (These surfaces need to be square, power of 2 sized)
    If DDSurface.D3d = True Then
        Dim destRect As RECT
        Dim TempVerts(3) As D3DTLVERTEX
'//*  建立目的站长方形
'       If HeightZoom > SrcHeight Then SrcHeight = SrcHeight - 1
'       If WidthZoom > SrcWidth Then SrcWidth = SrcWidth - 1
        With srcRect
            .Left = nOffsetX
            .Top = nOffsetY
            .Right = nOffsetX + iSrcWidth '
            .Bottom = nOffsetY + iSrcHeight '//*  原来的
        End With
'//*  建立源长方形
        With destRect
            .Left = nLeft
            .Top = nTop
            .Bottom = nTop + iHeightZoom '
            .Right = nLeft + iWidthZoom '
        End With
        'Set up the TempVerts(3) vertices
        SetUpGeom TempVerts, DDSurface, srcRect, destRect, nRed, nGreen, nBlue, nAlpha, nAngle
        Dev.SetRenderState D3DRENDERSTATE_ALPHABLENDENABLE, True 'Enable alpha-blending
        '//* Enable color-keying (ColorKey is drawn transparent)
        Dev.SetRenderState D3DRENDERSTATE_COLORKEYENABLE, True
'//* 不明什么意思
        'Dev.SetRenderState D3DRENDERSTATE_COLORKEYBLENDENABLE, True
        If tABOne = True Then        'Use Alpha Blend One alpha blending
            Dev.SetRenderState D3DRENDERSTATE_SRCBLEND, D3DBLEND_ONE
            Dev.SetRenderState D3DRENDERSTATE_DESTBLEND, D3DBLEND_ONE
        Else 'Alpha blend to a certain fade value (0 - 1)
            Dev.SetRenderState D3DRENDERSTATE_SRCBLEND, D3DBLEND_SRCALPHA
            Dev.SetRenderState D3DRENDERSTATE_DESTBLEND, D3DBLEND_INVSRCALPHA
            Dev.SetRenderState D3DRENDERSTATE_TEXTUREFACTOR, dx.CreateColorRGBA(1, 1, 1, nAlpha)
            Dev.SetTextureStageState 0, D3DTSS_ALPHAOP, D3DTOP_MODULATE 'D3DTA_TFACTOR
        End If        'Set the texture on the D3D device

        Dev.SetTexture 0, DDSurface.DDSface7
'         Dev.SetTextureStageState 0, D3D_TEXTURESTAGE_STATETYPE, 3 '//*  D3DTSS_MIPFILTER  '//*  基于 DrawPrimitive 的渲染功能
        Dev.DrawPrimitive D3DPT_TRIANGLESTRIP, D3DFVF_TLVERTEX, TempVerts(0), 4, D3DDP_DEFAULT Or D3DDP_WAIT
        Dev.SetRenderState D3DRENDERSTATE_ALPHABLENDENABLE, False
        Dev.SetTexture 0, Nothing
    Else '//*  不是 Ｄ３Ｄ　的精灵
          If nTop > 0 Then
             srcRect.Top = nOffsetY: srcRect.Bottom = iSrcHeight
             If (iSrcHeight + nTop > gE_formScreen.DisplayHeight) Then
                If (DDSurface.D3d = False) Then '//*原为是否是地面，因编译改为 D3d
                   srcRect.Bottom = iSrcHeight - (iSrcHeight - (gE_formScreen.DisplayHeight - nTop))
                Else
                   If (nTop + iSrcHeight) > gE_formScreen.ScreenHeight Then srcRect.Bottom = (gE_formScreen.ScreenHeight - nTop) 'SrcHeight - ((SrcHeight + Top) - ScreenHeight)
                End If
             End If
          ElseIf nTop < 0 Then
             srcRect.Top = Abs(nTop): srcRect.Bottom = iSrcHeight ' - Abs(Top)  '(SrcHeight - (DisplayHeight - Top))
             nTop = 0
          ElseIf nTop = 0 Then
              srcRect.Top = nOffsetY: srcRect.Bottom = iSrcHeight
             If iSrcHeight + nTop > gE_formScreen.DisplayHeight Then
                If (DDSurface.D3d = False) Then
                    srcRect.Bottom = iSrcHeight - (iSrcHeight - (gE_formScreen.DisplayHeight - nTop))
                Else
                  If iSrcHeight + nTop > gE_formScreen.ScreenHeight Then srcRect.Bottom = gE_formScreen.ScreenHeight - nTop
                End If
             End If
          End If
          If nLeft > 0 Then
            srcRect.Left = nOffsetX '//*  管偏移地址
            If iSrcWidth + nLeft > gE_formScreen.ScreenWidth Then
               srcRect.Right = iSrcWidth - (iSrcWidth - (gE_formScreen.ScreenWidth - nLeft))
            Else
               srcRect.Right = iSrcWidth
            End If
          ElseIf nLeft < 0 Then
                srcRect.Left = Abs(nLeft)
                srcRect.Right = iSrcWidth: nLeft = 0
          Else
             srcRect.Left = nOffsetX
             srcRect.Right = iSrcWidth '//*  管 宽度  裁去 右边多少
          End If
        'Blt the surface normally, without D3D features (these surfaces can be any size)
           'BackBuffer.Blt DestRect, DDSurface.iSurface, SrcRect, DDBLT_KEYSRC Or DDBLT_WAIT
        If DDSurface.BitMask = True Then '//*  透明使用
           BackBuffer.BltFast nLeft, nTop, DDSurface.DDSface7, srcRect, DDBLTFAST_SRCCOLORKEY Or DDBLTFAST_DONOTWAIT 'DDBLTFAST_WAIT
        Else
            BackBuffer.BltFast nLeft, nTop, DDSurface.DDSface7, srcRect, DDBLTFAST_DONOTWAIT ' DDBLTFAST_WAIT
           'BackBuffer.Blt RecB, DDSurface.iSurface, RecB, DDBLT_WAIT '//*  效果可能一样
        End If
    End If
    Exit Sub
ErrOut3:
   Call Err_Msg_Log.AT_Error_Run("DisplaySurface 调用错误：" & Err.Number, Err.Number)
   Exit Sub
End Sub

nogood

'//* *****************************************************************
'//* *  读取图形文件过程                                             *
'//* *  BGround = 为不是地面不可移出区、是地面不可移出区、           *
'//* *  PicWidth,PicHeight  可以起放大、缩小 作用                    *
'//* *  Transparent 为是否 透明                                      *
'//* *****************************************************************
Sub 创建表面原型CreateTextureSurface4(ByRef DDSurface As My_Surface, _
    ByVal BmpFile As String, _
    ByVal PicWidth As Integer, ByVal PicHeight As Integer, _
    Optional ByVal D3DSprite As Boolean, Optional ByVal B_Ground As Boolean, _
    Optional ByVal nMask As Boolean = True, _
    Optional ByVal ColourKey As Integer = gL_ColorKey)
   
   Dim DDSD1 As DDSURFACEDESC2  '//*  最初的表面 (荧屏)
   
   On Error GoTo ErrOutSurface
    '//*  If this is a D3D surface (for alpha blending, etc.), set it up accordingly
       Set DDSurface.DDSface7 = Nothing
           DDSurface.BitMask = nMask
    If D3DSprite = True Then '//*  加载 精灵 为 3D 模式
        Call Err_Msg_Log.AppendToLog("加载 精灵 为 3D 模式 ...", True, True)
'//*  --------------------------------------------------------------------------
      DDSD1.lFlags = DDSD_CAPS Or DDSD_TEXTURESTAGE Or DDSD_PIXELFORMAT
      If ((PicHeight <> 0) And (PicWidth <> 0)) Then
         DDSD1.lFlags = DDSD_CAPS Or DDSD_WIDTH Or DDSD_HEIGHT Or DDSD_CKSRCBLT
         DDSD1.lHeight = PicHeight
         DDSD1.lWidth = PicWidth
      End If
'//*  --------------------------------------------------------------------------
        'Call Err_Msg_Log.AppendToLog("set some texture surface flags", True, True)
'//*  set some texture surface flags
        If Dev.GetDeviceGuid() = "IID_IDirect3DHALDevice" Then
                DDSD1.ddsCaps.lCaps = DDSCAPS_TEXTURE Or DDSCAPS_3DDEVICE
                DDSD1.ddsCaps.lCaps2 = DDSCAPS2_TEXTUREMANAGE
                DDSD1.lTextureStage = 0
        ElseIf Dev.GetDeviceGuid() = "IID_IDirect3DRGBDevice" Then
        '//*  如果不能用硬件 HAL 就用软件 RGB
                DDSD1.ddsCaps.lCaps = DDSCAPS_TEXTURE
                DDSD1.ddsCaps.lCaps2 = 0
                DDSD1.lTextureStage = 0
        Else
            Call Err_Msg_Log.AT_Error_Run("Could not create a Direct3D device.", Err.Number)
            Exit Sub
        End If
        Call Err_Msg_Log.AppendToLog("DX显示模式... " & Dev.GetDeviceGuid(), True, True)
        If nMask = True Then
           DDSD1.ddckCKSrcBlt.high = ColourKey        '//*  设置 图象遮蔽色
           DDSD1.ddckCKSrcBlt.low = ColourKey 'ColorKey
           Call Err_Msg_Log.AppendToLog("设置 图象遮蔽色 ... " & ColourKey, True, True)
        Else '//*  不用透明
           DDSD1.ddckCKSrcBlt.high = &HF81F 'ColorKey
           DDSD1.ddckCKSrcBlt.low = &HF81F
        End If
        Call Err_Msg_Log.AppendToLog("读取精灵图象... " & BmpFile, True, True)
        Set DDSurface.DDSface7 = DD.CreateSurfaceFromFile(BmpFile, DDSD1) 'Create the surface
        'Set the information for this surface
        Call Err_Msg_Log.AppendToLog("加载 3D 模式精灵 ... Ok", True, True)
    Else    '//*  Normal DirectDraw surface
                Call Err_Msg_Log.AppendToLog("加载 精灵 为 Normal DirectDraw surface 模式 ...", True, True)
        DDSD1.lFlags = DDSD_CAPS Or DDSD_WIDTH Or DDSD_HEIGHT
        DDSD1.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN Or DDSCAPS_SYSTEMMEMORY 'DDSCAPS_VIDEOMEMORY
        DDSD1.lHeight = PicHeight
        DDSD1.lWidth = PicWidth
                Call Err_Msg_Log.AppendToLog("读取精灵图象... " & BmpFile, True, True)
        Set DDSurface.DDSface7 = DD.CreateSurfaceFromFile(BmpFile, DDSD1)
        ''DD.GetGDISurface
'//*  设置 图象遮蔽色

         If nMask = True Then '//*  透明
            Dim CKey As DDCOLORKEY
            CKey.low = ColourKey '16Bit 的粉红为 &HF81F
            CKey.high = ColourKey 'ColorKey
            DDSurface.DDSface7.SetColorKey DDCKEY_SRCBLT, CKey
                      Call Err_Msg_Log.AppendToLog("设置 图象遮蔽色 ... " & ColourKey, True, True)
         Else              'Set the information for this surface
              DDSurface.DDSface7.SetForeColor vbBlack 'SystemColorKey
              Call Err_Msg_Log.AppendToLog("加载 Normal DirectDraw surface 模式精灵 ... Ok", True, True)
        End If
    End If
'//*  结尾的公共过程
         Call Err_Msg_Log.AppendToLog("精灵图象大小为 ... " & DDSD1.lWidth & " " & DDSD1.lHeight, True, True)
        DDSurface.iWidth = PicWidth
        DDSurface.iHeight = PicHeight
        'DDSD1 = SurfaceDescZero '//*  初始化 DDSD1
     Exit Sub
ErrOutSurface:
    Call Err_Msg_Log.AT_Error_Run("LoadSurfaces3D 错误，无法加载 ", Err.Number)
    Exit Sub
End Sub



'//* *********************************************************************
'//* *         设计为 地面一级的精灵层 (0层)  2D模式                     *
'//* *    主要是一些无特效的地面等                                       *
'//* *    主要是地面的，可用系统内存                                     *
'//* *********************************************************************
Sub CreateTextureSurface_1D(ByRef DDSurface As My_Surface, ByVal BmpFileName As String, _
            Optional ByVal PicWidth As Integer, Optional ByVal PicHeight As Integer, _
            Optional ByVal nMask As Boolean = False, _
            Optional ByVal ColourKey As Integer = gL_ColorKey) '//* mask 遮蔽 Transparent 透明
   
   Dim ddsd As DDSURFACEDESC2
   'Dim DDSD3 As DDSURFACEDESC2

    On Error GoTo ErrOutSurface0   '//* 设计为 地面一级的精灵层 (0层)
        Call Err_Msg_Log.AppendToLog("加载 Normal DirectDraw surface 模式 ...", True, True)
        
      ddsd.lFlags = DDSD_CAPS Or DDSD_WIDTH Or DDSD_HEIGHT Or DDSD_CKSRCBLT
      ddsd.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN Or DDSCAPS_SYSTEMMEMORY 'DDSCAPS_VIDEOMEMORY '//* 用系统内存
      ''If ((PicHeight <> 0) And (PicWidth <> 0)) Then
'         ddsd.lHeight = PicHeight
'         ddsd.lWidth = PicWidth
      ''End If
'//* **********************************************************************************
        Set DDSurface.DDSface7 = DD.CreateSurfaceFromFile(BmpFileName, ddsd)
        If nMask = True Then '// 图象遮蔽 为真
            Dim CKey As DDCOLORKEY '//*  设置 图象遮蔽色
            CKey.low = ColourKey '16Bit 的粉红为 &HF81F
            CKey.high = ColourKey 'ColorKey
            DDSurface.DDSface7.SetColorKey DDCKEY_SRCBLT, CKey
        Else '//*  不用遮蔽透明
              DDSurface.DDSface7.SetForeColor vbBlack 'SystemColorKey
        End If '
'//*  结尾的公共过程
        DDSurface.iHeight = ddsd.lHeight
        DDSurface.iWidth = ddsd.lWidth
        DDSurface.BitMask = nMask
        Call Err_Msg_Log.AppendToLog("读取精灵图象 " & BmpFileName & " 大小为 ." & ddsd.lWidth & " " & ddsd.lHeight, True, True)
     Exit Sub
ErrOutSurface0:
    Call Err_Msg_Log.AT_Error_Run("TextureSurface0 错误，" & BmpFileName & " 无法加载 ", Err.Number)
    Exit Sub
End Sub '//*  这个过程已经可以用了的 2004-08-03

'//* *********************************************************************
'//* *         设计为 地面二级的精灵层 (1层)  伪3D模式                   *
'//* *    这个过程是为了有一些特效的 如透明等                            *
'//* *********************************************************************
Sub CreateTextureSurface_2D(ByRef DDSurface As My_Surface, ByVal BmpFileName As String, _
            Optional ByVal PicWidth As Integer, Optional ByVal PicHeight As Integer, _
            Optional ByVal nMask As Boolean = True, _
            Optional ByVal ColourKey As Integer = gL_ColorKey) '//* mask 遮蔽 Transparent 透明
   
   Dim DDSD1 As DDSURFACEDESC2 '//* 设计为 地面二级的精灵层 (1层)
    On Error GoTo ErrOutSurface1
       'Set DDSurface.dSurface = Nothing
        Call Err_Msg_Log.AppendToLog("加载 伪3D 模式 ...", True, True)
'//*  -- ddsd.lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH Or DDSD_PIXELFORMAT
      If ((PicHeight <> 0) And (PicWidth <> 0)) Then '//*  以上代码正常
         DDSD1.lFlags = DDSD_CAPS Or DDSD_WIDTH Or DDSD_HEIGHT Or DDSD_CKSRCBLT ' Or DDSD_PIXELFORMAT
         DDSD1.lHeight = PicHeight
         DDSD1.lWidth = PicWidth
      Else
          DDSD1.lFlags = DDSD_CAPS Or DDSD_TEXTURESTAGE ' Or DDSD_PIXELFORMAT
      End If
'//*  设定一些材质表面旗标 set some texture surface flags
        If Dev.GetDeviceGuid() = "IID_IDirect3DHALDevice" Then
                DDSD1.ddsCaps.lCaps = DDSCAPS_TEXTURE Or DDSCAPS_3DDEVICE
                DDSD1.ddsCaps.lCaps2 = DDSCAPS2_TEXTUREMANAGE
                DDSD1.lTextureStage = 0
        ElseIf Dev.GetDeviceGuid() = "IID_IDirect3DRGBDevice" Then
               '//* 如果不能用硬件 HAL 就用软件 RGB
                DDSD1.ddsCaps.lCaps = DDSCAPS_TEXTURE Or DDSCAPS_SYSTEMMEMORY
                DDSD1.ddsCaps.lCaps2 = 0
                DDSD1.lTextureStage = 0
        Else
        '//*  如果 软硬 驱动 都不能用就退出！
            Call Err_Msg_Log.AT_Error_Run("Could not create a Direct3D device.", Err.Number)
            Exit Sub
        End If
'//*  -----------------------------------------------------------------------
        Call Err_Msg_Log.AppendToLog("DX显示模式... " & Dev.GetDeviceGuid(), True, True)
        If nMask = True Then '// 图象遮蔽 为真
           DDSD1.ddckCKSrcBlt.high = ColourKey        '//*  设置 图象遮蔽色
           DDSD1.ddckCKSrcBlt.low = ColourKey 'ColorKey
           Call Err_Msg_Log.AppendToLog("设置 图象遮蔽色 ... " & ColourKey, True, True)
        Else '//*  不用遮蔽透明
           DDSD1.ddckCKSrcBlt.high = &HF81F 'ColorKey
           DDSD1.ddckCKSrcBlt.low = &HF81F '//* 为粉红的
        End If
        Set DDSurface.DDSface7 = DD.CreateSurfaceFromFile(BmpFileName, DDSD1) 'Create the surface
'//*  结尾的公共过程
        DDSurface.iHeight = DDSD1.lHeight
        DDSurface.iWidth = DDSD1.lWidth
        DDSurface.BitMask = nMask
         Call Err_Msg_Log.AppendToLog("读取精灵图象 " & BmpFileName & " 大小为 ." & DDSD1.lWidth & " " & DDSD1.lHeight, True, True)
     Exit Sub
ErrOutSurface1:
    Call Err_Msg_Log.AT_Error_Run("TextureSurface1 错误，无法加载 ", Err.Number)
    Exit Sub
End Sub

nogood

'//* *********************************************************************
'//* *         设计为 地面 三级 的精灵层 (2、3层)  伪3D模式              *
'//* *    这个过程是为了有一些特效的 如透明等  渲染                      *
'//* *********************************************************************
Sub CreateTextureSurface3(ByRef DDSurface As My_Surface, ByVal BmpFileName As String, _
            Optional ByVal PicWidth As Integer, Optional ByVal PicHeight As Integer, _
            Optional ByVal nMask As Boolean = True, _
            Optional ByVal ColourKey As Integer = gL_ColorKey)
   
   Dim DDSD1 As DDSURFACEDESC2
   Dim bOK As Boolean
    Dim EnumTex As Direct3DEnumPixelFormats
    Dim sLoadFile As String
    Dim i As Long

    Dim SurfaceObject As DirectDrawSurface7
    Dim Init As Boolean

    On Error GoTo ErrOutSurface3
       'Set DDSurface.dSurface = Nothing
        Call Err_Msg_Log.AppendToLog("加载 伪3D 渲染 模式 ...", True, True)
      DDSD1.lFlags = DDSD_CAPS Or DDSD_TEXTURESTAGE Or DDSD_PIXELFORMAT
      If ((PicHeight <> 0) And (PicWidth <> 0)) Then
         DDSD1.lFlags = DDSD1.lFlags Or DDSD_HEIGHT Or DDSD_WIDTH
         'DDSD1.lFlags = DDSD_CAPS Or DDSD_WIDTH Or DDSD_HEIGHT Or DDSD_CKSRCBLT
         DDSD1.lHeight = PicHeight
         DDSD1.lWidth = PicWidth
      End If
    '//* check if device supports 16bit surfaces
       Set EnumTex = Dev.GetTextureFormatsEnum()
            For i = 1 To EnumTex.GetCount()
                bOK = True
                Call EnumTex.GetItem(i, DDSD1.ddpfPixelFormat)
                With DDSD1.ddpfPixelFormat
                    If .lRGBBitCount <> 16 Then bOK = False
                End With
                If bOK = True Then Exit For
            Next
        
            If bOK = False Then
                Call Err_Msg_Log.AT_Error_Run("Unable to find 16bit surface support on your hardware.", Err.Number)
                Init = False
            End If

'//*  设定一些材质表面旗标 set some texture surface flags
        If Dev.GetDeviceGuid() = "IID_IDirect3DHALDevice" Then
                DDSD1.ddsCaps.lCaps = DDSCAPS_TEXTURE Or DDSCAPS_3DDEVICE
                DDSD1.ddsCaps.lCaps2 = DDSCAPS2_TEXTUREMANAGE
                DDSD1.lTextureStage = 0
        ElseIf Dev.GetDeviceGuid() = "IID_IDirect3DRGBDevice" Then
               '//* 如果不能用硬件 HAL 就用软件 RGB
                DDSD1.ddsCaps.lCaps = DDSCAPS_TEXTURE Or DDSCAPS_SYSTEMMEMORY
                DDSD1.ddsCaps.lCaps2 = 0
                DDSD1.lTextureStage = 0
        Else
        '//*  如果 软硬 驱动 都不能用就退出！
            Call Err_Msg_Log.AT_Error_Run("Could not create a Direct3D device.", Err.Number)
            Exit Sub
        End If
'//*  -----------------------------------------------------------------------
        If BmpFileName = "" Then
            Set DDSurface.DDSface7 = DD.CreateSurface(DDSD1)
        Else
            Set DDSurface.DDSface7 = DD.CreateSurfaceFromFile(BmpFileName, DDSD1)
        End If

        Dim CKey As DDCOLORKEY '//*  设置 图象遮蔽色
        Dim DDPF As DDPIXELFORMAT
        If nMask = True Then '// 图象遮蔽 为真
            CKey.low = ColourKey '16Bit 的粉红为 &HF81F
            CKey.high = ColourKey 'ColorKey
            DDSurface.DDSface7.SetColorKey DDCKEY_SRCBLT, CKey
        Else
            DDSurface.DDSface7.GetPixelFormat DDPF
            CKey.low = DDPF.lBBitMask + DDPF.lRBitMask
            CKey.high = CKey.low
            DDSurface.DDSface7.SetColorKey DDCKEY_SRCBLT, CKey
        End If

'//*  结尾的公共过程
         Call Err_Msg_Log.AppendToLog("读取精灵图象 " & BmpFileName & " 大小为 ." & DDSD1.lWidth & " " & DDSD1.lHeight, True, True)
     Exit Sub
ErrOutSurface3:
    Call Err_Msg_Log.AT_Error_Run("渲染 错误，无法加载 ", Err.Number)
    Exit Sub
End Sub









'//* ***********************************************************************
'//* *  这一个替代人员组在顶点上面为一个子画面,考虑
'//* *  宽度，画面高度,顶涂颜色, 和转动角度
'//* *  注意: 半径， G 和 B 听写 [颜]色子画面将会是 -
'//* *  1,1,1 是正常,较低的数值将会使顶点变成彩色
'//* *  v1      * v3
'//* *  |\        |
'//* *  |  \      |
'//* *  |    \    |
'//* *  |      \  |
'//* *  |        \|
'//* *  * v0      * v2
'//* ***********************************************************************
Sub SetUpGeom(Verts() As D3DTLVERTEX, DDSurface As My_Surface, Src As RECT, Dest As RECT, ByVal R As Single, ByVal G As Single, ByVal B As Single, ByVal A As Single, ByVal Angle As Single)

    Dim SurfW As Single
    Dim SurfH As Single
    Dim XCenter As Single
    Dim YCenter As Single
    Dim Radius As Single
    Dim XCor As Single
    Dim YCor As Single
   'Call Err_Msg_Log.AppendToLog("SetUpGeom 参数设定 ...", True, True)
'//* Width of the surface
    SurfW = DDSurface.iWidth
    '//* Height of the surface
    SurfH = DDSurface.iHeight
    '//* Center coordinates on screen of the sprite
    '//*  置中在子画面的荧屏上的坐标
    XCenter = Dest.Left + (Dest.Right - Dest.Left - 1) / 2
    YCenter = Dest.Top + (Dest.Bottom - Dest.Top - 1) / 2
   
    '//* Calculate screen coordinates of sprite, and only rotate if necessary
    '//*  计算子画面的荧屏坐标, 和如果有需要的话只使旋转
    If Angle = 0 Then
        XCor = Dest.Left
        YCor = Dest.Bottom
    Else
        XCor = XCenter + (Dest.Left - XCenter) * Sin(Angle) + (Dest.Bottom - YCenter) * Cos(Angle)
        YCor = YCenter + (Dest.Bottom - YCenter) * Sin(Angle) - (Dest.Left - XCenter) * Cos(Angle)
    End If
   
    '//* 0 - Bottom left vertex
    dx.CreateD3DTLVertex XCor, YCor, 0, 1, dx.CreateColorRGBA(R, G, B, A), _
    0, Src.Left / SurfW, (Src.Bottom + 0.1) / SurfH, Verts(0)
    '//* Calculate screen coordinates of sprite, and only rotate if necessary
    If Angle = 0 Then
        XCor = Dest.Left
        YCor = Dest.Top
    Else
        XCor = XCenter + (Dest.Left - XCenter) * Sin(Angle) + (Dest.Top - YCenter) * Cos(Angle)
        YCor = YCenter + (Dest.Top - YCenter) * Sin(Angle) - (Dest.Left - XCenter) * Cos(Angle)
    End If
   
    '//*  高耸左边的顶 (1-Top left vertex)
    dx.CreateD3DTLVertex _
    XCor, YCor, 0, 1, _
    dx.CreateColorRGBA(R, G, B, A), 0, _
    Src.Left / SurfW, Src.Top / SurfH, Verts(1)
    '//* Calculate screen coordinates of sprite, and only rotate if necessary
    '//*  计算子画面的荧屏坐标, 和如果有需要的话只使旋转
    If Angle = 0 Then
        XCor = Dest.Right
        YCor = Dest.Bottom
    Else
        XCor = XCenter + (Dest.Right - XCenter) * Sin(Angle) + (Dest.Bottom - YCenter) * Cos(Angle)
        YCor = YCenter + (Dest.Bottom - YCenter) * Sin(Angle) - (Dest.Right - XCenter) * Cos(Angle)
    End If
   
    '//* 2 - Bottom right vertex
    dx.CreateD3DTLVertex XCor, YCor, 0, 1, _
    dx.CreateColorRGBA(R, G, B, A), 0, _
    (Src.Right + 0.1) / SurfW, (Src.Bottom + 0.1) / SurfH, Verts(2)
    '//* Calculate screen coordinates of sprite, and only rotate if necessary
    '//*  计算子画面的荧屏坐标, 和如果有需要的话只使旋转
    If Angle = 0 Then
        XCor = Dest.Right
        YCor = Dest.Top
    Else
        XCor = XCenter + (Dest.Right - XCenter) * Sin(Angle) + (Dest.Top - YCenter) * Cos(Angle)
        YCor = YCenter + (Dest.Top - YCenter) * Sin(Angle) - (Dest.Right - XCenter) * Cos(Angle)
    End If
    '//* 3 - Top right vertex
    dx.CreateD3DTLVertex XCor, YCor, 0, 1, _
    dx.CreateColorRGBA(R, G, B, A), 0, _
    (Src.Right + 0.1) / SurfW, Src.Top / SurfH, Verts(3)
End Sub



Sub FlipBlt(Optional hWnd As Long = 0) '//* 翻面操作过程
    On Local Error GoTo errOutC
     If hWnd = 0 Then hWnd = gL_mFromHwnd
'//*  等待前一次翻面操作完成. <<DirectDraw原理与API参考 P45页>>
     dx.GetWindowRect hWnd, rBack '//*  这个是一组的 <1>
'     Primary.Flip Nothing, DDFLIP_WAIT
''     Primary.Blt rBack, BackBuffer, rBack, DDBLT_WAIT '//*  这个是一组的 <2>
     Primary.Blt rBack, BackBuffer, rBack, DDBLT_DONOTWAIT
'     BackBuffer.BltFast 0, 0, BackBuffer, rBack, DDBLTFAST_SRCCOLORKEY Or DDBLTFAST_WAIT
'     Primary.Flip Nothing, DDFLIP_WAIT
    Exit Sub
errOutC:
'    If Not (DD Is Nothing) Then
   Call Err_Msg_Log.AT_Error_Run("无法对 Primary.Flip 过程 FlipBlt", Err.Number)
End Sub

lights

你们实在是，DRAW7不支持ALPHABLEND没错！D3D7支持啊！用D3D7自己封个Sprite难道不是最好的解决方案么？

E语

严重感谢nogood！！！！

mk124

偶也严重感谢nogood~~~!!!!!这..太好拉!辛苦!