SmoothScrolling


Option Explicit
‘Function calls
Declare Sub CopyMemory Lib “kernel32” Alias “RtlMoveMemory” (ByRef pDst As Any, ByRef pSrc As Any, ByVal ByteLen As Long)

‘DirectDraw Declarations
Public Dx As New DirectX7
Public DD As DirectDraw7

‘Primary Surface
Public ddsFront As DirectDrawSurface7
‘Backbuffer
Public ddsBack As DirectDrawSurface7

‘Types
Public Type RGBMask
    rgbRed As Long
    rgbBlue As Long
    rgbGreen As Long
End Type

Public Type RGBQuad
    rgbBlue As Byte
    rgbRed As Byte
    rgbGreen As Byte
    rgbReserved As Byte
End Type

Public Type RGB16
    Position As RGBQuad
    Depth As RGBQuad
    Amount As RGBQuad
    Mask As RGBMask
End Type

Public RGB16Desc As RGB16

‘Blt FX
Dim ddfx As DDBLTFX

‘Font
Public MoCFont As New StdFont

‘Surface descriptions
Public ddsd1 As DDSURFACEDESC2
Public Ddsd2 As DDSURFACEDESC2
Public Function ddInit(ByRef myForm As Form, ByVal nWidth As Long, ByVal nHeight As Long, ByVal BPP As Integer, Optional UseSystemMemory As Boolean = False)
    ‘This subroutine initializes DirectDraw 7. myForm is the name of
    ‘the form to be used by DirectDraw.
    ‘Height and Width are screen dimensions, BPP is
    ‘the colour depth.
       
    On Error Resume Next
   
   
    Set DD = Dx.DirectDrawCreate(“”)
    myForm.Show
   
    ‘Full screen exclusive mode always
    Call DD.SetCooperativeLevel(myForm.hWnd, DDSCL_FULLSCREEN Or DDSCL_ALLOWMODEX Or DDSCL_EXCLUSIVE)
   
    DD.SetDisplayMode nWidth, nHeight, BPP, 0, DDSDM_DEFAULT
   
    ‘Fill out primary surface description
    ddsd1.lFlags = DDSD_CAPS Or DDSD_BACKBUFFERCOUNT
    If UseSystemMemory = True Then
        ddsd1.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE Or DDSCAPS_FLIP Or DDSCAPS_COMPLEX Or DDSCAPS_SYSTEMMEMORY
    Else
        ddsd1.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE Or DDSCAPS_FLIP Or DDSCAPS_COMPLEX
    End If
    ddsd1.lBackBufferCount = 1 ‘One backbuffer
   
    ‘ddsFront is the primary surface
    Set ddsFront = DD.CreateSurface(ddsd1)
   
    ‘Attach the backbuffer
    Dim Caps As DDSCAPS2
    If UseSystemMemory = True Then
        Caps.lCaps = DDSCAPS_BACKBUFFER Or DDSCAPS_SYSTEMMEMORY
    Else
        Caps.lCaps = DDSCAPS_BACKBUFFER
    End If
    Set ddsBack = ddsFront.GetAttachedSurface(Caps)
   
    ddsBack.GetSurfaceDesc Ddsd2
   
   
   
    With ddfx
        .ddckDestColorKey_high = RGB(0, 0, 0)
        .ddckDestColorKey_low = RGB(0, 0, 0)
    End With
   
       
    ‘Create an easily readable surface
    ‘Set the default font
    DDSetFont “Calligraphic 421 BT”, RGB(255, 255, 255)
   
   
    ddsBack.SetFontTransparency True
   
End Function
Public Sub DDSetFont(FontName As String, Optional FontColour As Long)
    ‘Changes the font of a surface
    MoCFont.Name = FontName
    MoCFont.Size = 12
    ddsBack.SetForeColor FontColour
    ddsBack.SetFont MoCFont
End Sub
Public Sub DDSurface16Setup(surface As DirectDrawSurface7)
    ‘This sub sets up a surface for alpha-blending.
    ‘It creates RGB masks.
   
    Dim Ddsd As DDSURFACEDESC2
    Dim nCount As Byte
   
    ‘Surface description
    Ddsd.lWidth = Len(Ddsd.lWidth)
    Ddsd.lHeight = Len(Ddsd.lHeight)
    Ddsd.lFlags = DDSD_PIXELFORMAT
    surface.GetSurfaceDesc Ddsd
   
    ‘Set up masks
    RGB16Desc.Mask.rgbRed = Ddsd.ddpfPixelFormat.lRBitMask
    RGB16Desc.Mask.rgbGreen = Ddsd.ddpfPixelFormat.lGBitMask
    RGB16Desc.Mask.rgbBlue = Ddsd.ddpfPixelFormat.lBBitMask
   
    ‘Red
    nCount = 0
    While Not ((Ddsd.ddpfPixelFormat.lRBitMask And &H1) = &H1)
        Ddsd.ddpfPixelFormat.lRBitMask = BitShiftRight(Ddsd.ddpfPixelFormat.lRBitMask, 1)
        nCount = nCount + 1
    Wend
   
    RGB16Desc.Depth.rgbRed = BitShiftRight(Ddsd.ddpfPixelFormat.lRBitMask, 12)
    RGB16Desc.Position.rgbRed = nCount
    If Ddsd.ddpfPixelFormat.lRBitMask = &H1F Then
        RGB16Desc.Amount.rgbRed = 3
    Else
        RGB16Desc.Amount.rgbRed = 2
    End If
   
    ‘Green
    nCount = 0
    While Not ((Ddsd.ddpfPixelFormat.lGBitMask And &H1) = &H1)
        Ddsd.ddpfPixelFormat.lGBitMask = BitShiftRight(Ddsd.ddpfPixelFormat.lGBitMask, 1)
        nCount = nCount + 1
    Wend
   
    RGB16Desc.Depth.rgbGreen = BitShiftRight(Ddsd.ddpfPixelFormat.lGBitMask, 12)
    RGB16Desc.Position.rgbGreen = nCount
    If Ddsd.ddpfPixelFormat.lGBitMask = &H1F Then
        RGB16Desc.Amount.rgbGreen = 3
    Else
        RGB16Desc.Amount.rgbGreen = 2
    End If
   
    ‘Blue
    nCount = 0
    While Not ((Ddsd.ddpfPixelFormat.lBBitMask And &H1) = &H1)
        Ddsd.ddpfPixelFormat.lBBitMask = BitShiftRight(Ddsd.ddpfPixelFormat.lBBitMask, 1)
        nCount = nCount + 1
    Wend
   
    RGB16Desc.Depth.rgbBlue = BitShiftRight(Ddsd.ddpfPixelFormat.lBBitMask, 12)
    RGB16Desc.Position.rgbBlue = nCount
    If Ddsd.ddpfPixelFormat.lBBitMask = &H1F Then
        RGB16Desc.Amount.rgbBlue = 3
    Else
        RGB16Desc.Amount.rgbBlue = 2
    End If
End Sub

Public Sub DDCreateSurface(surface As DirectDrawSurface7, BmpPath As String, RECTvar As RECT, Optional TransCol As Integer = 0, Optional UseSystemMemory As Boolean = True)
    ‘This sub will load a bitmap from a file
    ‘into a specified dd surface. Transparent
    ‘colour is black (0) by default.
   
    Dim tempddsd As DDSURFACEDESC2
   
    Set surface = Nothing
   
    ‘Load sprite
    tempddsd.lFlags = DDSD_CAPS
    If UseSystemMemory = True Then
        tempddsd.ddsCaps.lCaps = DDSCAPS_SYSTEMMEMORY Or DDSCAPS_OFFSCREENPLAIN
    Else
        tempddsd.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
    End If
    Set surface = DD.CreateSurfaceFromFile(BmpPath, tempddsd)
   
    ‘set the RECT dimensions
    RECTvar.Right = tempddsd.lWidth
    RECTvar.Bottom = tempddsd.lHeight
   
    ‘Colour key
    Dim ddckColourKey As DDCOLORKEY
    ddckColourKey.low = TransCol
    ddckColourKey.high = TransCol
    surface.SetColorKey DDCKEY_SRCBLT, ddckColourKey
   
   
