PowerBASIC - Alphablending FX DLL

'This is a PowerBASIC 32-bit DLL
'using pure SDK programming style "a la Petzold" (just like in plain C)
'
'Complete source code + DLL could be downloaded from there:
'http://www.zapsolution.com/preview/skssfx.zip
'(size of the ZIP file: 9064 bytes)
'
'Author's web site:
'http://www.zapsolution.com
'Want to see what could be done with PowerBASIC then give a try to this:
'http://www.zapsolution.com/preview/WinLIFT.exe
'
'

VB Code:

SUB skEffect ALIAS "skEffect" (BYVAL hDC&, _                 ' Destination device context
                               BYVAL xDest&, _               ' Upper-left X coordinate (pixels)
                               BYVAL yDest&, _               ' Upper-left Y coordinate (pixels)
                               BYVAL nWidth&, _              ' Width of destination
                               BYVAL nHeight&, _             ' Height of destination
                               BYVAL hSrcBMP&, _             ' Handle of the source bitmap
                               BYVAL Dummy&, _               ' Unused
                               BYVAL CallBackFX AS DWORD, _  ' CODEPTR
                               BYVAL uGrain&, _              ' Pixel square size
                               BYVAL uDelay&, _              ' Speed effect in millisecond
                               BYVAL UseEffect&) EXPORT      ' The effect type
 
    REGISTER x&, y&
 
    DIM Bm(2) AS BITMAP, hTmpBmp&(2), hDC&(2), hTmpDC&(2)
    DIM bmi As BITMAPINFO
    DIM pBits0 AS BYTE PTR, pBits1 AS BYTE PTR, pBits2 AS BYTE PTR
 
    hDC&(1) = CreateCompatibleDC(hDC&)
    CALL SelectObject(hDC&(1), hSrcBMP&)
 
    hDC&(2) = CreateCompatibleDC(hDC&)
    hResultBmp& = CreateCompatibleBitmap(hDC&, nWidth&, nHeight&)
    hDestPrevBmp& = SelectObject(hDC&(2), hResultBmp&)
    CALL BitBlt(hDC&(2), 0, 0, nWidth&, nHeight&, hDC&, xDest&, yDest&, %SRCCOPY)
 
    bmi.bmiHeader.biSize = SIZEOF(bmi.bmiHeader)
    bmi.bmiHeader.biWidth = nWidth&
    bmi.bmiHeader.biHeight = nHeight&
    bmi.bmiHeader.biPlanes = 1
    bmi.bmiHeader.biBitCount = 32
    bmi.bmiHeader.biCompression = %BI_RGB
    FOR K& = 2 TO 0 STEP -1
       hTmpDC&(K&) = CreateCompatibleDC (hDC&)
       hTmpBmp&(K&) = CreateDIBSection(hTmpDC&(K&), bmi, %DIB_RGB_COLORS, 0, 0, 0)
       CALL GlobalLock(hTmpBmp&(K&))
       CALL SelectObject(hTmpDC&(K&), hTmpBmp&(K&))
       IF K& THEN
          CALL BitBlt(hTmpDC&(K&), 0, 0, nWidth&, nHeight&, hDC&(K&), 0, 0, %SRCCOPY)
       END IF
       CALL GetObject(hTmpBmp&(K&), SIZEOF(bm(K&)), bm(K&))
       IF K& = 0 THEN
          SELECT CASE LONG UseEffect&
          CASE FxAlphablend ' Alphablending using using uGrain& as percent value
               GOSUB ResetPTR
               p1& = uGrain&: p2& = 100 - uGrain&
               FOR Y& = nHeight& - 1 TO 0 STEP - 1
                   FOR X& = nWidth& - 1 TO 0 STEP -1
                       GOSUB ComputePTR
                   NEXT
               NEXT
               GOSUB DisplayFX
               GOSUB DelayFX
          CASE FxTop, FxBottom ' 1 = Dissolve from top
                               ' 2 = Dissolve from bottom
               GOSUB ResetPTR
               FOR Y& = nHeight& - 1 TO 0 STEP - 1
                   Percent& = Y& / nHeight& * 100
                   IF UseEffect& = 1 THEN
                      p1& = percent&: p2& = 100 - percent&
                   ELSE
                      p1& = 100 - percent&: p2& = percent&
                   END IF
                   FOR X& = nWidth& - 1 TO 0 STEP -1
                       GOSUB ComputePTR
                   NEXT
               NEXT
               GOSUB DisplayFX
               GOSUB DelayFX
          CASE FxLeft, FxRight ' 3 = Dissolve from left
                               ' 4 = Dissolve from right
               GOSUB ResetPTR
               FOR Y& = nHeight& - 1 TO 0 STEP - 1
                   FOR X& = nWidth& - 1 TO 0 STEP -1
                       Percent& = X& / nWidth& * 100
                       IF UseEffect& = 3 THEN
                          p1& = 100 - percent&: p2& = percent&
                       ELSE
                          p2& = 100 - percent&: p1& = percent&
                       END IF
                       GOSUB ComputePTR
                   NEXT
               NEXT
               GOSUB DisplayFX
               GOSUB DelayFX
          CASE FxHorzCenter, FxVertCenter ' 5 = Dissolve horizontaly to center
                                          ' 6 = Dissolve verticaly to center
               GOSUB ResetPTR
               FOR Y& = nHeight& - 1 TO 0 STEP - 1
                   IF UseEffect& = 5 THEN
                      IF Y& < nHeight& \ 2 THEN 
                         Percent& = (Y& / nHeight& * 100) * 2
                      ELSE
                         Percent& = 200 - ((Y& / nHeight& * 100) * 2)
                      END IF
                      p2& = 100 - percent&: p1& = percent&
                   END IF
                   FOR X& = nWidth& - 1 TO 0 STEP -1
                       IF UseEffect& = 6 THEN
                          IF X& < nWidth& \ 2 THEN 
                             Percent& = (X& / nWidth& * 100) * 2
                          ELSE
                             Percent& = 200 - ((X& / nWidth& * 100) * 2)
                          END IF
                          p2& = 100 - percent&: p1& = percent&
                       END IF
                       GOSUB ComputePTR
                   NEXT
               NEXT
               GOSUB DisplayFX
               GOSUB DelayFX
          CASE FxCenter    ' 7 = Dissolve to center
               GOSUB ResetPTR
               FOR Y& = nHeight& - 1 TO 0 STEP - 1
                   IF Y& < nHeight& \ 2 THEN 
                      P& = (Y& / nHeight& * 100) * 2
                   ELSE
                      P& = 200 - ((Y& / nHeight& * 100) * 2)
                   END IF
                   FOR X& = nWidth& - 1 TO 0 STEP -1
                       IF X& < nWidth& \ 2 THEN 
                          Percent& = (X& / nWidth& * 100) * 2
                       ELSE
                          Percent& = 200 - ((X& / nWidth& * 100) * 2)
                       END IF
                       IF P& < Percent& THEN Percent& = P&
                       p2& = 100 - percent&: p1& = percent&
                       GOSUB ComputePTR
                   NEXT
               NEXT
               GOSUB DisplayFX
               GOSUB DelayFX
          CASE ELSE ' Full dissolve
               FOR Percent& = 1 TO 100 STEP uGrain&
                   GOSUB ResetPTR
                   p1& = percent&: p2& = 100 - percent&
                   FOR Y& = nHeight& - 1 TO 0 STEP - 1
                       FOR X& = nWidth& - 1 TO 0 STEP -1
                           GOSUB ComputePTR
                       NEXT
                   NEXT
                   GOSUB DisplayFX
                   IF uDelay& THEN
                      T??? = GetTickCount + uDelay&
                      DO WHILE GetTickCount < T???
                         CALL apiSLEEP(0)
                         GOSUB CheckStatusFX: IF BailOut& THEN EXIT DO
                      LOOP
                   ELSE
                      GOSUB CheckStatusFX
                   END IF
                   IF BailOut& THEN EXIT FOR
               NEXT
          END SELECT
          FOR T& = 0 TO 2
              CALL GlobalUnLock(hTmpBmp&(T&))
              CALL DeleteDC(hTmpDC&(T&)): CALL DeleteObject(hTmpBmp&(T&))
          NEXT
       END IF
    NEXT
  ' Select original objects back.
    CALL SelectObject(hDC&(2), hDestPrevBmp&)
  ' Deallocate system resources.
    CALL DeleteObject(hResultBmp&)
    FOR K& = 1 TO 2
        DeleteDC hDC&(K&)
    NEXT
    EXIT SUB
    
