LOAD PNG TO IMAGE

New to FreeBASIC? Post your questions here.
UEZ
Posts: 335
Joined: May 05, 2017 19:59
Location: Germany

Re: LOAD PNG TO IMAGE

Postby UEZ » Jan 13, 2019 13:12

dodicat wrote:If you use windows, then keeping things as simple as possible, please try this.
Does other formats also.

Code: Select all

#if sizeof(integer)=8
#include "windows.bi"
#endif
#Include  "win/gdiplus.bi"

#include "file.bi"
'An idea from UEZ in another thread.
Function Pload(Picture as String,byref i as any ptr=0) as long
   Dim As uinteger TMP
   GDIPLUS.GdiplusStartup(@TMP,@type<GDIPLUS.GDIPLUSSTARTUPINPUT>(1),0)
   Dim as any Ptr Img
   if GDIPLUS.GdipLoadImageFromFile(Picture,@Img)>0 then return 0
   Dim As Single w,h
   GDIPLUS.GdipGetImageDimension(Img,@w,@h)
   if w*h=0 then return 0
   Dim As GDIPLUS.BitmapData Pdata
   Dim As Rect R=Type(0,0,w-1,h-1)
   GDIPLUS.GdipBitmapLockBits(Img,Cast(Any Ptr,@R),GDIPLUS.ImageLockModeRead,PixelFormat32bppARGB,@Pdata)
   For y as long = 0 To h-1
      For x as long = 0 To w-1
           pset i,(x,y),Cast(ulong Ptr,Pdata.Scan0)[y*w+x]
      Next
   Next
return w*h
End Function

sub getsize(picture as string,byref w as single,byref h as single) 'unused
    Dim As uinteger TMP
   GDIPLUS.GdiplusStartup(@TMP,@type<GDIPLUS.GDIPLUSSTARTUPINPUT>(1),0)
   Dim as any Ptr Img
   if GDIPLUS.GdipLoadImageFromFile(Picture,@Img)>0 then exit sub
   GDIPLUS.GdipGetImageDimension(Img,@w,@h)
end sub

screen 20,32
'get the desired image size and load the file to it
dim as single w,h

dim as string picture="bob.png"
if fileexists(picture)=0 then print picture + "  not found"
getsize(picture,w,h)

dim as any ptr i=imagecreate(w,h)
Pload(picture,i)
put(0,0),i,pset
sleep
imagedestroy i

 
 



Additionally, here the save function using GDIPlus:

Code: Select all

'Coded by UEZ build 2019-01-13

#Ifdef __Fb_64bit__
    #Inclib "gdiplus"
    #Include Once "win/gdiplus-c.bi"
#Else
    #Include Once "win/gdiplus.bi"
    Using gdiplus
#Endif


Declare Function ImageSave(Image As Any Ptr, Filename As Wstring, JPGQual As Ulong = 80) As Boolean

'' Create 32-Bit graphics Screen And image.
Dim As Ushort w = 640, h = 640, ww = 512, hh = 512
Screenres w, h, 32
Dim image As Any Ptr = Imagecreate(ww, hh)

Dim pitch As Integer
Dim pixels As Any Ptr

'' Get enough information To iterate through the pixel Data.
If 0 <> Imageinfo(image, ,,, pitch, pixels) Then
    Print "unable To retrieve image information."
    Sleep
    End
End If

'' Draw a pattern on the image by directly manipulating pixel memory.
For y As Integer = 0 To hh - 1
    Dim row As Ulong Ptr = pixels + y * pitch
    For x As Integer = 0 To ww - 1
        row[x] = Rgba(x Shl 1, y Shl 1, (x Xor y) Shl 1, 255 Xor (x Xor y))
    Next x
Next y

'' Draw the image onto the Screen.
Put ((w - ww) Shr 1, (h - hh) Shr 1), image

ImageSave(image, "Test.bmp")
ImageSave(image, "Test.gif")
ImageSave(image, "Test.jpg", 5)
ImageSave(image, "Test.png")
ImageSave(image, "Test.tif")


'' Destroy the image.
Imagedestroy image
? "Done."
Sleep

Function ImageSave(Image As Any Ptr, Filename As Wstring, JPGQual As Ulong = 80) As Boolean 'coded by UEZ
   Dim As Integer w, h, bypp, pitch
   Dim pixdata As Any Ptr
   If Imageinfo(Image, w, h, bypp, pitch, pixdata) <> 0 Then Return False
   
   #Define PixelGet(_x, _y)   (*Cptr(Ulong ptr, pixdata + (_y) * pitch + (_x) Shl 2))
   
   Dim GDIPlusStartupInput As GDIPLUSSTARTUPINPUT
   Dim As ULONG_PTR GDIPlusToken
   GDIPlusStartupInput.GdiplusVersion = 1   
   If (GdiplusStartup(@GDIPlusToken, @GDIPlusStartupInput, NULL) <> 0) Then Return 0
   Dim As Uinteger  x, y, RowOffset
   Dim As Any Ptr hBitmap
   Dim As BitmapData tBitmapData
   Dim As Rect tRect = Type(0, 0, w - 1, h - 1)
   GdipCreateBitmapFromScan0(w, h, 0, PixelFormat32bppARGB, 0, @hBitmap)
   GdipBitmapLockBits(hBitmap, Cast(Any Ptr, @tRect), ImageLockModeWrite, PixelFormat32bppARGB, @tBitmapData)
   For y = 0 To h - 1
      RowOffset = y * w
      For x = 0 To w - 1
         Cast(ULong Ptr, tBitmapData.Scan0)[RowOffset + x] = PixelGet(x, y)
      Next     
   Next
   GdipBitmapUnlockBits(hBitmap, @tBitmapData)
   
   Dim As Byte iErr = 0

   Dim As Ulong count, size
   GdipGetImageEncodersSize(@count, @size)
   
   Dim As CLSID clsid
   Dim As ImageCodecInfo Ptr pImageCodecInfo
   pImageCodecInfo = Allocate(size)
   GdipGetImageEncoders(count, size, pImageCodecInfo)
   
   #Define _MimeType(x)   (*Cast(Wstring Ptr, pImageCodecInfo[x].MimeType))
   #Define FnSuffix   (Right(Filename, 4))   
   
   For i As Ulong = 0 To count - 1
      If _MimeType(i) = "image/bmp" And FnSuffix = ".bmp" Then
         If (GdipSaveImageToFile(hBitmap, Wstr(Filename), @pImageCodecInfo[i].Clsid, NULL) <> 0) Then iErr += 1
      Elseif _MimeType(i) = "image/jpeg" And (FnSuffix = ".jpg" Or Right(Filename, 5) = ".jpeg") Then
         JPGQual = Iif(JPGQual < 0, 0, Iif(JPGQual > 100, 100, JPGQual))
         Dim tParams As EncoderParameters
         Dim EncoderQuality As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"
         tParams.Count = 1
         CLSIDFromString(Wstr(EncoderQuality), @tParams.Parameter(0).GUID)
         With tParams.Parameter(0)
            .NumberOfValues = 1
            .Type = EncoderParameterValueTypeLong
            .Value = Varptr(JPGQual)
         End With
         If GdipSaveImageToFile(hBitmap, Wstr(Filename), @pImageCodecInfo[i].Clsid, @tParams) <> 0 Then iErr += 1         
      Elseif _MimeType(i) = "image/gif" And FnSuffix = ".gif" Then
         If (GdipSaveImageToFile(hBitmap, Wstr(Filename), @pImageCodecInfo[i].Clsid, NULL) <> 0) Then iErr += 1
      Elseif _MimeType(i) = "image/tiff" And (FnSuffix = ".tif" Or Right(Filename, 5) = ".tiff") Then
         If (GdipSaveImageToFile(hBitmap, Wstr(Filename), @pImageCodecInfo[i].Clsid, NULL) <> 0) Then iErr += 1
      Elseif _MimeType(i) = "image/png" And FnSuffix = ".png" Then
         If (GdipSaveImageToFile(hBitmap, Wstr(Filename), @pImageCodecInfo[i].Clsid, NULL) <> 0) Then iErr += 1     
      Else
         iErr += 1
      End If
   Next

   Deallocate(pImageCodecInfo)

   GdipDisposeImage(hBitmap)
   GdiplusShutdown(GDIPlusToken)
   If iErr > 0 Then Return False

   Return True
End Function


Edit1: added 32-bit support

Return to “Beginners”

Who is online

Users browsing this forum: No registered users and 5 guests