End Sub
Public Sub DDColorFill(surface As DirectDrawSurface7, x1 As Integer, y1 As Integer, x2 As Integer, y2 As Integer, color As Long)
    ‘Fills a surface with a specified colour
    Dim FillRECT As RECT
    With FillRECT
        .Top = y1
        .Left = x1
        .Right = x2
        .Bottom = y2
    End With
   
    surface.BltColorFill FillRECT, color
End Sub
Public Sub DDBltFast(surface As DirectDrawSurface7, RECTvar As RECT, x As Integer, y As Integer, Optional transparent As Boolean = True, Optional Clip As Boolean = True)
    ‘This subroutine will BltFast a surface to the
    ‘backbuffer. This wont work with clipper.
   
    ‘CLIPPING
    ‘Temporary rect
    Dim RectTEMP As RECT
    RectTEMP = RECTvar
   
    If Clip = True Then
        ‘Set up screen rect for clipping
        Dim ScreenRECT As RECT
        With ScreenRECT
            .Top = y
            .Left = x
            .Bottom = y + RECTvar.Bottom
            .Right = x + RECTvar.Right
        End With
        ‘Clip surface
        With ScreenRECT
            If .Bottom > 600 Then
                RectTEMP.Bottom = RectTEMP.Bottom – (.Bottom – 600)
                .Bottom = 590
            End If
            If .Left < 0 Then
                RectTEMP.Left = RectTEMP.Left – .Left
                .Left = 0
                x = 0
            End If
            If .Right > 800 Then
                RectTEMP.Right = RectTEMP.Right – (.Right – 800)
                .Right = 800
            End If
            If .Top < 0 Then
                RectTEMP.Top = RectTEMP.Top – .Top
                .Top = 0
                y = 0
            End If
        End With
   
    End If
   
    If transparent = False Then
        Call ddsBack.BltFast(x, y, surface, RectTEMP, DDBLTFAST_WAIT)
    Else
        Call ddsBack.BltFast(x, y, surface, RectTEMP, DDBLTFAST_WAIT Or DDBLTFAST_SRCCOLORKEY)
    End If
End Sub
Public Sub DDBlt(surface As DirectDrawSurface7, RECTvar As RECT, CoorX As Integer, CoorY As Integer, Optional transparent As Boolean = True, Optional Clip As Boolean = True)
    ‘This sub will Blt a surface to the backbuffer.
    ‘This is for use with Clipper
    Dim DestRECT As RECT
    DestRECT.Top = CoorY
    DestRECT.Left = CoorX
    DestRECT.Right = CoorX + RECTvar.Right
    DestRECT.Bottom = CoorY + RECTvar.Bottom
   
    ‘CLIPPING
    ‘Temporary rect
    Dim RectTEMP As RECT
    RectTEMP = RECTvar
   
    If Clip = True Then
        ‘Set up screen rect for clipping
        Dim ScreenRECT As RECT
        With ScreenRECT
            .Top = CoorY
            .Left = CoorX
            .Bottom = CoorY + RECTvar.Bottom
            .Right = CoorX + RECTvar.Right
        End With
        ‘Clip surface
        With ScreenRECT
            If .Bottom > 600 Then
                RectTEMP.Bottom = RectTEMP.Bottom – (.Bottom – 600)
                .Bottom = 590
            End If
            If .Left < 0 Then
                RectTEMP.Left = RectTEMP.Left – .Left
                .Left = 0
                CoorX = 0
            End If
            If .Right > 800 Then
                RectTEMP.Right = RectTEMP.Right – (.Right – 800)
                .Right = 800
            End If
            If .Top < 0 Then
                RectTEMP.Top = RectTEMP.Top – .Top
                .Top = 0
                CoorY = 0
            End If
        End With
    End If
   
    If transparent = True Then
        Call ddsBack.BltFx(DestRECT, surface, RectTEMP, DDBLT_WAIT Or DDBLT_KEYSRCOVERRIDE, ddfx)
    Else
        Call ddsBack.Blt(DestRECT, surface, RectTEMP, DDBLT_WAIT)
    End If
   
