'  Простая демонстрация загрузки альфа из 32-х битного *.BMP
'  Код для компилятора FreeBasic версии 0.24.0
'  >Quiet Snow< (c)  \16.01.2013\
'    www.iForum.pro
'  $Lang: "FBLite"

   '    Тип заголовка *.BMP
TYPE BMFile FIELD = 1
   BmID AS SHORT = 19778
   FileSize AS INTEGER
   Reserved AS INTEGER
   BmOFFSET AS INTEGER = 54
   HeadSize AS INTEGER = 40
   BmpSizeX AS INTEGER
   BmpSizeY AS INTEGER
   BmSlices AS SHORT = 1
   BitDepth AS SHORT = 32
   Rez1 As LONGINT
   Rez2 As LONGINT
   Rez3 As LONGINT
END TYPE

DECLARE FUNCTION LoadBMP (BmName AS STRING) AS ANY POINTER
DECLARE SUB SaveBMP (BmName AS STRING, IMG_Buff AS ANY POINTER)
DECLARE FUNCTION ResizeIMG (OldPictureID AS ANY POINTER, NewSizeX AS INTEGER, NewSizeY AS INTEGER, NeedCreate AS SHORT) AS ANY POINTER

DECLARE SUB ShadowPrint (x AS INTEGER, y AS INTEGER, StrOut AS STRING, Cv AS UINTEGER)
DECLARE SUB MouCurDraw (CurNum AS USHORT)

     '    Тех переменные
DIM SHARED AS INTEGER ScrXRez, ScrYRez, FullSCR
DIM SHARED AS INTEGER Mx, My, u, Btn, Dvig, Dvig2

     '    Наше разрешение
ScrXRez = 640
ScrYRez = 480
FullSCR = 0

     '    Установим экран
SCREENRES ScrXRez, ScrYRez, 32, 2, FullSCR

     '    Поинтеры на картинки
DIM SHARED My_Image(3) AS ANY POINTER

     '    Загрузим картинки
My_Image(0) = LoadBMP("Курсор 1.bmp")
My_Image(1) = LoadBMP("Курсор 2.bmp")

     '    Создаём картинку
My_Image(2) = ImageCreate (150, 80, RGBA(0, 0, 0, 0), 32)
     '    Заполняем её прозрачными кругами
FOR u = 1 to 50
CIRCLE My_Image(2), (RND * 150, RND * 80), RND * 30, RGBA(RND * 255, RND * 255, RND * 255, RND * 50 + 80), , , , F
NEXT
     '    По бокам красные круги
CIRCLE My_Image(2), (0, 0), 8, RGBA(255, 80, 50, 128), , , , F
CIRCLE My_Image(2), (149, 0), 8, RGBA(255, 80, 50, 128), , , , F
CIRCLE My_Image(2), (0, 79), 8, RGBA(255, 80, 50, 128), , , , F
CIRCLE My_Image(2), (149, 79), 8, RGBA(255, 80, 50, 128), , , , F
DRAW STRING My_Image(2), (7, 36), "New alpha image!!!", RGBA(0, 0, 0, 128)
DRAW STRING My_Image(2), (5, 34), "New alpha image!!!", RGBA(100, 255, 40, 128)
     '    Далаем ресайз
My_Image(3) = ResizeIMG (My_Image(2), 300, 160, -1)
Dvig2 = 512
     '    Сохраняем изображение в *.BMP
SaveBMP ("TestIMG.bmp", My_Image(3))

   COLOR , RGB(100, 100, 100)             '   Цвет заднего фона
   SetMouse 320, 200, 0, 1                    '   Параметры мыши
     '    Основной цикл

DO
    ScreenLock                  '      Начало отрисовки
       CLS
          '    Полосатый экран
          FOR u = 1 TO 59 STEP 2
                LINE (0, u SHL 3)-(ScrXRez - 1, u SHL 3 + 7), &H454545, BF
          NEXT
          '    Текстовые надписи
          ShadowPrint 20, 20, "Simple graphics cursor DEMO", RGB(160, 255, 50)
          ShadowPrint 20, 40, "Load 32Bit Alpha BMP cursor", RGB(50, 160, 255)
          ShadowPrint 20, ScrYRez - 20, "Press ESCAPE  -  for EXIT", RGB(255, 140, 35)
          ShadowPrint 20, ScrYRez - 60, "Coord :" + STR(Mx) + ", " + STR(My), RGB(255, 70, 200)
       '    Возьмём коорд. мыши и нарисуем курсор.
       GetMouse Mx, My, , Btn
       MouCurDraw Btn AND 1
       PUT (245 + COS(Dvig / 162.815506783) * 100, 200 - SIN(Dvig / 162.815506783) * 100), My_Image(2), ALPHA
       PUT (170 + COS(Dvig2 / 162.815506783) * 100, 160 - SIN(Dvig2 / 162.815506783) * 100), My_Image(3), ALPHA
       Dvig = (Dvig + 2) AND 1023
       Dvig2 = (Dvig2 + 2) AND 1023
    ScreenUnlock             '       Конец отрисовки
    SLEEP 10, 1
LOOP UNTIL INKEY = CHR(27)        '     Выход по ESC
ImageDestroy( My_Image(0) )            '     Высвободим память
ImageDestroy( My_Image(1) )            '     Высвободим память


FUNCTION LoadBMP (BmName AS STRING) AS ANY POINTER
DIM NewIMG AS ANY POINTER, BmID AS SHORT
DIM AS INTEGER NewIMG_XRez, NewIMG_YRez
DIM SvBMF AS INTEGER
SvBMF = FREEFILE
IF NOT OPEN(BmName, FOR BINARY, ACCESS READ, AS #SvBMF) THEN
    GET #SvBMF, , BmID
    IF BmID = 19778 THEN
        GET #SvBMF, 19, NewIMG_XRez
        GET #SvBMF, , NewIMG_YRez
        IF NewIMG_XRez > 0 AND NewIMG_YRez > 0 THEN
           NewIMG = ImageCreate(NewIMG_XRez, NewIMG_YRez, , 32)
           BLOAD BmName, NewIMG
           LoadBMP = NewIMG
        END IF
    END IF
CLOSE #SvBMF
END IF
END FUNCTION

SUB SaveBMP (BmName AS STRING, IMG_Buff AS ANY POINTER)
DIM AS INTEGER  SImgRezX , SImgRezY, ImgSize, LineBytes
DIM WhereData AS BYTE PTR
DIM NewFHead AS BMFile, FHead AS BMFile, BmNameL AS STRING
DIM AS INTEGER  AdrAdd, SvBMF, ImY

   IMAGEINFO IMG_Buff, SImgRezX, SImgRezY, , LineBytes, WhereData, ImgSize
   NewFHead.FileSize = SImgRezX * SImgRezY SHL 2 + 54
   NewFHead.BmpSizeX = SImgRezX
   NewFHead.BmpSizeY = SImgRezY
   SvBMF = FREEFILE
   OPEN BmName FOR BINARY ACCESS WRITE AS SvBMF
   PUT #SvBMF, , NewFHead
        FOR ImY = SImgRezY - 1 TO 0 STEP -1 
             AdrAdd = LineBytes * ImY
             PUT #SvBMF, , *(WhereData + AdrAdd), SImgRezX SHL 2
        NEXT
   CLOSE SvBMF
END SUB

FUNCTION  ResizeIMG (OldPictureID AS ANY POINTER, NewSizeX AS INTEGER, NewSizeY AS INTEGER, NeedCreate AS SHORT) AS ANY POINTER
DIM NewIMG AS ANY POINTER
DIM OldSizeX AS INTEGER, OldSizeY AS INTEGER
DIM Tmp AS SINGLE, l AS INTEGER
DIM u AS SINGLE, t AS SINGLE
DIM AS SINGLE d1, d2, d3, d4
DIM AS UINTEGER p1, p2, p3, p4
DIM AS UBYTE RRed, RGrn, RBlu, RAlf
  '  Получим параметры старого изображения
  IMAGEINFO OldPictureID, OldSizeX, OldSizeY
  NewIMG = ImageCreate(NewSizeX, NewSizeY, , 32)   '  Создаём новое изображение

      FOR i = 0 TO NewSizeY - 1

           FOR j = 0 TO NewSizeX - 1

                  Tmp = i / (NewSizeY - 1) * (OldSizeY - 1)
                  l = FIX(Tmp)
                  IF l < 0 THEN
                      l = 0
                  ELSE
                      IF l >= OldSizeY - 1 THEN l = OldSizeY - 2
                  END IF
                  u = Tmp - l

                  Tmp = j / (NewSizeX - 1) * (OldSizeX - 1)
                  c = FIX(Tmp)
                  IF c < 0 THEN
                      c = 0
                  ELSE
                      IF c >= OldSizeX - 1 THEN c = OldSizeX - 2
                  END IF
                  t = Tmp - c

                  d1 = (1 - t) * (1 - u)
                  d2 = t * (1 - u)
                  d3 = t * u
                  d4 = (1 - t) * u

                  p1 = POINT(c, l, OldPictureID)
                  p2 = POINT(c + 1, l, OldPictureID)
                  p3 = POINT(c + 1, l + 1, OldPictureID)
                  p4 = POINT(c, l + 1, OldPictureID)

                  RBlu = (p1 AND 255) * d1 + (p2 AND 255) * d2 + (p3 AND 255) * d3 + (p4 AND 255) * d4
                  RGrn = ((p1 SHR 8) AND 255) * d1 + ((p2 SHR 8) AND 255) * d2 + ((p3 SHR 8) AND 255) * d3 + ((p4 SHR 8) AND 255) * d4
                  RRed = ((p1 SHR 16) AND 255) * d1 + ((p2 SHR 16) AND 255) * d2 + ((p3 SHR 16) AND 255) * d3 + ((p4 SHR 16) AND 255) * d4
                  RAlf = ((p1 SHR 24) AND 255) * d1 + ((p2 SHR 24) AND 255) * d2 + ((p3 SHR 24) AND 255) * d3 + ((p4 SHR 24) AND 255) * d4

                  PSET NewIMG, (j, i), RGBA(RRed, RGrn, RBlu, RAlf)
           NEXT j
      NEXT i

  '  Если необходимо создать новое изображение
  IF NeedCreate THEN
     ResizeIMG = NewIMG
  ELSE        '  Если ресайзим старое изображение
     ImageDestroy (OldPictureID)
     OldPictureID = NewIMG
  END IF
END FUNCTION

SUB ShadowPrint (x AS INTEGER, y AS INTEGER, StrOut AS STRING, Cv AS UINTEGER)
    DRAW STRING (x + 2, y + 2), StrOut, 0
    DRAW STRING (x, y), StrOut, Cv
END SUB

SUB MouCurDraw (CurNum AS USHORT)
      PUT (Mx - 6, My- 6), My_Image(CurNum), ALPHA
END SUB