FreeBasic

Данный пример преобразует фото в монохромное изображение. Был взят с сайта microsoft и адаптирован с языка C#. Так работает хорошо, но есть парочка вещей которые можно подделать при желании:

1. Пути к файлам для загрузки и сохранения лучше преобразовывать в Unicode (с помощью MultiByteToWideChar), а не как сделано в примере. Тогда появится возможность загружать и сохранять из любой папки. В примере только из папки с программой.
2. Скорость обработки можно существенно повысить, если не использовать GdipBitmapGetPixel , а вынимать цвета напрямую из палитры

Платформа: Windows
Автор: MicroSoft 
Переписано на FreeBasic: Станислав Будинов

'http://support.microsoft.com/kb/319061

#Undef Color
#INCLUDE "windows.bi"
#INCLUDE "win/gdiplus.bi"
#INCLUDE "crt.bi"

Declare Sub SaveGIFWithNewColorTable(Byval image As Any Ptr, Byval filename As String, Byval nColors As Integer, Byval fTransparent As Integer)

Type ColorPalette1
    Flags As UINT
    Count As UINT
    Entries(0 To 15) As Integer
End Type

Using GDIPLUS
Dim GDIPLUSSTARTUPINPUT As GDIPLUSSTARTUPINPUT
Dim As ULONG_PTR gdiplusToken

GDIPLUSSTARTUPINPUT.GdiplusVersion = 1
If (GdiplusStartup(@gdiplusToken, @GDIPLUSSTARTUPINPUT, NULL) <> 0) Then
    Print "FAIL"
Endif

Dim pic As Any Ptr
If (GdipLoadImageFromFile(Wstr("1.bmp"), @pic) <> 0) Then
    Print "FAIL"
Endif

SaveGIFWithNewColorTable(pic, "test.gif", 16, True)



Function GetColorPalette(Byval nColors As Integer) As ColorPalette1

    Dim bitscolordepth As PixelFormat = PixelFormat1bppIndexed
    Dim pal As ColorPalette1
    Dim bitmap As Any Ptr 
    Dim size As Integer

    If nColors > 16 Then
        bitscolordepth = PixelFormat8bppIndexed
    Elseif nColors > 2 Then
        bitscolordepth = PixelFormat4bppIndexed
    End If

    GdipCreateBitmapFromScan0(1, 1, NULL, bitscolordepth, NULL, @bitmap)
    GdipGetImagePaletteSize(bitmap,@size)
    GdipGetImagePalette(bitmap,Cast(Any Ptr,@pal),size)
    GdipDisposeImage bitmap

    Return pal          
End Function


Sub SaveGIFWithNewColorTable(Byval image As Any Ptr, Byval filename As String, Byval nColors As Integer, Byval fTransparent As Integer)

    If (nColors > 256) Then
        nColors = 256
    End If
    If nColors < 2 Then
        nColors = 2
    End If

    Dim Width_ As Integer
    GdipGetImageWidth(Image,@Width_)
    Dim Height As Integer
    GdipGetImageHeight(Image,@Height)

    Dim bitmap As Any Ptr
    GdipCreateBitmapFromScan0(Width_, Height, NULL,PixelFormat8bppIndexed , NULL, @bitmap)

    Dim pal As ColorPalette1 = GetColorPalette(nColors)
    Dim i As Integer

    For i = 0 To nColors - 1
        
        Dim Alpha_ As Uinteger = 255 
        Dim Intensity As Uinteger = i*255/(nColors-1) 
        Dim col As Color = Color(Alpha_, Intensity, Intensity, Intensity)

        If (i = 0 And fTransparent) Then    
            Alpha_ = 0                       
        End If
        pal.Entries(i) = Col.Argb_
        
    Next i

    GdipSetImagePalette(bitmap,Cast(Any Ptr,@pal))
    
    Dim As Any Ptr BmpCopy,g
    GdipCreateBitmapFromScan0(Width_, Height, NULL,PixelFormat32bppArgb , NULL, @BmpCopy)
    GdipGetImageGraphicsContext(BmpCopy,@g)
    GdipSetPageUnit(g,UnitPixel)
    GdipDrawImageRect(g,image,0,0,width_,height)
    GdipDeleteGraphics(g)

    Dim As BitmapData  bitmapData
    Dim As RECT  rect = Type(0, 0, Width_, Height)

    GdipBitmapLockBits(bitmap,Cast(Any Ptr,@rect),IMAGELOCKMODE.IMAGELOCKMODEWRITE,PixelFormat8bppIndexed,@bitmapData)

    Dim As Integer Ptr pixels = bitmapData.Scan0
    Dim As Byte Ptr  pBits
    
    If (bitmapData.Stride > 0) Then
        pBits = Cast(Byte Ptr,pixels)
    Else
        pBits = Cast(Byte Ptr,pixels) + bitmapData.Stride*(Height-1)
    Endif

    Dim As UINT stride = Cast(uint,Abs(bitmapData.Stride))

    For row As UINT = 1 To Height

        For col As UINT = 1 To Width_

            Dim As Color     pixel 
            Dim As Byte Ptr    p8bppPixel = pBits + (row-1)*stride + col-1
            Dim As Integer Color_
            
            GdipBitmapGetPixel(BmpCopy,col,row,@Color_)
            pixel.argb_ = Color_

            Dim As Double luminance = (pixel.GetR *0.299) + _
            (pixel.GetG *0.587) + _
            (pixel.GetB *0.114)

            *p8bppPixel = Cast(Byte,(luminance * (nColors-1)/255 +0.5))

        Next
        
    Next

    GdipBitmapUnlockBits(bitmap,@bitmapData)

    Dim clssid As String ="{557CF406-1A04-11D3-9A73-0000F81EF32E}"
    Dim CLSID_01 As CLSID
    CLSIDFROMSTRING Wstr(clssid), @CLSID_01

    If (GdipSaveImageToFile(bitmap, Wstr(filename), @CLSID_01, 0) = 0) Then
        Print "image saved successfully."
    Endif

    GdipDisposeImage BmpCopy
    GdipDisposeImage bitmap

End Sub