ResetPTR:
    pBits0 = bm(0).bmBits
    pBits1 = bm(1).bmBits
    pBits2 = bm(2).bmBits
    RETURN    
ComputePTR:
    @pBits0[2] = ((p1& * @pBits1[2] + p2& * @pBits2[2])) \ 100
    @pBits0[1] = ((p1& * @pBits1[1] + p2& * @pBits2[1])) \ 100
    @pBits0[0] = ((p1& * @pBits1[0] + p2& * @pBits2[0])) \ 100
    pBits0 = pBits0 + 4: pBits1 = pBits1 + 4: pBits2 = pBits2 + 4
    RETURN
DelayFX:
    IF uDelay& THEN
       T??? = GetTickCount + uDelay&
       DO WHILE GetTickCount < T???
          CALL apiSLEEP(0)
          GOSUB CheckStatusFX: IF BailOut& THEN EXIT DO
       LOOP
    END IF
    RETURN
CheckStatusFX:
    IF CallBackFX THEN
       CALL DWORD CallBackFX USING StatusCallBack(0) TO BailOut&
       IF BailOut& <> ERROR_USER_ABORT THEN BailOut& = 0
    END IF
    RETURN
DisplayFX:
    CALL BitBlt(hDC&, xDest&, yDest&, nWidth&, nHeight&, hTmpDC&(K&), 0, 0, %SRCCOPY)
    RETURN
END SUB
'

Header to include in your source code, to use the SKSSFX.DLL

VB Code:

CONST FxAlphablend     = -1 ' Alphablending using uGrain& as percent value
CONST FxFullFading     = 0  ' Full fading mode (Requires a fast computer)
CONST FxTop            = 1  ' Dissolve from top
CONST FxBottom         = 2  ' Dissolve from bottom
CONST FxLeft           = 3  ' Dissolve from left
CONST FxRight          = 4  ' Dissolve from right
CONST FxHorzCenter     = 5  ' Dissolve horizontaly to center
CONST FxVertCenter     = 6  ' Dissolve verticaly to center
CONST FxCenter         = 7  ' Dissolve to center
 
CONST ERROR_USER_ABORT = -100
 
DECLARE SUB skEffect LIB "skssfx.dll" ALIAS "skEffect" (BYVAL hDC&, BYVAL xDest&, BYVAL yDest&, BYVAL nWidth&, BYVAL nHeight&, BYVAL hSrcBMP&, BYVAL Dummy&, BYVAL CallBackFX AS DWORD, BYVAL uGrain&, BYVAL uDelay&, BYVAL UseEffect&)