End Sub
Public Sub DDBltTranslucent(surface As DirectDrawSurface7, RECTvar As RECT, CoorX As Integer, CoorY As Integer, Optional transparent As Boolean = True)
    ‘This sub will use SrcPaint to draw a semi-transparent
    ‘image. Typically for use with shadows, etc.
    Dim DestRECT As RECT
    With DestRECT
        .Top = 0
        .Left = 0
        .Right = 54
        .Bottom = 50
    End With
    Dim fx As DDBLTFX
    ‘With fx
        ‘.lROP = SRCPAINT
    ‘    .ddckDestColorKey_high = RGB(0, 0, 0)
    ‘    .ddckDestColorKey_low = RGB(0, 0, 0)
    ‘End With
    fx.lROP = vbSrcPaint
    Call ddsBack.BltFx(DestRECT, surface, RECTvar, DDBLT_WAIT Or DDBLT_ROP, fx)
   
End Sub
Public Sub DDBltFastAnim(surface As DirectDrawSurface7, RECTvar As RECT, x As Integer, y As Integer, FrameNumber As Integer, FrameWidth As Integer, Optional transparent As Boolean = True, Optional Clip As Boolean = True)
    ‘This sub will draw animations. Meaning that the
    ‘part of the picture will be drawn according to the
    ‘frame number. The pics in the file have to be in
    ‘1 strip. Wont work with clipper.
   
    RECTvar.Left = FrameWidth * FrameNumber – FrameWidth
    RECTvar.Right = FrameWidth * FrameNumber
   
    ‘CLIPPING
    ‘Temporary rect
    Dim RectTEMP As RECT
    RectTEMP = RECTvar
   
    If Clip = True Then
        ‘Set up screen rect for clipping
        Dim ScreenRECT As RECT
        With ScreenRECT
            .Top = y
            .Left = x
            .Bottom = y + RectTEMP.Bottom
            .Right = x + FrameWidth
        End With
        ‘Clip surface
        With ScreenRECT
            If .Bottom > 600 Then
                RectTEMP.Bottom = RectTEMP.Bottom – (.Bottom – 600)
                .Bottom = 600
            End If
            If .Left < 0 Then
                RectTEMP.Left = RectTEMP.Left – .Left
                .Left = 0
                x = 0
            End If
            If .Right > 800 Then
                RectTEMP.Right = RectTEMP.Right – (.Right – 800)
                .Right = 800
            End If
            If .Top < 0 Then
                RectTEMP.Top = RectTEMP.Top – .Top
                .Top = 0
                y = 0
            End If
        End With
   
    End If
   
   
    If transparent = True Then
        Call ddsBack.BltFast(x, y, surface, RectTEMP, DDBLTFAST_WAIT Or DDBLTFAST_SRCCOLORKEY)
    Else
        Call ddsBack.BltFast(x, y, surface, RectTEMP, DDBLTFAST_WAIT)
    End If
   
End Sub
Public Sub DDBltAnim(surface As DirectDrawSurface7, RECTvar As RECT, CoorX As Integer, CoorY As Integer, FrameNumber As Integer, FrameWidth As Integer, Optional transparent As Boolean = True, Optional Clip As Boolean = True)
    ‘This sub will draw animations. This is the same as the sub above
    ‘but will work with clipper.
   
    RECTvar.Left = FrameWidth * FrameNumber – FrameWidth
    RECTvar.Right = FrameWidth * FrameNumber
   
    Dim DestRECT As RECT
    DestRECT.Top = CoorY
    DestRECT.Left = CoorX
    DestRECT.Right = CoorX + FrameWidth
    DestRECT.Bottom = CoorY + RECTvar.Bottom
   
       
    If transparent = True Then
        Call ddsBack.BltFx(DestRECT, surface, RECTvar, DDBLT_WAIT Or DDBLT_KEYSRCOVERRIDE, ddfx)
    Else
        Call ddsBack.Blt(DestRECT, surface, RECTvar, DDBLT_WAIT)
    End If
   
End Sub
Public Sub DDDrawBox(surface As DirectDrawSurface7, x1 As Integer, y1 As Integer, x2 As Integer, y2 As Integer, Width As Integer, Col As Long)
    ‘Draws a box on a specified surface
    Dim x As Integer
   
    ‘Get the previous colour of the surface
    Dim PrevColour As Long
    PrevColour = surface.GetForeColor
   
    surface.SetForeColor Col
    For x = 1 To Width
        surface.DrawBox x1 + x, y1 + x, x2 – x, y2 – x
    Next
   
    ‘Reset
    surface.SetForeColor PrevColour
End Sub
Public Sub DDLock(surface As DirectDrawSurface7, x As Integer, y As Integer, picWidth As Integer, picHeight As Integer, Ddsd As DDSURFACEDESC2)
    ‘Locks a surface and gets the memory pointer.
    Dim tempRECT As RECT
   
    With tempRECT
        .Top = y
        .Left = x
        .Right = x + picWidth
        .Bottom = y + picHeight
    End With
   
    surface.Lock tempRECT, Ddsd, DDLOCK_WAIT Or DDLOCK_SURFACEMEMORYPTR, 0
   
End Sub
Public Sub DDAlphaBlend1(destSurface As DirectDrawSurface7, srcSurface As DirectDrawSurface7, CoorX As Integer, CoorY As Integer, srcRECT As RECT, Alphavalue As Integer)
    ‘This subroutine will alpha-blend two surfaces.
    ‘This is the slower version using SetLockedPixel
    Dim DestRECT As RECT
    With DestRECT
        .Top = CoorY
        .Bottom = CoorY + srcRECT.Bottom
        .Left = CoorX
        .Right = CoorX + srcRECT.Right
    End With
   
   
    Dim Alpha As Integer ‘alpha value
    Dim ddsdTEMP1 As DDSURFACEDESC2
    Dim ddsdTEMP2 As DDSURFACEDESC2
    Dim SrcCol1 As Long, SrcCol2 As Long
    Dim RMask&, GMask&, BMask&
    Dim FinalCol As Long
    Dim x%, y%
    ‘Dim PixelNum As Integer
    ‘Dim nOffset As Long
    ‘Dim nColor16 As Long
    Dim PixelColor As Long
   
    Alpha = (256 – Alphavalue)
   
    ‘Destination surface description
    ddsdTEMP1.lWidth = DestRECT.Right
    ddsdTEMP1.lHeight = DestRECT.Bottom
    ‘Source surface description
    ddsdTEMP2.lWidth = srcRECT.Right
    ddsdTEMP2.lHeight = srcRECT.Bottom
   
    ‘Lock the surfaces
    destSurface.Lock DestRECT, ddsdTEMP1, DDLOCK_WAIT Or DDLOCK_SURFACEMEMORYPTR, 0
    srcSurface.Lock srcRECT, ddsdTEMP2, DDLOCK_WAIT Or DDLOCK_SURFACEMEMORYPTR, 0
   
    For x = DestRECT.Left To DestRECT.Right
        For y = DestRECT.Top To DestRECT.Bottom
                                
            ‘Get the colour for the dest surface
            SrcCol1 = destSurface.GetLockedPixel(x, y)
           
            ‘Get colour for src surface
            SrcCol2 = srcSurface.GetLockedPixel(x, y)
            If SrcCol2 = 0 Then GoTo endit
           
            ‘Get RGB Masks
            RMask = RGB16Desc.Mask.rgbRed
            GMask = RGB16Desc.Mask.rgbGreen
            BMask = RGB16Desc.Mask.rgbBlue
           
            ‘Blending algorithm
            FinalCol = (RMask And (((SrcCol1 And RMask) * Alpha + (SrcCol2 And RMask) * Alphavalue) / 256)) _
                    Or (GMask And (((SrcCol1 And GMask) * Alpha + (SrcCol2 And GMask) * Alphavalue) / 256)) _
                    Or (BMask And (((SrcCol1 And BMask) * Alpha + (SrcCol2 And BMask) * Alphavalue) / 256))
                   
            ‘Draw the final pixel
            destSurface.SetLockedPixel x, y, FinalCol
endit:
        Next
    Next
   
    ‘Unlock
    destSurface.Unlock DestRECT
    srcSurface.Unlock srcRECT
   
