GDIPlus ASCII GIF Anim Player.bas
Code: Select all
'Coded by UEZ build 2019-02-15
#Include "file.bi"
#Include "fbgfx.bi"
#Include "windows.bi"
#Include "win\wininet.bi"
#Ifdef __Fb_64bit__
#Inclib "gdiplus"
#Include "win/gdiplus-c.bi"
#Else
#Include "win/gdiplus.bi"
Using gdiplus
#Endif
Using FB
Function _GDIPlus_BitmapCreateFromMemory3(aBinImage As Ubyte Ptr, iLen As Ulong, bBitmap_GDI As Bool = False) As Any Ptr
Dim As HGLOBAL hGlobal
Dim As LPSTREAM hStream
Dim As Any Ptr hImage_Stream
Dim As Any Ptr hMemory = GlobalAlloc(GMEM_MOVEABLE, iLen)
Dim As Any Ptr lpMemory = GlobalLock(hMemory)
RtlCopyMemory(lpMemory, @aBinImage[0], iLen)
GlobalUnlock(hMemory)
CreateStreamOnHGlobal(hMemory, 0, @hStream)
GdipCreateBitmapFromStream(hStream, @hImage_Stream)
IUnknown_Release(hStream)
If bBitmap_GDI = TRUE Then
Dim hImage_GDI As Any Ptr
GdipCreateHBITMAPFromBitmap(hImage_Stream, @hImage_GDI, &hFF000000)
GdipDisposeImage(hImage_Stream)
Return hImage_GDI
Endif
Return hImage_Stream
End Function
Function LoadDataFromINet(sUrl As String, Byref iSize As Ulong) As Byte Ptr
Dim As HINTERNET hOpen = InternetOpen("FB Downloader", INTERNET_OPEN_TYPE_DIRECT, NULL, NULL, INTERNET_FLAG_NO_COOKIES Or INTERNET_FLAG_NO_UI Or INTERNET_FLAG_PRAGMA_NOCACHE Or INTERNET_FLAG_SECURE), _
hFile = InternetOpenUrl(hOpen, sURL, NULL, 0, INTERNET_FLAG_EXISTING_CONNECT, 0)
Dim As Ulong iBuffLen = 32, iBytes = 1
Dim As String sBuff = Space(32)
HttpQueryInfo(hFile, HTTP_QUERY_CONTENT_LENGTH, StrPtr(sBuff), @iBuffLen, NULL)
iBuffLen = Valint(Trim(sBuff))
Dim As Byte Ptr imgBuffer
If iBuffLen > 0 Then
imgBuffer = Allocate(iBuffLen)
Do Until iBytes = 0
InternetReadFile(hFile, imgBuffer, iBuffLen, @iBytes)
Loop
Endif
InternetCloseHandle(hFile)
InternetCloseHandle(hOpen)
iSize = iBuffLen
Return imgBuffer
End Function
Function _GDIPlus_ImageSaveToFile(hImage As Any Ptr, Filename As Wstring, JPGQual As Ulong = 85) As Boolean
'check If hImage Is a GDI+ image
Dim As Single iW, iH
If GdipGetImageDimension(hImage, @iW, @iH) <> 0 Then Return 0
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(hImage, Wstr(Filename), @pImageCodecInfo[i].Clsid, NULL) <> 0) Then iErr += 1
Elseif _MimeType(i) = "image/jpeg" And (FnSuffix = ".jpg" Or FnSuffix = ".jpe" Or Right(Filename, 5) = ".jpeg" Or Right(Filename, 5) = ".jfif") 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(hImage, Wstr(Filename), @pImageCodecInfo[i].Clsid, @tParams) <> 0 Then iErr += 1
Elseif _MimeType(i) = "image/gif" And FnSuffix = ".gif" Then
If (GdipSaveImageToFile(hImage, 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(hImage, Wstr(Filename), @pImageCodecInfo[i].Clsid, NULL) <> 0) Then iErr += 1
Elseif _MimeType(i) = "image/png" And FnSuffix = ".png" Then
If (GdipSaveImageToFile(hImage, Wstr(Filename), @pImageCodecInfo[i].Clsid, NULL) <> 0) Then iErr += 1
Else
iErr += 1
End If
Next
Deallocate(pImageCodecInfo)
If iErr > 0 Then Return False
Return True
End Function
Function _GDIPlus_BitmapScale(hImage As Any Ptr, fScaleX As Single, fScaleY As Single, iInterpolationMode As Ubyte = InterpolationModeHighQualityBicubic) As Any Ptr
Dim As Single iW, iH, fW, fH
GdipGetImageDimension(hImage, @iW, @iH)
If iW = 0 Or iH = 0 Then Return 0
fW = iW * fScaleX
fH = iH * fScaleY
Dim As Any Ptr hBitmap_Scaled, hGfx_Scaled
GdipCreateBitmapFromScan0(fW, fH, 0, PixelFormat32bppARGB, 0, @hBitmap_Scaled)
GdipGetImageGraphicsContext(hBitmap_Scaled, @hGfx_Scaled)
'GdipSetCompositingQuality(hGfx_Scaled, 2)
GdipSetPixelOffsetMode(hGfx_Scaled, PixelOffsetModeHighQuality)
GdipSetInterpolationMode(hGfx_Scaled, iInterpolationMode)
GdipDrawImageRectRect(hGfx_Scaled, hImage, 0, 0, fW, fH, 0, 0, iW, iH, 2, 0, 0, 0)
GdipDeleteGraphics(hGfx_Scaled)
Return hBitmap_Scaled
End Function
Function _GDIPlus_BitmapResize(hImage As Any Ptr, iNewW As Ushort, iNewH As Ushort, iInterpolationMode As Ubyte = InterpolationModeHighQualityBicubic) As Any Ptr
Dim As Single iW, iH
GdipGetImageDimension(hImage, @iW, @iH)
If iW = 0 Or iH = 0 Then Return 0
Dim As Any Ptr hBitmap_Resized, hGfx_Resized
GdipCreateBitmapFromScan0(iNewW, iNewH, 0, PixelFormat32bppARGB, 0, @hBitmap_Resized)
GdipGetImageGraphicsContext(hBitmap_Resized, @hGfx_Resized)
'GdipSetCompositingQuality(hGfx_Resized, 2)
GdipSetPixelOffsetMode(hGfx_Resized, PixelOffsetModeHighQuality)
GdipSetInterpolationMode(hGfx_Resized, iInterpolationMode)
GdipDrawImageRectRect(hGfx_Resized, hImage, 0, 0, iNewW, iNewH, 0, 0, iW, iH, 2, 0, 0, 0)
GdipDeleteGraphics(hGfx_Resized)
Return hBitmap_Resized
End Function
Function _GDIPlus_BitmapCreateGreyscale(hImage As Any Ptr) As Any Ptr
Dim As Single iW, iH
GdipGetImageDimension(hImage, @iW, @iH)
If iW = 0 Or iH = 0 Then Return 0
Dim As Any Ptr hBitmap_Greyscale
Dim As BitmapData tBitmapData, tBitmapData_Greyscale
Dim As Long iX, iY, iRowOffset, iColor, c, iR, iG, iB
Dim As Rect tRect = Type(0, 0, iW - 1, iH - 1)
GdipCreateBitmapFromScan0(iW, iH, 0, PixelFormat32bppARGB, 0, @hBitmap_Greyscale)
GdipBitmapLockBits(hBitmap_Greyscale, Cast(Any Ptr, @tRect), ImageLockModeWrite, PixelFormat32bppARGB, @tBitmapData_Greyscale)
GdipBitmapLockBits(hImage, Cast(Any Ptr, @tRect), ImageLockModeRead, PixelFormat32bppARGB, @tBitmapData)
For iY = 0 To iH - 1
iRowOffset = iY * iW
For iX = 0 To iW - 1
iColor = Cast(ULong Ptr, tBitmapData.Scan0)[iRowOffset + iX]
iR = (iColor Shr 16) And &hFF
iG = (iColor Shr 8) And &hFF
iB = iColor And &hFF
c = Culng((iR * 213 + iG * 715 + iB * 72) / 1000)
Cast(ULong Ptr, tBitmapData_Greyscale.Scan0)[iRowOffset + iX] = &hFF000000 + (c Shl 16) + (c Shl 8) + c
Next
Next
GdipBitmapUnlockBits(hBitmap_Greyscale, @tBitmapData_Greyscale)
GdipBitmapUnlockBits(hImage, @tBitmapData)
Return hBitmap_Greyscale
End Function
Function _GDIPlus_BitmapCreateBW(hImage As Any Ptr, iThreshold As Ubyte = &h80) As Any Ptr
Dim As Single iW, iH
Dim As Any Ptr hBitmap_BW
Dim As BitmapData tBitmapData, tBitmapData_BW
Dim As Long iX, iY, iRowOffset, iColor, iR, iG, iB
GdipGetImageDimension(hImage, @iW, @iH)
Dim As Rect tRect = Type(0, 0, iW - 1, iH - 1)
GdipCreateBitmapFromScan0(iW, iH, 0, PixelFormat32bppARGB, 0, @hBitmap_BW)
GdipBitmapLockBits(hBitmap_BW, Cast(Any Ptr, @tRect), ImageLockModeWrite, PixelFormat32bppARGB, @tBitmapData_BW)
GdipBitmapLockBits(hImage, Cast(Any Ptr, @tRect), ImageLockModeRead, PixelFormat32bppARGB, @tBitmapData)
For iY = 0 To iH - 1
iRowOffset = iY * iW
For iX = 0 To iW - 1
iColor = Cast(ULong Ptr, tBitmapData.Scan0)[iRowOffset + iX]
iR = (iColor Shr 16) And &hFF
iG = (iColor Shr 8) And &hFF
iB = iColor And &hFF
If Clng((iR + iG + iB) / 3) >= iThreshold Then
Cast(ULong Ptr, tBitmapData_BW.Scan0)[iRowOffset + iX] = &hFFFFFFFF
Else
Cast(ULong Ptr, tBitmapData_BW.Scan0)[iRowOffset + iX] = &hFF000000
End If
Next
Next
GdipBitmapUnlockBits(hBitmap_BW, @tBitmapData_BW)
GdipBitmapUnlockBits(hImage, @tBitmapData)
Return hBitmap_BW
End Function
Function _GDIPlus_BitmapConvert2ASCII(hImage As Any Ptr, iCharSize As Single = 8.0, iColorMode As Ubyte = 0, bInverted As Bool = False) As Any Ptr
Dim As Single iW, iH
GdipGetImageDimension(hImage, @iW, @iH)
If iW = 0 Or iH = 0 Then Return 0
Dim As Any Ptr hBitmap_ASCII, hBitmap_Scaled, hBitmap_Resized, hBitmap_Grey, hGFX_ASCII, hBrush_ASCII, hFamily, hFont, hStringFormat
hBitmap_Scaled = _GDIPlus_BitmapScale(hImage, 1 / iCharSize, 1 / iCharSize)
hBitmap_Resized = _GDIPlus_BitmapResize(hBitmap_Scaled, iW, iH, InterpolationModeNearestNeighbor)
hBitmap_Grey = _GDIPlus_BitmapCreateGreyscale(hBitmap_Resized)
GdipCreateBitmapFromScan0(iW, iH, 0, PixelFormat32bppARGB, 0, @hBitmap_ASCII)
GdipGetImageGraphicsContext(hBitmap_ASCII, @hGFX_ASCII)
GdipGraphicsClear(hGFX_ASCII, Iif(bInverted, &hFF000000, &hFFFFFFFF))
GdipSetSmoothingMode(hGFX_ASCII, SmoothingModeAntiAlias)
GdipSetPixelOffsetMode(hGFX_ASCII, PixelOffsetModeHalf)
GdipSetTextRenderingHint(hGFX_ASCII, TextRenderingHintAntiAlias)
GdipCreateStringFormat(0, 0, @hStringFormat)
GdipCreateFontFamilyFromName("Lucida Console", Null, @hFamily)
GdipCreateFont(hFamily, iCharSize, 1, 3, @hFont)
GdipCreateSolidFill(Iif(bInverted, &hFFFFFFFF, &hFF000000), @hBrush_ASCII)
#Define Map(n, s, e, ns, ne) (ns - (ns - ne) * (n / (e - s)))
Dim As Rect tRect = Type(0, 0, iW - 1, iH - 1)
Dim As BitmapData tBitmapData_Grey, tBitmapData_Resized
GdipBitmapLockBits(hBitmap_Grey, Cast(Any Ptr, @tRect), ImageLockModeRead, PixelFormat32bppARGB, @tBitmapData_Grey)
GdipBitmapLockBits(hBitmap_Resized, Cast(Any Ptr, @tRect), ImageLockModeRead, PixelFormat32bppARGB, @tBitmapData_Resized)
Dim As ULong iX, iY, iRowOffset, col, x, y
Dim as GpRectF tLayout
Dim As String aChars(0 To ...) = {"#", "@", "%", "X", "x", "o", "+", "=", "~", "-", ";", ":", ",", "." , " "}
tLayout.width = iCharSize * 1.666
tLayout.height = iCharSize * 1.666
iColorMode = Iif(iColorMode > 2, 2, iColorMode)
For iY = 0 To (iH - iCharSize) Step iCharSize
For iX = 0 To (iW - iCharSize) Step iCharSize
x = iX + iCharSize \ 2
y = (iY + iCharSize \ 2) * iW
col = Cast(ULong Ptr, tBitmapData_Grey.Scan0)[y + x] And &hFF
tLayout.x = iX
tLayout.y = iY
Select Case iColorMode
Case 0 'b/w
'brush already defined above
Case 1 'color
GdipSetSolidFillColor(hBrush_ASCII, Iif(bInverted, &hFFFFFF Xor Cast(ULong Ptr, tBitmapData_Resized.Scan0)[y + x], Cast(ULong Ptr, tBitmapData_Resized.Scan0)[y + x]))
Case 2 'greyscale
col = Iif(bInverted, col Xor &hFF, col)
GdipSetSolidFillColor(hBrush_ASCII, &hFF000000 Or col Shl 16 Or col Shl 8 Or col)
End Select
GdipDrawString(hGFX_ASCII, aChars(Map(col, 0, 255, 0, Ubound(aChars))), -1, hFont, @tLayout, hStringFormat, hBrush_ASCII)
Next
Next
GdipBitmapUnlockBits(hBitmap_ASCII, @tBitmapData_Grey)
GdipBitmapUnlockBits(hBitmap_ASCII, @tBitmapData_Resized)
GdipDisposeImage(hBitmap_Scaled)
GdipDisposeImage(hBitmap_Resized)
GdipDisposeImage(hBitmap_Grey)
GdipDeleteFont(hFont)
GdipDeleteFontFamily(hFamily)
GdipDeleteStringFormat(hStringFormat)
GdipDeleteBrush(hBrush_ASCII)
GdipDeleteGraphics(hGFX_ASCII)
Return hBitmap_ASCII
End Function
'decode animated GIF and select frame
Function _GDIPlus_GIFAnimGetFrameDimensionsCount(hImage As Any Ptr) As Ulong
Dim As Ulong iFrameDimCount
GdipImageGetFrameDimensionsCount(hImage, @iFrameDimCount)
Return iFrameDimCount
End Function
Function _GDIPlus_GIFAnimGetFrameDimensionsList(hImage As Any Ptr, iFrameDimCount As Ulong) As GUID
Dim As GUID FrameDimList
GdipImageGetFrameDimensionsList(hImage, @FrameDimList, iFrameDimCount)
Return FrameDimList
End Function
Function _GDIPlus_GIFAnimGetFrameCount(hImage As Any Ptr, tFrameDimList As GUID) As Ulong
Dim As Ulong iFrameCount
GdipImageGetFrameCount(hImage, @tFrameDimList, @iFrameCount)
Return iFrameCount
End Function
Sub _GDIPlus_GIFAnimSelectActiveFrame(hImage As Any Ptr, tFrameDimList As GUID, iCurrentFrame As Ulong)
GdipImageSelectActiveFrame(hImage, @tFrameDimList, iCurrentFrame)
End Sub
Function _GDIPlus_ImageGetPropertyItem(hImage As Any Ptr, iPropID As PROPID) As PropertyItem Ptr
Dim As Ulong iSize
GdipGetPropertyItemSize(hImage, iPropID, @iSize)
Dim As PropertyItem Ptr buffer
buffer = Allocate(iSize * SizeOf(PropertyItem))
GdipGetPropertyItem(hImage, iPropID, iSize, @buffer[0])
Return buffer
End Function
Sub _GDIPlus_GIFAnimGetFrameDelays(hImage As Any Ptr, iAnimFrameCount As Ulong, aFrameDelay() As Ulong)
Dim As PropertyItem Ptr PropItem = _GDIPlus_ImageGetPropertyItem(hImage, PROPERTYTAGFRAMEDELAY)
Select Case PropItem->type
Case 1
Dim As Ubyte Ptr delay = PropItem->value
For i As Ulong = 0 To Ubound(aFrameDelay)
aFrameDelay(i) = delay[i] * 10
Next
Case 3
Dim As Ushort Ptr delay = PropItem->value
For i As Ulong = 0 To Ubound(aFrameDelay)
aFrameDelay(i) = delay[i] * 10
Next
Case 4
Dim As Ulong Ptr delay = PropItem->value
For i As Ulong = 0 To Ubound(aFrameDelay)
aFrameDelay(i) = delay[i] * 10
Next
End Select
End Sub
Dim Shared gdipToken As ULONG_PTR
Dim Shared GDIp As GdiplusStartupInput
GDIp.GdiplusVersion = 1
If GdiplusStartup(@gdipToken, @GDIp, NULL) <> 0 Then End
Dim As Single iW, iH
Dim As Any Ptr hCanvas, hImage, hImage_ASCII
Dim As String sURL = "https://i.gifer.com/17YK.gif", sFilename = Curdir & "\17YK.gif" 'https://gifer.com/en/
If Fileexists(sFilename) = -1 Then
'local loa
GdipLoadImageFromFile(sFilename, @hImage)
Else
If Messagebox(0, "Do you agree to download an image from internet?", "Information", MB_ICONQUESTION or MB_YESNO) = 7 Then
Messagebox(0, "This demo requires an image. Please enable code line to load from local disk and disable code for download! Do not forget to adjust the path to the image!", "Information", MB_ICONWARNING)
GdiplusShutdown(gdipToken)
End
End If
'internet load
Dim As Ulong iSize
Dim As Byte Ptr binImg = LoadDataFromINet(sURL, iSize)
Dim As Integer hFile = FreeFile()
Open sFilename For Binary Access Write As #hFile
Put #hFile, 0, binImg[0], iSize
Close #hFile
hImage = _GDIPlus_BitmapCreateFromMemory3(binImg, iSize)
Deallocate binImg
Endif
GdipGetImageDimension(hImage, @iW, @iH)
If iW = 0 Then
GdiplusShutdown(gdipToken)
Messagebox(0, "Something went wrong to download the GIF animation!", "ERROR", 16)
End
End If
Screencontrol SET_DRIVER_NAME, "GDI"
Screenres iW, iH, 32, 1, GFX_HIGH_PRIORITY Or GFX_NO_SWITCH
Windowtitle "GDIPlus ASCII GIF Anim Player by UEZ"
Dim As Integer iDW, iDH
Screencontrol GET_DESKTOP_SIZE, iDW, iDH
Dim tWorkingArea As RECT
SystemParametersInfo(SPI_GETWORKAREA, null, @tWorkingArea, null)
Screencontrol SET_WINDOW_POS, (iDW - iW) \ 2, ((tWorkingArea.Bottom - iH) - (iDH - tWorkingArea.Bottom)) \ 2
Dim As HWND hHWND
Screencontrol(GET_WINDOW_HANDLE, Cast(Integer, hHWND))
Dim As Any Ptr hDC = GetDC(hHWND), _
hHBitmap = CreateCompatibleBitmap(hDC, iW, iH), _
hDC_backbuffer = CreateCompatibleDC(hDC), _
hDC_obj = SelectObject(hDC_backbuffer, hHBitmap)
GdipCreateFromHDC(hDC_backbuffer, @hCanvas)
Dim As Ulong iFrame = 0, iFrameDimCount = _GDIPlus_GIFAnimGetFrameDimensionsCount(hImage)
Dim As GUID tFrameDimList = _GDIPlus_GIFAnimGetFrameDimensionsList(hImage, iFrameDimCount)
Dim As Ulong iFrames = _GDIPlus_GIFAnimGetFrameCount(hImage, tFrameDimList)
Dim As Ulong aFrameDelays(0 To iFrames - 1)
Dim As Any Ptr aFrames(0 To iFrames - 1)
Dim As Bool bInverted = False
Dim As Byte bLMB = 1
? "Please wait while frames will be buffered!"
'render all frames to save CPU usage later in the loop
For i As Ulong = 0 To Ubound(aFrames)
_GDIPlus_GIFAnimSelectActiveFrame(hImage, tFrameDimList, i)
aFrames(i) = _GDIPlus_BitmapConvert2ASCII(hImage, 8, 1, bInverted)
Next
_GDIPlus_GIFAnimGetFrameDelays(hImage, iFrames, aFrameDelays())
Dim evt As Event
Do
_GDIPlus_GIFAnimSelectActiveFrame(hImage, tFrameDimList, iFrame)
If bLMB = 1 Then
GdipDrawImageRect(hCanvas, aFrames(iFrame), 0, 0, iW, iH)
Else
GdipGraphicsClear(hCanvas, Iif(bInverted, &hFF000000, &hFFFFFFFF)) 'visible only for transparent animated GIFs
GdipDrawImageRect(hCanvas, hImage, 0, 0, iW, iH)
End If
BitBlt(hDC, 0, 0, iW, iH, hDC_backbuffer, 0, 0, SRCCOPY)
Sleep aFrameDelays(iFrame)
Windowtitle "Frame: " & iFrame + 1 & " / " & iFrames
iFrame += 1
iFrame = Iif(iFrame > iFrames - 1, 0, iFrame)
If (Screenevent(@evt)) Then
Select Case evt.Type
Case EVENT_KEY_PRESS
If evt.scancode = SC_ESCAPE Then Exit Do
Case EVENT_WINDOW_CLOSE
Exit Do
Case EVENT_MOUSE_BUTTON_PRESS
If evt.button = BUTTON_LEFT Then bLMB *= -1
End Select
Endif
Loop
For i As Ulong = 0 To Ubound(aFrames)
GdipDisposeImage(aFrames(i))
Next
SelectObject(hDC_backbuffer, hDC_obj)
DeleteDC(hDC_backbuffer)
DeleteObject(hHBitmap)
ReleaseDC(hHWND, hDC)
GdipDeleteGraphics(hCanvas)
GdipDisposeImage(hImage)
GdipDisposeImage(hImage_ASCII)
GdiplusShutdown(gdipToken)
To do: