Buchempfehlung
MySQL kurz & gut
MySQL kurz & gut
Das preiswerte Taschen- buch stellt MySQL-rele- vante Inhalte systematisch und knapp dar, sodass es sich optimal zum Nach- schlagen beim Pro- grammieren eignet. [Mehr Infos...]
FreeBASIC-Chat
Es sind Benutzer im FreeBASIC-Chat online.
(Stand:  )
FreeBASIC bei Twitter
Twitter FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!

fb:porticula NoPaste

Info
Info / Hilfe
Liste
Übersicht / Liste
Neu
Datei hochladen
Suche
Quellcode suchen
Download
Dateidownload

inc\imagefunctions.bas

Uploader:MitgliedEternal_Pain
Datum/Zeit:19.03.2014 04:38:16
Hinweis: Dieser Quelltext ist Bestandteil des Projekts Windows Easy Gui (WEG), zu dem es auf FreeBASIC-Portal.de eine Projektseite gibt.

'
'Jpg, Png, Gif, Bmp, Ico, Tif
'#Include once "windows.bi"
'#include once "win\gdiplus.bi"


'Namespace Globals
'    Dim as ULONG_PTR    gdiplusToken
'End Namespace

'Sub GDI_Plus_Init CONSTRUCTOR
'    'http://msdn.microsoft.com/en-us/library/windows/desktop/ms534077%28v=vs.85%29.aspx
'    Using GDIPLUS
'    Dim as GdiplusStartupInput gdiplusStartupInput 'The GdiplusStartupInput structure holds a block
                                                   'of arguments that are required by the GdiplusStartup
                                                   'function.

    '.GdiplusVersion | Type: UINT32 | Specifies the version of GDI+. Must be 1.
'    gdiplusStartupInput.GdiplusVersion = 1

'    If (GdiplusStartup(@Globals.gdiplusToken, @gdiplusStartupInput, NULL) <> 0) Then
'        ?"Fehler"
'    End If
'End Sub

'Sub GDI_Plus_Close DESTRUCTOR
'    Using GDIPLUS
'    GdiplusShutdown(Globals.gdiplusToken)
'End Sub

Declare Function CreateCopy_GDIImage_As_WINImage(byref GDIImage as any ptr) as HBITMAP
Declare Function CreateCopy_GDIImage_As_FBImage(byref GDIImage as any ptr) as any ptr

Declare Function CreateCopy_WINImage_As_GDIImage(byref WINImage as HBITMAP) as any ptr
Declare Function CreateCopy_WINImage_As_FBImage(byref WINImage as HBITMAP) as any ptr

Declare Function CreateCopy_FBImage_As_GDIImage(byref FBImage as any ptr) as any ptr
Declare Function CreateCopy_FBImage_As_WINImage(byref FBImage as any ptr) as HBITMAP

Declare Function LoadFBImage(byval Filename as String) as any ptr
Declare Function LoadGDIImage(byval Filename as String) as any ptr
Declare Function LoadWINImage(byval Filename as String, byval BackColor as Integer = &h000000) as HBITMAP

Declare Function SaveGDIImage(byref GDIImage as any ptr, byval Filename as String, byval itype as String = "AUTO") as Integer
Declare Function SaveWINImage(byref WINImage as HBITMAP, byval Filename as String, byval itype as String = "AUTO") as Integer
Declare Function SaveFBImage(byref FBImage as any ptr, byval Filename as String, byval itype as String = "AUTO") as Integer

Declare Function GetRect_From_FBImage(byref FBImage as any ptr, byval fromX as Integer, byval fromY as Integer, byval iWidth as Integer, byval iHeight as Integer) as any ptr
Declare Function GetRect_From_GDIImage(byref GDIImage as any ptr, byval fromX as Integer, byval fromY as Integer, byval iWidth as Integer, byval iHeight as Integer) as any ptr
Declare Function GetRect_From_WINImage(byref WINImage as HBITMAP, byval fromX as Integer, byval fromY as Integer, byval iWidth as Integer, byval iHeight as Integer) as HBITMAP


Function GetRect_From_FBImage(byref FBImage as any ptr, byval fromX as Integer, byval fromY as Integer, byval iWidth as Integer, byval iHeight as Integer) as any ptr
    Dim as any ptr CutImage = Imagecreate(iWidth, iHeight)
    Dim as Integer rWidth, rHeight
    Dim as Integer cWidth, cHeight

    If FBImage Then
        ImageInfo FBImage, rWidth, rHeight
        cWidth=iWidth : cHeight=iHeight
        If fromX+cWidth > rWidth Then cWidth = rWidth-fromX
        If fromY+cHeight > rHeight Then cHeight = rHeight-fromY

        Get FBImage,(fromX,fromY)-(fromX+cWidth-1,fromY+cHeight-1),CutImage
    End If
    return CutImage
End Function

Function GetRect_From_GDIImage(byref GDIImage as any ptr, byval fromX as Integer, byval fromY as Integer, byval iWidth as Integer, byval iHeight as Integer) as any ptr
    Using GDIPLUS
        Dim as GPBITMAP ptr CutImage
        GdipCloneBitmapArea (fromX, fromY, iWidth, iHeight, 0, GDIImage , @CutImage)
    Return CutImage
End Function

Function GetRect_From_WINImage(byref WINImage as HBITMAP, byval fromX as Integer, byval fromY as Integer, byval iWidth as Integer, byval iHeight as Integer) as HBITMAP
    Using GDIPLUS
        Dim as HBITMAP      CutImage
        Dim as GPBITMAP ptr TempImage1, TempImage2
        GdipCreateBitmapFromHBITMAP(WINImage, NULL, @TempImage1)
        GdipCloneBitmapArea (fromX, fromY, iWidth, iHeight, 0, TempImage1 , @TempImage2)
        GdipCreateHBITMAPFromBitmap(TempImage2 ,@CutImage, 0)
        GdipDisposeImage TempImage2
        GdipDisposeImage TempImage1
    Return CutImage
End Function

Function CreateCopy_GDIImage_As_FBImage(byref GDIImage as any ptr) as any ptr
    Using GDIPLUS
        Dim as any ptr      FBImage, pixels
        Dim as Integer      w, h, pitch
        Dim as BitmapData   ImageData
        Dim as UInteger ptr row
        Dim as RECT         rc

        If GDIImage = 0 Then Return 0

        GdipGetImageWidth(GDIImage, @w)
        GdipGetImageHeight(GDIImage, @h)

        rc = Type(0, 0, w-1, h-1)
        FBImage = ImageCreate(w,h)
        ImageInfo FBImage, ,,, pitch, pixels

        GdipBitmapLockBits(GDIImage,Cast(Any Ptr,@rc),ImageLockModeRead ,PixelFormat32bppARGB, @ImageData) ' Lock
            For y As Integer = 0 To h-1
                row = pixels + y * pitch
            For x As Integer = 0 To w-1
                row[x] = cast(Integer Ptr,ImageData.Scan0)[x+y*w]
            Next x
            Next y
        GdipBitmapUnlockBits(GDIImage,@ImageData) ' UnLock
        GdipDisposeImage(GDIImage)
    Return FBImage
End Function

Function CreateCopy_GDIImage_As_WINImage(byref GDIImage as any ptr) as HBITMAP
    Using GDIPLUS
        Dim as any ptr      Temp1, Temp2
        Dim as Integer      w,h, BackColor = &hFF00FF
        Dim as HBITMAP      hhbitmap

        If LOBYTE(LOWORD(GetVersion)) < 6 Then
            GdipGetImageWidth(GDIImage, @w)
            GdipGetImageHeight(GDIImage, @h)
            GdipCreateBitmapFromScan0(w, h, NULL, PixelFormat32bppARGB, NULL, @Temp1)
            GdipGetImageGraphicsContext(Temp1, @Temp2)
            GdipGraphicsClear(Temp2, BackColor or &hff000000)
            GdipDrawImageRectI(Temp2, GDIImage, 0, 0, w, h)
            GdipCreateHBITMAPFromBitmap(Temp1, @hhbitmap, BackColor or &hff000000)
            If Temp1 <> 0 Then GdipDisposeImage(Temp1)
            If Temp2 <> 0 Then GdipDeleteGraphics(Temp2)
        Else
            GdipCreateHBITMAPFromBitmap(GDIImage ,@hhBitmap, BackColor or &hff000000)
        End If
        GdipDisposeImage(GDIImage)
    Return hhbitmap
End Function


Function CreateCopy_WINImage_As_FBImage(byref WINImage as HBITMAP) as any ptr
    Using GDIPLUS
        Dim as GPBITMAP ptr Image = CreateCopy_WINImage_As_GDIImage(WINImage)
        Dim as any ptr      FBImage, pixels
        Dim as Integer      w, h, pitch
        Dim as BitmapData   ImageData
        Dim as UInteger ptr row
        Dim as RECT         rc

        GdipGetImageWidth(Image, @w)
        GdipGetImageHeight(Image, @h)

        rc = Type(0, 0, w-1, h-1)
        FBImage = ImageCreate(w,h)
        ImageInfo FBImage, ,,, pitch, pixels

        GdipBitmapLockBits(Image,Cast(Any Ptr,@rc),ImageLockModeRead ,PixelFormat32bppARGB, @ImageData) ' Lock
            For y As Integer = 0 To h-1
                row = pixels + y * pitch
            For x As Integer = 0 To w-1
                row[x] = cast(Integer Ptr,ImageData.Scan0)[x+y*w]
            Next x
            Next y
        GdipBitmapUnlockBits(Image,@ImageData) ' UnLock
        GdipDisposeImage(Image)
    Return FBImage
End Function


Function CreateCopy_WINImage_As_GDIImage(byref WINImage as HBITMAP) as any ptr
    Using GDIPLUS
        Dim as GPBITMAP ptr Image
        GdipCreateBitmapFromHBITMAP(WINImage, NULL, @Image)
        Return Image
End Function


Function CreateCopy_FBImage_As_WINImage(byref FBImage as any ptr) as HBITMAP
    Using GDIPLUS
        Dim as GPBITMAP ptr Image = CreateCopy_FBImage_As_GDIImage(FBImage)
        Dim as any ptr      Temp1, Temp2
        Dim as Integer      w,h, BackColor = &hFF00FF
        Dim as HBITMAP      hhbitmap

        If LOBYTE(LOWORD(GetVersion)) < 6 Then
            GdipGetImageWidth(Image, @w)
            GdipGetImageHeight(Image, @h)
            GdipCreateBitmapFromScan0(w, h, NULL, PixelFormat32bppARGB, NULL, @Temp1)
            GdipGetImageGraphicsContext(Temp1, @Temp2)
            GdipGraphicsClear(Temp2, BackColor or &hff000000)
            GdipDrawImageRectI(Temp2, Image, 0, 0, w, h)
            GdipCreateHBITMAPFromBitmap(Temp1, @hhbitmap, BackColor or &hff000000)
            If Temp1 <> 0 Then GdipDisposeImage(Temp1)
            If Temp2 <> 0 Then GdipDeleteGraphics(Temp2)
        Else
            GdipCreateHBITMAPFromBitmap(Image ,@hhBitmap, BackColor or &hff000000)
        End If
        GdipDisposeImage(Image)
    Return hhbitmap
End Function

Function CreateCopy_FBImage_As_GDIImage(byref FBImage as any ptr) as any ptr
    Using GDIPLUS
        Dim as GPBITMAP ptr Image
        Dim as any ptr      pixels
        Dim as Integer      w, h, pitch
        Dim as BitmapData   ImageData
        Dim as UInteger ptr row
        Dim as RECT         rc

        If FBImage = 0 Then Return 0

        ImageInfo FBImage, w, h,, pitch, pixels
        rc = Type(0, 0, w-1, h-1)
        GdipCreateBitmapFromScan0(w, h, NULL, PixelFormat32bppARGB, NULL, @Image)

        GdipBitmapLockBits(Image,Cast(Any Ptr,@rc),ImageLockModeWrite ,PixelFormat32bppARGB,@ImageData) ' Lock
            For y As Integer = 0 To h-1
                row = pixels + y * pitch
                For x As Integer = 0 To w-1
                    cast(Integer Ptr,ImageData.Scan0)[x+y*w] = IIf (row[x] = &hFFFF00FF,&h00000000,row[x])
                Next x
            Next y
        GdipBitmapUnlockBits(Image,@ImageData) ' UnLock
    Return Image
End Function




Function LoadFBImage(byval Filename as String) as any ptr
    Using GDIPLUS
        Dim as GPBITMAP ptr Image   = LoadGDIImage(Filename)
        Dim as any ptr      FBImage, pixels
        Dim as Integer      w, h, pitch
        Dim as BitmapData   ImageData
        Dim as UInteger ptr row
        Dim as RECT         rc

        If Image = 0 Then Return 0

        GdipGetImageWidth(Image, @w)
        GdipGetImageHeight(Image, @h)

        rc = Type(0, 0, w-1, h-1)
        FBImage = ImageCreate(w,h)
        ImageInfo FBImage, ,,, pitch, pixels

        GdipBitmapLockBits(Image,Cast(Any Ptr,@rc),ImageLockModeRead ,PixelFormat32bppARGB, @ImageData) ' Lock
            For y As Integer = 0 To h-1
                row = pixels + y * pitch
            For x As Integer = 0 To w-1
                row[x] = cast(Integer Ptr,ImageData.Scan0)[x+y*w]
            Next x
            Next y
        GdipBitmapUnlockBits(Image,@ImageData) ' UnLock
        GdipDisposeImage(Image)
    Return FBImage
End Function


Function LoadWINImage(byval Filename as String, byval BackColor as Integer = &h000000) as HBITMAP
    Using GDIPLUS
        Dim as GPBITMAP ptr Image = LoadGDIImage(Filename)
        Dim as any ptr      Temp1, Temp2
        Dim as Integer      w,h
        Dim as HBITMAP      hhbitmap

        If LOBYTE(LOWORD(GetVersion)) < 6 Then
            GdipGetImageWidth(Image, @w)
            GdipGetImageHeight(Image, @h)
            GdipCreateBitmapFromScan0(w, h, NULL, PixelFormat32bppARGB, NULL, @Temp1)
            GdipGetImageGraphicsContext(Temp1, @Temp2)
            GdipGraphicsClear(Temp2, BackColor or &hff000000)
            GdipDrawImageRectI(Temp2, Image, 0, 0, w, h)
            GdipCreateHBITMAPFromBitmap(Temp1, @hhbitmap, BackColor or &hff000000)
            If Temp1 <> 0 Then GdipDisposeImage(Temp1)
            If Temp2 <> 0 Then GdipDeleteGraphics(Temp2)
        Else
            GdipCreateHBITMAPFromBitmap(Image ,@hhBitmap, BackColor or &hff000000)
        End If
        GdipDisposeImage(Image)
    Return hhbitmap
End Function

Function LoadGDIImage(byval Filename as String) as any ptr
    Using GDIPLUS
        Dim as GPBITMAP ptr Image
        Dim as UInteger     FLen    =   (Len(Filename)*2)+2
        Dim as WString ptr  wbuf    =   allocate(FLen)

        MultiByteToWideChar(CP_ACP, 0, Filename, -1, wbuf, FLen)

        GDIPLOADIMAGEFROMFILE( *wbuf, @Image)
        Deallocate(wbuf)
    Return Image
End Function


Function SaveFBImage(byref FBImage as any ptr, byval Filename as String, byval itype as String = "AUTO") as Integer
    Using GDIPLUS
        Dim as any ptr TempImage = CreateCopy_FBImage_As_GDIImage(FBImage)
        Function = SaveGDIImage(TempImage, Filename, itype)
        GdipDisposeImage(TempImage)
End Function

Function SaveWINImage(byref WINImage as HBITMAP, byval Filename as String, byval itype as String = "AUTO") as Integer
    USING GDIPLUS
        Dim as GPBITMAP ptr TempImage = CreateCopy_WinImage_As_GDIImage(WINImage)
        Function = SaveGDIImage(TempImage, Filename, itype)
        GdipDisposeImage(TempImage)
End Function


Function SaveGDIImage(byref GDIImage as any ptr, byval Filename as String, byval itype as String = "AUTO") as Integer
    If GDIImage = 0 Then Return NOT(0)
    Using GDIPLUS
        Dim as String       clssid, fileext
        Dim as CLSID        classID
        Dim as Integer      flen   = (Len(Filename)*2)+2
        Dim as WString Ptr  wbuf

        If itype="AUTO" Then
            fileext = UCase(Right(Filename,4))
        Else
            fileext = UCase("." & itype)
        End If

        Select Case fileext
            Case ".BMP"
                clssid="{557CF400-1A04-11D3-9A73-0000F81EF32E}"
            Case ".JPG","JPEG"
                clssid="{557CF401-1A04-11D3-9A73-0000F81EF32E}"
            Case ".GIF"
                clssid="{557CF402-1A04-11D3-9A73-0000F81EF32E}"
            Case ".TIF","TIFF"
                clssid="{557CF405-1A04-11D3-9A73-0000F81EF32E}"
            Case ".PNG"
                clssid="{557CF406-1A04-11D3-9A73-0000F81EF32E}"
        End Select

        CLSIDFROMSTRING WSTR(clssid), @classID
        wbuf = allocate(flen)

        MultiByteToWideChar(CP_ACP, 0, Filename, -1, wbuf, flen)

        IF (GDIPSAVEIMAGETOFILE(GDIImage, *wbuf, @classID , 0) <> 0) Then
            Function = NOT(0)
        Else
            Function = 0
        End If

        deallocate(wbuf)
End Function