End Sub
Public Sub DDAlphaBlend3(destSurface As DirectDrawSurface7, srcSurface As DirectDrawSurface7, CoorX As Integer, CoorY As Integer, srcRECT As RECT, Alphavalue As Integer)
    ‘This sub will alpha-blend two images. Uses CopyMemory!
    Dim DestRECT As RECT
    With DestRECT
        .Top = CoorY
        .Bottom = CoorY + srcRECT.Bottom
        .Left = CoorX
        .Right = CoorX + srcRECT.Right
    End With
   
   
    Dim Alpha As Integer ‘alpha value
    Dim ddsdTEMP1 As DDSURFACEDESC2
    Dim ddsdTEMP2 As DDSURFACEDESC2
    Dim SrcCol1 As Long, SrcCol2 As Long
    Dim RMask&, GMask&, BMask&
    Dim FinalCol As Long
    Dim x%, y%
    ‘Dim PixelNum As Integer
    ‘Dim nOffset As Long
    ‘Dim nColor16 As Long
    Dim PixelColor As Long
   
    Alpha = (256 – Alphavalue)
   
    ‘Destination surface description
    ddsdTEMP1.lWidth = DestRECT.Right
    ddsdTEMP1.lHeight = DestRECT.Bottom
    ‘Source surface description
    ddsdTEMP2.lWidth = srcRECT.Right
    ddsdTEMP2.lHeight = srcRECT.Bottom
   
    ‘Lock the surfaces
    destSurface.Lock DestRECT, ddsdTEMP1, DDLOCK_WAIT Or DDLOCK_SURFACEMEMORYPTR, 0
    srcSurface.Lock srcRECT, ddsdTEMP2, DDLOCK_WAIT Or DDLOCK_SURFACEMEMORYPTR, 0
   
    For x = DestRECT.Left To DestRECT.Right
        For y = DestRECT.Top To DestRECT.Bottom
                                
            ‘Get the colour for the dest surface
            SrcCol1 = DDGetPixel(destSurface, x, y)
           
            ‘Get colour for src surface
            SrcCol2 = DDGetPixel(srcSurface, x, y)
            If SrcCol2 = 0 Then GoTo endit
           
            ‘Get RGB Masks
            RMask = RGB16Desc.Mask.rgbRed
            GMask = RGB16Desc.Mask.rgbGreen
            BMask = RGB16Desc.Mask.rgbBlue
           
            ‘Blending algorithm
            FinalCol = (RMask And (((SrcCol1 And RMask) * Alpha + (SrcCol2 And RMask) * Alphavalue) / 256)) _
                    Or (GMask And (((SrcCol1 And GMask) * Alpha + (SrcCol2 And GMask) * Alphavalue) / 256)) _
                    Or (BMask And (((SrcCol1 And BMask) * Alpha + (SrcCol2 And BMask) * Alphavalue) / 256))
                   
            ‘Draw the final pixel
            DDSetPixel destSurface, x, y, FinalCol
endit:
        Next
    Next
   
    ‘Unlock
    destSurface.Unlock DestRECT
    srcSurface.Unlock srcRECT
   
End Sub
Public Sub DDAlphaBlend2(destSurface As DirectDrawSurface7, srcSurface As DirectDrawSurface7, CoorX As Integer, CoorY As Integer, srcRECT As RECT, Alphavalue As Integer)
    ‘This sub will alpha-blend two images. This is faster than
    ‘DDAlphaBlend1 because it uses GetLockedArray instead of sloppy
    ‘direct pixel editing.
   
   
    Dim DestAlphaArray() As Byte
   
    Dim DestRECT As RECT
    With DestRECT
        .Top = CoorY
        .Left = CoorX
        .Right = CoorX + srcRECT.Right
        .Bottom = CoorY + srcRECT.Bottom
    End With
   
    Dim ddsdTEMP1 As DDSURFACEDESC2
    Dim ddsdTEMP2 As DDSURFACEDESC2
     
    Dim x As Integer, y As Integer
    Dim Alpha
    Alpha = (256 – Alphavalue)
   
    Dim srcBlue As Byte
    Dim srcGreen As Byte
    Dim srcRed As Byte
   
    Dim destBlue As Byte
    Dim destGreen As Byte
    Dim destRed As Byte
   
    Dim FinalBlue As Byte
    Dim FinalGreen As Byte
    Dim FinalRed As Byte
   
    ‘Destination surface description
    ddsdTEMP1.lWidth = DestRECT.Right
    ddsdTEMP1.lHeight = DestRECT.Bottom
    ‘Source surface description
    ddsdTEMP2.lWidth = srcRECT.Right
    ddsdTEMP2.lHeight = srcRECT.Bottom
   
    Dim SrcArray() As Byte
    destSurface.Lock DestRECT, ddsdTEMP1, DDLOCK_WAIT, 0
    destSurface.GetLockedArray DestAlphaArray()
   
    srcSurface.Lock srcRECT, ddsdTEMP2, DDLOCK_WAIT, 0
    srcSurface.GetLockedArray SrcArray()
   
    ‘alpha blending
    For y = 0 To UBound(SrcArray(), 2)
        For x = 0 To UBound(SrcArray(), 1) Step 3
            srcBlue = SrcArray(x, y)
            srcGreen = SrcArray(x + 1, y)
            srcRed = SrcArray(x + 2, y)
           
            destBlue = DestAlphaArray(x + (CoorX * 3), y + CoorY)
            destGreen = DestAlphaArray(x + (CoorX * 3) + 1, y + CoorY)
            destRed = DestAlphaArray(x + (CoorX * 3) + 2, y + CoorY)
                     
            FinalBlue = CByte(destBlue * (256 – Alphavalue) / 256 + srcBlue * Alphavalue / 256)
            FinalGreen = CByte(destGreen * (256 – Alphavalue) / 256 + srcGreen * Alphavalue / 256)
            FinalRed = CByte(destRed * (256 – Alphavalue) / 256 * srcRed * Alphavalue / 256)
           
            DestAlphaArray(x + (CoorX * 3), y + CoorY) = FinalBlue
            DestAlphaArray(x + (CoorX * 3) + 1, y + CoorY) = FinalGreen
            DestAlphaArray(x + (CoorX * 3) + 2, y + CoorY) = FinalRed
        Next x
    Next y
   
    destSurface.Unlock DestRECT
    srcSurface.Unlock srcRECT
End Sub
Public Sub DDSetPixel(surface As DirectDrawSurface7, x As Integer, y As Integer, Col As Long)
    ‘This sub plots a pixel to a surface.
    ‘NOTE: Surface must be locked. This is slower than CopyMemory
    surface.SetLockedPixel x, y, Col
End Sub
Public Function DDGetPixel(surface As DirectDrawSurface7, x As Integer, y As Integer)
    ‘This function returns the colour of a pixel on a surface.
    ‘NOTE: Surface must be locked. Slower than using CopyMemory
    DDGetPixel = surface.GetLockedPixel(x, y)
End Function
Public Sub DDGetPixel2(surface As DirectDrawSurface7, x As Integer, y As Integer, Col As Long)
    ‘Gets the colour of a pixel using CopyMemory
    Dim nOffset As Long
    Dim nColor16 As Long
    Dim PixelColor As Long
   
    Dim SrcArray() As Byte
   
   
End Sub
Public Sub DDUnlock(surface As DirectDrawSurface7, x As Integer, y As Integer, picWidth As Integer, picHeight As Integer)
    ‘Unlocks a previously locked surface
    Dim tempRECT As RECT
   
    With tempRECT
        .Top = y
        .Left = x
        .Right = x + picWidth
        .Bottom = y + picHeight
    End With
   
    surface.Unlock tempRECT
End Sub

Public Sub DDFlip()
    On Error Resume Next
   
    ‘This sub flips the backbuffer onto the primary surface
    ddsFront.Flip Nothing, DDFLIP_WAIT
End Sub

Public Function BitShiftRight(ByVal intValue As Long, ByVal intShiftBy As Byte) As Variant
    ‘Bit shifts a value to the right
    Dim lngShiftVal As Long
    lngShiftVal = 2 ^ intShiftBy
    BitShiftRight = Fix(intValue / lngShiftVal)
End Function
Public Function BitShiftLeft(ByVal intValue As Long, ByVal intShiftBy As Byte) As Variant
    ‘Bit shift a value to the left
    Dim lngShiftVal As Long
    lngShiftVal = 2 ^ intShiftBy
    BitShiftLeft = Fix(intValue * lngShiftVal)
End Function

Public Sub DDUnload(myForm As Form)
    Set ddsFront = Nothing
    Set ddsBack = Nothing
   
    ‘This subroutine unloads DirectDraw.
    Call DD.RestoreDisplayMode
    Call DD.SetCooperativeLevel(myForm.hWnd, DDSCL_NORMAL)
    End
End Sub

 

 

 

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s