1) GDI+ Image Painting1.bas
Code: Select all
'Coded by UEZ build 2019-02-08
'Windows only!
'Original idea (Crazy Painter) by Daniel Wyllie
#Include "fbgfx.bi"
#Include "windows.bi"
#Include "vbcompat.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
Declare Function Brightness(iColor As Ulong) As Single
Declare Function RandomRange(fStart as Single, fEnd as Single) as Single
Declare Function _GDIPlus_ImageSaveToFile(hImage As Any Ptr, Filename As Wstring, JPGQual As Ulong = 85) As Boolean
Declare Function _GDIPlus_BitmapCreateFromMemory3(aBinImage As Ubyte Ptr, iLen As Ulong, bBitmap_GDI As Bool = False) As Any Ptr
Declare Function LoadDataFromINet(sUrl As String, Byref iSize As Integer) As Byte Ptr
#Define _Max(a, b) (Iif(a > b, b, a))
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)
End
End If
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, iPixel, iRowOffset
Dim As Any Ptr hImage
'load image from internet
Dim As Integer iSize
Dim As Byte Ptr binImg = LoadDataFromINet("https://www.noz.de/article/teaser/1395114/full", iSize)
hImage = _GDIPlus_BitmapCreateFromMemory3(binImg, iSize)
Deallocate binImg
'for local files
'GdipLoadImageFromFile("Test.jpg", @hImage)
GdipGetImageDimension(hImage, @iW, @iH)
If iW = 0 Then
GdiplusShutdown(gdipToken)
Messagebox(0, "Something went wrong to download the image!", "ERROR", 16)
End
End If
'read all colors to an array for faster access
Dim As ULong aColors(0 To iH - 1, 0 To iW - 1), iX, iY, iARGB
For iY = 0 To iH - 1
For iX = 0 To iW - 1
GdipBitmapGetPixel(hImage, iX, iY, @iARGB)
aColors(iY, iX) = iARGB
Next
Next
Dim As String sTitle = "GDIPlus Image Painting 1 Demo / FPS: "
Dim As UShort iFPS = 0
Dim As Double fTimer
Dim evt As Event
Screencontrol SET_DRIVER_NAME, "GDI"
Screenres iW, iH, 32, 1, GFX_HIGH_PRIORITY Or GFX_NO_SWITCH
Windowtitle sTitle
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), _
hCanvas, hPen, hBrush, hBitmap
GdipCreateFromHDC(hDC_backbuffer, @hCanvas)
GdipSetSmoothingMode(hCanvas, SmoothingModeAntiAlias)
GdipSetPixelOffsetMode(hCanvas, PixelOffsetModeHalf)
GdipCreateSolidFill(&hFFFF0000, @hBrush)
GdipCreatePen1(&hFF00FF00, 1, 2, @hPen)
Randomize(, 2)
Type tPoint
As Single x, y
End Type
Dim As tPoint aPoints(4)
For i As Ubyte = 0 To 3
aPoints(i).x = Rnd() * iW / 4
aPoints(i).y = Rnd() * iH / 4
Next
Dim As Ulong ca, cb, cc, cd, iAmount = _Max(iW, iH) / 12
Dim As Single ba, bb, bc, bd, f, g = iAmount / 4, fSize
Dim As Integer mx, my, mb
fTimer = Timer
Do
Getmouse mx, my, , mb
mx += 1
my += 1
For k As UShort = 1 To iAmount
For i As Ubyte = 0 To 3
If aPoints(i).x < 0 Then aPoints(i).x = 0
If aPoints(i).y < 0 Then aPoints(i).y = 0
If aPoints(i).x > iW - 1 Then aPoints(i).x = iW - 1
If aPoints(i).y > iH - 1 Then aPoints(i).y = iH - 1
Next
ca = aColors(aPoints(0).y, aPoints(0).x)
cb = aColors(aPoints(1).y, aPoints(1).x)
cc = aColors(aPoints(2).y, aPoints(2).x)
cd = aColors(aPoints(3).y, aPoints(3).x)
ba = Brightness(ca): bb = Brightness(cb): bc = Brightness(cc): bd = Brightness(cd)
If ba - bb < 50 And bb - bc < 50 And bc - bd < 50 Then
GdipCreateHatchBrush(12, &hE0FFFFFF And cc, &hA0FFFFFF And cb, @hBrush)
GdipSetPenBrushFill(hPen, hBrush)
GdipSetPenWidth(hPen, my / 50)
'GdipSetPenColor(hPen, &hE0FFFFFF And cc)
GdipDrawBezier(hCanvas, hPen, aPoints(0).x, aPoints(0).y, aPoints(1).x, aPoints(1).y, aPoints(2).x, aPoints(2).y, aPoints(3).x, aPoints(3).y)
fSize = ba / g
f = fSize / 2
GdipFillEllipse(hCanvas, hBrush, aPoints(0).x - f, aPoints(0).y - f, fSize, fSize)
GdipDeleteBrush(hBrush)
'GdipSetSolidFillColor(hBrush, &hE0FFFFFF And cc)
'GdipFillEllipse(hCanvas, hBrush, aPoints(0).x - ba / 40, aPoints(0).y - ba / 40, ba / 20, ba / 20)
GdipSetPenColor(hPen, &hE0FFFFFF And cb)
GdipSetPenWidth(hPen, 2)
GdipDrawEllipse(hCanvas, hPen, aPoints(0).x - f, aPoints(0).y - f, fSize, fSize)
End If
aPoints(0).x = Rnd() * iW
aPoints(0).y = Rnd() * iH
f = mx / 10
aPoints(1).x = aPoints(0).x + RandomRange(-f, f)
aPoints(1).y = aPoints(0).y + RandomRange(-f, f)
aPoints(2).x = aPoints(1).x + RandomRange(-f, f)
aPoints(2).y = aPoints(1).y + RandomRange(-f, f)
aPoints(3).x = aPoints(2).x + RandomRange(-f, f)
aPoints(3).y = aPoints(2).y + RandomRange(-f, f)
Next
BitBlt(hDC, 0, 0, iW, iH, hDC_backbuffer, 0, 0, SRCCOPY)
If(Timer - fTimer > 0.99) Then
Windowtitle (sTitle & iFPS)
iFPS = 0
fTimer = Timer
Else
iFPS += 1
Endif
If (Screenevent(@evt)) Then
Select Case evt.Type
Case SC_ESCAPE, EVENT_WINDOW_CLOSE
'GDI
SelectObject(hDC_backbuffer, hDC_obj)
DeleteDC(hDC_backbuffer)
DeleteObject(hHBitmap)
ReleaseDC(hHWND, hDC)
'GDIPlus
GdipDeletePen(hPen)
GdipDeleteBrush(hBrush)
GdipDeleteGraphics(hCanvas)
GdiplusShutdown(gdipToken)
Exit Do
Case EVENT_MOUSE_BUTTON_RELEASE
If evt.button = BUTTON_RIGHT Then
GdipCreateBitmapFromHBITMAP(hHBitmap, 0, @hBitmap)
_GDIPlus_ImageSaveToFile(hBitmap, Curdir & "\Painting1_" & Format(Now(), "yyyymmdd_hhmmss") & ".jpg")
GdipDisposeImage(hBitmap)
End If
End Select
Endif
Sleep(10, 1)
Loop
Function Brightness(iColor As Ulong) As Single
Dim As Ubyte r = (iColor Shr 16) And &hFF, g = (iColor Shr 8) And &hFF, b = iColor And &hFF
Return Sqr(0.241 * r * r + 0.691 * g * g + 0.068 * b * b)
End Function
Function RandomRange(fStart as Single, fEnd as Single) as Single
Return Rnd() * (fEnd - fStart) + fStart
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_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 Integer) As Byte Ptr
Dim As HINTERNET hOpen = InternetOpen("IE", INTERNET_OPEN_TYPE_DIRECT, NULL, NULL, 0), _
hFile = InternetOpenUrl(hOpen, sURL, NULL, 0, INTERNET_FLAG_RELOAD, 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
2) GDI+ Image Painting2.bas
Code: Select all
'Coded by UEZ build 2019-02-08
'Windows only!
'Original idea by Vamoss
#Include "fbgfx.bi"
#Include "windows.bi"
#Include "vbcompat.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
Declare Function Brightness(iColor As Ulong) As Single
Declare Function RandomRange(fStart as Single, fEnd as Single) as Single
Declare Function _GDIPlus_ImageSaveToFile(hImage As Any Ptr, Filename As Wstring, JPGQual As Ulong = 85) As Boolean
Declare Function _GDIPlus_BitmapCreateFromMemory3(aBinImage As Ubyte Ptr, iLen As Ulong, bBitmap_GDI As Bool = False) As Any Ptr
Declare Function LoadDataFromINet(sUrl As String, Byref iSize As Integer) As Byte Ptr
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)
End
End If
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, iPixel, iRowOffset
Dim As Any Ptr hImage
'load image from internet
Dim As Integer iSize
Dim As Byte Ptr binImg = LoadDataFromINet("https://www.3darchitettura.com/wp-content/uploads/2018/11/maxresdefault-1.jpg", iSize)
hImage = _GDIPlus_BitmapCreateFromMemory3(binImg, iSize)
Deallocate binImg
'for local files
'GdipLoadImageFromFile("Test.png", @hImage)
GdipGetImageDimension(hImage, @iW, @iH)
If iW = 0 Then
GdiplusShutdown(gdipToken)
Messagebox(0, "Something went wrong to download the image!", "ERROR", 16)
End
End If
'read all colors to an array for faster access
Dim As ULong aColors(0 To iH - 1, 0 To iW - 1), iX, iY, iARGB
For iY = 0 To iH - 1
For iX = 0 To iW - 1
GdipBitmapGetPixel(hImage, iX, iY, @iARGB)
aColors(iY, iX) = iARGB
Next
Next
Dim As String sTitle = "GDIPlus Image Painting 2 Demo / FPS: "
Dim As UShort iFPS = 0
Dim As Double fTimer
Dim evt As Event
Screencontrol SET_DRIVER_NAME, "GDI"
Screenres iW, iH, 32, 1, GFX_HIGH_PRIORITY Or GFX_NO_SWITCH
Windowtitle sTitle
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), _
hCanvas, hPen, hBrush, hBitmap
GdipCreateFromHDC(hDC_backbuffer, @hCanvas)
GdipSetSmoothingMode(hCanvas, SmoothingModeAntiAlias)
GdipSetPixelOffsetMode(hCanvas, PixelOffsetModeHalf)
GdipCreateSolidFill(&hFFFF0000, @hBrush)
GdipCreatePen1(&hFF00FF00, 1, 2, @hPen)
GdipGraphicsClear(hCanvas, &hFF404040)
Randomize(, 2)
Type tPoint
As Single prevPosX, prevPosY, posX, posY, radius, angle
As Byte dir
End Type
Dim As Ushort iTotal = 200
Dim As tPoint aPoints(iTotal)
For i As Ushort = 0 To iTotal - 1
aPoints(i).prevPosX = iW / 2
aPoints(i).prevPosY = iH / 2
aPoints(i).posX = iW / 2
aPoints(i).posY = iH / 2
aPoints(i).radius = RandomRange(3, 10)
aPoints(i).angle = 0
aPoints(i).dir = Iif(Rnd() > 0.5, 1, -1)
Next
Dim As Single fPI = Acos(-1), x, y, b
fTimer = Timer
Do
For i As Ushort = 0 To iTotal - 1
aPoints(i).angle += 1 / aPoints(i).radius * aPoints(i).dir
aPoints(i).posX += Cos(aPoints(i).angle) * aPoints(i).radius
aPoints(i).posY += Sin(aPoints(i).angle) * aPoints(i).radius
x = aPoints(i).posX
y = aPoints(i).posY
x = Iif(x < 0, 0, Iif(x > iW - 1, iW - 1, x))
y = Iif(y < 0, 0, Iif(y > iH - 1, iH - 1, y))
b = Brightness(aColors(y, x))
If b > 70 Or _
aPoints(i).posX < 0 Or aPoints(i).posX > iW - 1 Or _
aPoints(i).posY < 0 Or aPoints(i).posY > iH - 1 Then
aPoints(i).dir *= -1
aPoints(i).radius = RandomRange(3, 10)
aPoints(i).angle += fPI
End If
GdipSetPenWidth(hPen, b / 20)
GdipSetPenColor(hPen, &hA0FFFFFF And aColors(y, x))
GdipDrawLine(hCanvas, hPen, aPoints(i).prevPosX, aPoints(i).prevPosY, aPoints(i).posX, aPoints(i).posY)
aPoints(i).prevPosX = aPoints(i).posX
aPoints(i).prevPosY = aPoints(i).posY
Next
BitBlt(hDC, 0, 0, iW, iH, hDC_backbuffer, 0, 0, SRCCOPY)
If(Timer - fTimer > 0.99) Then
Windowtitle (sTitle & iFPS)
iFPS = 0
fTimer = Timer
Else
iFPS += 1
Endif
If (Screenevent(@evt)) Then
Select Case evt.Type
Case SC_ESCAPE, EVENT_WINDOW_CLOSE
'GDI
SelectObject(hDC_backbuffer, hDC_obj)
DeleteDC(hDC_backbuffer)
DeleteObject(hHBitmap)
ReleaseDC(hHWND, hDC)
'GDIPlus
GdipDeletePen(hPen)
GdipDeleteBrush(hBrush)
GdipDeleteGraphics(hCanvas)
GdiplusShutdown(gdipToken)
Exit Do
Case EVENT_MOUSE_BUTTON_RELEASE
If evt.button = BUTTON_RIGHT Then
GdipCreateBitmapFromHBITMAP(hHBitmap, 0, @hBitmap)
_GDIPlus_ImageSaveToFile(hBitmap, Curdir & "\Painting2_" & Format(Now(), "yyyymmdd_hhmmss") & ".jpg")
GdipDisposeImage(hBitmap)
Elseif evt.button = BUTTON_MIDDLE Then
GdipGraphicsClear(hCanvas, &hFF404040)
End If
End Select
Endif
Sleep(10, 1)
Loop
Function Brightness(iColor As Ulong) As Single
Dim As Ubyte r = (iColor Shr 16) And &hFF, g = (iColor Shr 8) And &hFF, b = iColor And &hFF
Return Sqr(0.241 * r * r + 0.691 * g * g + 0.068 * b * b)
End Function
Function RandomRange(fStart as Single, fEnd as Single) as Single
Return Rnd() * (fEnd - fStart) + fStart
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_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 Integer) As Byte Ptr
Dim As HINTERNET hOpen = InternetOpen("IE", INTERNET_OPEN_TYPE_DIRECT, NULL, NULL, 0), _
hFile = InternetOpenUrl(hOpen, sURL, NULL, 0, INTERNET_FLAG_RELOAD, 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
Code: Select all
'Coded by UEZ build 2019-02-15
'Windows only!
'Original idea (Brush Drawing) by Oliver Brotherhood
#Include "fbgfx.bi"
#Include "windows.bi"
#Include "vbcompat.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
Declare Function Brightness(iColor As Ulong) As Single
Declare Function RandomRange(fStart as Single, fEnd as Single) as Single
Declare Function _GDIPlus_ImageSaveToFile(hImage As Any Ptr, Filename As Wstring, JPGQual As Ulong = 85) As Boolean
Declare Function _GDIPlus_BitmapCreateFromMemory3(aBinImage As Ubyte Ptr, iLen As Ulong, bBitmap_GDI As Bool = False) As Any Ptr
Declare Function LoadDataFromINet(sUrl As String, Byref iSize As Integer) As Byte Ptr
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)
End
End If
Type Particle
As Single x, y, vx, vy, size
End Type
'Stack
Type _Stack
Private:
As Particle aStack(Any)
As Uinteger iPos = 0
Public:
Declare Constructor()
Declare Destructor()
Declare Sub Push(Particle As Particle)
Declare Function Pop() As Particle
Declare Function Get(iPos As Uinteger) Byref As Particle
Declare Sub Set(iPos As Uinteger, x As Single, y As Single, vx As Single, vy As Single, size As Single)
Declare Sub DeleteItem(iPos As Uinteger)
Declare Function Count() As Uinteger
Declare Sub Print()
End Type
Constructor _Stack()
Redim This.aStack(0 To 1000) As Particle
End Constructor
Destructor _Stack()
Redim This.aStack(0)
End Destructor
Sub _Stack.Push(Particle As Particle)
If This.iPos >= Ubound(This.aStack) Then
Redim Preserve This.aStack(0 To This.iPos + 1000)
End If
This.aStack(iPos) = Particle
This.iPos += 1
End Sub
Function _Stack.Pop() As Particle
If This.iPos > 0 Then This.iPos -= 1
Return This.aStack(This.iPos)
End Function
Sub _Stack.Set(iPos As Uinteger, x As Single, y As Single, vx As Single, vy As Single, size As Single)
If iPos >= 0 And iPos <= Ubound(This.aStack) Then
This.aStack(iPos).x = x
This.aStack(iPos).y = y
This.aStack(iPos).vx = vx
This.aStack(iPos).vy = vy
This.aStack(iPos).size = size
End If
End Sub
Function _Stack.Get(iPos As Uinteger) Byref As Particle
If iPos >= 0 And iPos <= Ubound(This.aStack) Then Return This.aStack(iPos)
End Function
Sub _Stack.DeleteItem(iPos As Uinteger)
If This.iPos >= 0 And This.iPos <= Ubound(This.aStack) Then
If iPos < Ubound(This.aStack) Then
For i As Uinteger = iPos To Ubound(This.aStack) - 1
This.aStack(i).x = This.aStack(i + 1).x
This.aStack(i).y = This.aStack(i + 1).y
This.aStack(i).vx = This.aStack(i + 1).vx
This.aStack(i).vy = This.aStack(i + 1).vy
This.aStack(i).size = This.aStack(i + 1).size
Next
End If
Redim Preserve This.aStack(0 To This.iPos - 1)
If This.iPos > 0 Then This.iPos -= 1
End If
End Sub
Function _Stack.Count() As Uinteger
Return This.iPos
End Function
Sub _Stack.Print()
If This.iPos > 0 Then
For i As Uinteger = 0 To This.iPos - 1
? This.aStack(i).x, This.aStack(i).x
Next
Else
? "<empty>"
End If
End Sub
'-----------------------------------------------------------
'--------------------------------------------------------------------------------------------------
Type float As Single 'Double
Dim Shared As Integer perm(512) = { _
151,160,137, 91, 90, 15,131, 13,201, 95, 96, 53,194,233, 7,225,_
140, 36,103, 30, 69,142, 8, 99, 37,240, 21, 10, 23,190, 6,148, _
247,120,234, 75, 0, 26,197, 62, 94,252,219,203,117, 35, 11, 32, _
57,177, 33, 88,237,149, 56, 87,174, 20,125,136,171,168, 68,175, _
74,165, 71,134,139, 48, 27,166, 77,146,158,231, 83,111,229,122, _
60,211,133,230,220,105, 92, 41, 55, 46,245, 40,244,102,143, 54, _
65, 25, 63,161, 1,216, 80, 73,209, 76,132,187,208, 89, 18,169, _
200,196,135,130,116,188,159, 86,164,100,109,198,173,186, 3, 64, _
52,217,226,250,124,123, 5,202, 38,147,118,126,255, 82, 85,212, _
207,206, 59,227, 47, 16, 58, 17,182,189, 28, 42,223,183,170,213, _
119,248,152, 2, 44,154,163, 70,221,153,101,155,167, 43,172, 9, _
129, 22, 39,253, 19, 98,108,110, 79,113,224,232,178,185,112,104, _
218,246, 97,228,251, 34,242,193,238,210,144, 12,191,179,162,241, _
81, 51,145,235,249, 14,239,107, 49,192,214, 31,181,199,106,157, _
184, 84,204,176,115,121, 50, 45,127, 4,150,254,138,236,205, 93, _
222,114, 67, 29, 24, 72,243,141,128,195, 78, 66,215, 61,156,180, _
151,160,137, 91, 90, 15,131, 13,201, 95, 96, 53,194,233, 7,225,_
140, 36,103, 30, 69,142, 8, 99, 37,240, 21, 10, 23,190, 6,148, _
247,120,234, 75, 0, 26,197, 62, 94,252,219,203,117, 35, 11, 32, _
57,177, 33, 88,237,149, 56, 87,174, 20,125,136,171,168, 68,175, _
74,165, 71,134,139, 48, 27,166, 77,146,158,231, 83,111,229,122, _
60,211,133,230,220,105, 92, 41, 55, 46,245, 40,244,102,143, 54, _
65, 25, 63,161, 1,216, 80, 73,209, 76,132,187,208, 89, 18,169, _
200,196,135,130,116,188,159, 86,164,100,109,198,173,186, 3, 64, _
52,217,226,250,124,123, 5,202, 38,147,118,126,255, 82, 85,212, _
207,206, 59,227, 47, 16, 58, 17,182,189, 28, 42,223,183,170,213, _
119,248,152, 2, 44,154,163, 70,221,153,101,155,167, 43,172, 9, _
129, 22, 39,253, 19, 98,108,110, 79,113,224,232,178,185,112,104, _
218,246, 97,228,251, 34,242,193,238,210,144, 12,191,179,162,241, _
81, 51,145,235,249, 14,239,107, 49,192,214, 31,181,199,106,157, _
184, 84,204,176,115,121, 50, 45,127, 4,150,254,138,236,205, 93, _
222,114, 67, 29, 24, 72,243,141,128,195, 78, 66,215, 61,156,180}
Function SimplexNoise2D(xin As float, yin As float, scale As float = 20.0) As float 'by D.J.Peters aka Joshy
Const As float F2 = 0.5*(Sqr(3.0)-1.0)
Const As float G2 = (3.0-Sqr(3.0))/6.0
Const As float G22 = G2 + G2
Static As Integer grad2(11,1) = {{ 1, 1},{-1, 1},{1,-1},{-1,-1}, _
{ 1, 0},{-1, 0},{1, 0},{-1, 0}, _
{ 0, 1},{ 0,-1},{0, 1},{ 0,-1}}
Dim As float s = (xin+yin)*F2
Dim As Integer i = Int(xin+s)
Dim As Integer j = Int(yin+s)
Dim As float t = (i+j)*G2
Dim As float x = i-t , y = j-t
Dim As float x0 = xin-x, y0 = yin-y
Dim As Integer i1=Any, j1=Any
i And=255
j And=255
If (x0>y0) Then
i1=1: j1=0
Else
i1=0: j1=1
End If
Dim As float x1 = x0 - i1 + G2
Dim As float y1 = y0 - j1 + G2
Dim As float x2 = x0 - 1.0 + G22
Dim As float y2 = y0 - 1.0 + G22
Dim As Integer ii = i 'And 255
Dim As Integer jj = j 'And 255
Dim As Integer ind = Any
Dim As float n=Any
t = 0.5 - x0*x0-y0*y0
If (t<0) Then
n=0
Else
ind = perm(i+perm(j)) Mod 12
n = t*t*t*t * (grad2(ind,0)*x0 + grad2(ind,1)*y0)
End If
t = 0.5 - x1*x1-y1*y1
If (t<0) Then
Else
ind = perm(i+i1+perm(j+j1)) Mod 12
n+= t*t*t*t * (grad2(ind,0)*x1 + grad2(ind,1)*y1)
End If
t = 0.5 - x2*x2-y2*y2
If(t<0) Then
Else
i+=1:j+=1
ind= perm(i+perm(j)) Mod 12
n+= t*t*t*t * (grad2(ind,0)*x2 + grad2(ind,1)*y2)
End If
' scaled in the interval [-1,1].
Return scale * n
End Function
'--------------------------------------------------------------------------------------------------
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, iPixel, iRowOffset
Dim As Any Ptr hImage
'load image from internet
Dim As Integer iSize
Dim As Byte Ptr binImg = LoadDataFromINet("https://i.pinimg.com/originals/b3/7e/0f/b37e0f691a8bb179bd344d6c911bcd43.jpg", iSize)
hImage = _GDIPlus_BitmapCreateFromMemory3(binImg, iSize)
Deallocate binImg
'for local files
'GdipLoadImageFromFile("Test.png", @hImage)
GdipGetImageDimension(hImage, @iW, @iH)
If iW = 0 Then
GdiplusShutdown(gdipToken)
Messagebox(0, "Something went wrong to download the image!", "ERROR", 16)
End
End If
'read all colors to an array for faster access
Dim As ULong aColors(0 To iH - 1, 0 To iW - 1), iX, iY, iARGB
For iY = 0 To iH - 1
For iX = 0 To iW - 1
GdipBitmapGetPixel(hImage, iX, iY, @iARGB)
aColors(iY, iX) = iARGB
Next
Next
Dim As String sTitle = "GDIPlus Image Painting 3 Demo / FPS: "
Dim As UShort iFPS = 0
Dim As Double fTimer
Dim evt As Event
Screencontrol SET_DRIVER_NAME, "GDI"
Screenres iW, iH, 32, 1, GFX_HIGH_PRIORITY Or GFX_NO_SWITCH
Windowtitle sTitle
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), _
hCanvas, hBrush, hBitmap
GdipCreateFromHDC(hDC_backbuffer, @hCanvas)
GdipSetSmoothingMode(hCanvas, SmoothingModeAntiAlias)
GdipSetPixelOffsetMode(hCanvas, PixelOffsetModeHalf)
GdipCreateSolidFill(&hFFFF0000, @hBrush)
GdipGraphicsClear(hCanvas, &hFF404040)
Randomize(, 2)
? "Press lmb and move mouse cursor around!"
Dim As Ushort iTotal = 20, i
Dim As _Stack Stack
Dim As Single x, y
Dim As Particle brush
Dim As Bool bLMB_pressed = False
Dim As Integer mx, my, mb
fTimer = Timer
Do
Getmouse mx, my, , mb
If mb = 1 Then
bLMB_pressed = True
For i = 0 To iTotal - 1
brush.x = mx + RandomRange(-4, 4)
brush.y = my + RandomRange(-4, 4)
brush.vx = RandomRange(-3, 3)
brush.vy = RandomRange(-3, 3)
brush.size = 16
Stack.Push(brush)
Next
End If
If Stack.Count() > 0 Then
For i = 0 To Stack.Count() - 1
x = Stack.Get(i).x
y = Stack.Get(i).y
x = Iif(x < 0, 0, Iif(x > iW - 1, iW - 1, x))
y = Iif(y < 0, 0, Iif(y > iH - 1, iH - 1, y))
GdipSetSolidFillColor(hBrush, &h80FFFFFF And aColors(y, x))
GdipFillEllipse(hCanvas, hBrush, x - Stack.Get(i).size / 2, y - Stack.Get(i).size / 2, Stack.Get(i).size, Stack.Get(i).size)
x += Stack.Get(i).vx + SimplexNoise2D(x, y, 500)
y += Stack.Get(i).vy + SimplexNoise2D(x, y, 500)
Stack.Set(i, x, y, Stack.Get(i).vx, Stack.Get(i).vy, Stack.Get(i).size * 0.9)
Next
'cleanup stack elements
i = Stack.Count()
Do Until i = 0
If Stack.Get(i).size < 0.75 Then Stack.DeleteItem(i)
i -= 1
Loop
End If
If bLMB_pressed = True Then BitBlt(hDC, 0, 0, iW, iH, hDC_backbuffer, 0, 0, SRCCOPY)
If(Timer - fTimer > 0.99) Then
Windowtitle (sTitle & iFPS)
iFPS = 0
fTimer = Timer
Else
iFPS += 1
Endif
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_RELEASE
If evt.button = BUTTON_RIGHT Then
GdipCreateBitmapFromHBITMAP(hHBitmap, 0, @hBitmap)
_GDIPlus_ImageSaveToFile(hBitmap, Curdir & "\Painting3_" & Format(Now(), "yyyymmdd_hhmmss") & ".jpg")
GdipDisposeImage(hBitmap)
Elseif evt.button = BUTTON_MIDDLE Then
GdipGraphicsClear(hCanvas, &hFF404040)
End If
'Case EVENT_KEY_PRESS
'If evt.scancode = Asc("c") Then GdipGraphicsClear(hCanvas, &hFF404040)
End Select
Endif
Sleep(10, 1)
Loop
'GDI
SelectObject(hDC_backbuffer, hDC_obj)
DeleteDC(hDC_backbuffer)
DeleteObject(hHBitmap)
ReleaseDC(hHWND, hDC)
'GDIPlus
GdipDeleteBrush(hBrush)
GdipDeleteGraphics(hCanvas)
GdiplusShutdown(gdipToken)
End
Function Brightness(iColor As Ulong) As Single
Dim As Ubyte r = (iColor Shr 16) And &hFF, g = (iColor Shr 8) And &hFF, b = iColor And &hFF
Return Sqr(0.241 * r * r + 0.691 * g * g + 0.068 * b * b)
End Function
Function RandomRange(fStart as Single, fEnd as Single) as Single
Return Rnd() * (fEnd - fStart) + fStart
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_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 Integer) As Byte Ptr
Dim As HINTERNET hOpen = InternetOpen("IE", INTERNET_OPEN_TYPE_DIRECT, NULL, NULL, 0), _
hFile = InternetOpenUrl(hOpen, sURL, NULL, 0, INTERNET_FLAG_RELOAD, 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
4) GDI+ Image Painting4.bas (van Gogh style)
Code: Select all
'Coded by UEZ build 2019-02-10
'Windows only!
'Original idea (Noise flow field painter) by Jose
#Include "fbgfx.bi"
#Include "windows.bi"
#Include "vbcompat.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
Declare Function RandomRange(fStart as Single, fEnd as Single) as Single
Declare Function _GDIPlus_ImageSaveToFile(hImage As Any Ptr, Filename As Wstring, JPGQual As Ulong = 85) As Boolean
Declare Function _GDIPlus_BitmapCreateFromMemory3(aBinImage As Ubyte Ptr, iLen As Ulong, bBitmap_GDI As Bool = False) As Any Ptr
Declare Function LoadDataFromINet(sUrl As String, Byref iSize As Integer) As Byte Ptr
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)
End
End If
'--------------------------------------------------------------------------------------------------
Type float As Single 'Double
Dim Shared As Integer perm(512) = { _
151,160,137, 91, 90, 15,131, 13,201, 95, 96, 53,194,233, 7,225,_
140, 36,103, 30, 69,142, 8, 99, 37,240, 21, 10, 23,190, 6,148, _
247,120,234, 75, 0, 26,197, 62, 94,252,219,203,117, 35, 11, 32, _
57,177, 33, 88,237,149, 56, 87,174, 20,125,136,171,168, 68,175, _
74,165, 71,134,139, 48, 27,166, 77,146,158,231, 83,111,229,122, _
60,211,133,230,220,105, 92, 41, 55, 46,245, 40,244,102,143, 54, _
65, 25, 63,161, 1,216, 80, 73,209, 76,132,187,208, 89, 18,169, _
200,196,135,130,116,188,159, 86,164,100,109,198,173,186, 3, 64, _
52,217,226,250,124,123, 5,202, 38,147,118,126,255, 82, 85,212, _
207,206, 59,227, 47, 16, 58, 17,182,189, 28, 42,223,183,170,213, _
119,248,152, 2, 44,154,163, 70,221,153,101,155,167, 43,172, 9, _
129, 22, 39,253, 19, 98,108,110, 79,113,224,232,178,185,112,104, _
218,246, 97,228,251, 34,242,193,238,210,144, 12,191,179,162,241, _
81, 51,145,235,249, 14,239,107, 49,192,214, 31,181,199,106,157, _
184, 84,204,176,115,121, 50, 45,127, 4,150,254,138,236,205, 93, _
222,114, 67, 29, 24, 72,243,141,128,195, 78, 66,215, 61,156,180, _
151,160,137, 91, 90, 15,131, 13,201, 95, 96, 53,194,233, 7,225,_
140, 36,103, 30, 69,142, 8, 99, 37,240, 21, 10, 23,190, 6,148, _
247,120,234, 75, 0, 26,197, 62, 94,252,219,203,117, 35, 11, 32, _
57,177, 33, 88,237,149, 56, 87,174, 20,125,136,171,168, 68,175, _
74,165, 71,134,139, 48, 27,166, 77,146,158,231, 83,111,229,122, _
60,211,133,230,220,105, 92, 41, 55, 46,245, 40,244,102,143, 54, _
65, 25, 63,161, 1,216, 80, 73,209, 76,132,187,208, 89, 18,169, _
200,196,135,130,116,188,159, 86,164,100,109,198,173,186, 3, 64, _
52,217,226,250,124,123, 5,202, 38,147,118,126,255, 82, 85,212, _
207,206, 59,227, 47, 16, 58, 17,182,189, 28, 42,223,183,170,213, _
119,248,152, 2, 44,154,163, 70,221,153,101,155,167, 43,172, 9, _
129, 22, 39,253, 19, 98,108,110, 79,113,224,232,178,185,112,104, _
218,246, 97,228,251, 34,242,193,238,210,144, 12,191,179,162,241, _
81, 51,145,235,249, 14,239,107, 49,192,214, 31,181,199,106,157, _
184, 84,204,176,115,121, 50, 45,127, 4,150,254,138,236,205, 93, _
222,114, 67, 29, 24, 72,243,141,128,195, 78, 66,215, 61,156,180}
Function SimplexNoise2D(xin As float, yin As float, scale As float = 1.0) As float 'by D.J.Peters aka Joshy
Const As float F2 = 0.5*(Sqr(3.0)-1.0)
Const As float G2 = (3.0-Sqr(3.0))/6.0
Const As float G22 = G2 + G2
Static As Integer grad2(11,1) = {{ 1, 1},{-1, 1},{1,-1},{-1,-1}, _
{ 1, 0},{-1, 0},{1, 0},{-1, 0}, _
{ 0, 1},{ 0,-1},{0, 1},{ 0,-1}}
Dim As float s = (xin+yin)*F2
Dim As Integer i = Int(xin+s)
Dim As Integer j = Int(yin+s)
Dim As float t = (i+j)*G2
Dim As float x = i-t , y = j-t
Dim As float x0 = xin-x, y0 = yin-y
Dim As Integer i1=Any, j1=Any
i And=255
j And=255
If (x0>y0) Then
i1=1: j1=0
Else
i1=0: j1=1
End If
Dim As float x1 = x0 - i1 + G2
Dim As float y1 = y0 - j1 + G2
Dim As float x2 = x0 - 1.0 + G22
Dim As float y2 = y0 - 1.0 + G22
Dim As Integer ii = i 'And 255
Dim As Integer jj = j 'And 255
Dim As Integer ind = Any
Dim As float n=Any
t = 0.5 - x0*x0-y0*y0
If (t<0) Then
n=0
Else
ind = perm(i+perm(j)) Mod 12
n = t*t*t*t * (grad2(ind,0)*x0 + grad2(ind,1)*y0)
End If
t = 0.5 - x1*x1-y1*y1
If (t<0) Then
Else
ind = perm(i+i1+perm(j+j1)) Mod 12
n+= t*t*t*t * (grad2(ind,0)*x1 + grad2(ind,1)*y1)
End If
t = 0.5 - x2*x2-y2*y2
If(t<0) Then
Else
i+=1:j+=1
ind= perm(i+perm(j)) Mod 12
n+= t*t*t*t* (grad2(ind,0)*x2 + grad2(ind,1)*y2)
End If
' scaled in the interval [-1,1].
Return scale * n
End Function
'--------------------------------------------------------------------------------------------------
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, iPixel, iRowOffset
Dim As Any Ptr hImage
'load image from internet
Dim As Integer iSize
'Dim As Byte Ptr binImg = LoadDataFromINet("https://pics.freiepresse.de/DYNIMG/74/95/6397495_W740.jpg", iSize)
'Dim As Byte Ptr binImg = LoadDataFromINet("https://www.tpi.it/app/uploads/2019/01/van-gogh.jpg", iSize)
Dim As Byte Ptr binImg = LoadDataFromINet("https://leaders.economicblogs.org/wp-content/uploads/2018/12/AEG.jpg", iSize)
'Dim As Byte Ptr binImg = LoadDataFromINet("https://d2jv9003bew7ag.cloudfront.net/uploads/Pablo-Picasso-old.jpg", iSize)
hImage = _GDIPlus_BitmapCreateFromMemory3(binImg, iSize)
Deallocate binImg
'for local files
'GdipLoadImageFromFile("Test.png", @hImage)
GdipGetImageDimension(hImage, @iW, @iH)
If iW = 0 Then
GdiplusShutdown(gdipToken)
Messagebox(0, "Something went wrong to download the image!", "ERROR", 16)
End
End If
'read all colors to an array for faster access
Dim As ULong aColors(0 To iH - 1, 0 To iW - 1), iX, iY, iARGB
For iY = 0 To iH - 1
For iX = 0 To iW - 1
GdipBitmapGetPixel(hImage, iX, iY, @iARGB)
aColors(iY, iX) = iARGB
Next
Next
Dim As String sTitle = "GDIPlus Image Painting 4 Demo / FPS: "
Dim As UShort iFPS = 0
Dim As Double fTimer
Dim evt As Event
Screencontrol SET_DRIVER_NAME, "GDI"
Screenres iW, iH, 32, 1, GFX_HIGH_PRIORITY Or GFX_NO_SWITCH
Windowtitle sTitle
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), _
hCanvas, hPen, hBrush, hBitmap
GdipCreateFromHDC(hDC_backbuffer, @hCanvas)
GdipSetSmoothingMode(hCanvas, SmoothingModeAntiAlias)
GdipSetPixelOffsetMode(hCanvas, PixelOffsetModeHalf)
GdipGraphicsClear(hCanvas, &hFFFFFFFF)
GdipCreatePen1(&hFF000000, 1, 2, @hPen)
GdipSetPenStartCap(hPen, 2)
GdipSetPenEndCap(hPen, 2)
Randomize(, 2)
#Define Map(n, s, e, ns, ne) (ns - (ns - ne) * (n / (e - s)))
#Define Red(iCol) ((iCol And &hFF0000) Shr 16)
#Define Green(iCol) ((iCol And &hFF00) Shr 8)
#Define Blue(iCol) (iCol And &hFF)
Const fPI = Acos(-1), rad = Acos(-1) * 180
Dim As Single x, y, xx, yy, frame, count, sw, angle, lengthVariation, _fMax = Max(iW, iH), _fMin = Min(iW, iH), _
noiseScale = 0.005, drawLength = _fMax / 2.5, fMSL = _fMin / 80, strokeLength = fMSL
Dim As Ulong col
Dim As Integer mx, my, mb
fTimer = Timer
Do
If frame <= drawLength Then
count = map(frame, 0, drawLength, 20, 80)
For i As uShort = 0 To count
strokeLength += RandomRange(-fMSL / 2, fMSL / 4)
x = Rnd() * iW - strokeLength / 2 : xx = x
y = Rnd() * iH - strokeLength / 2 : yy = y
col = aColors(Iif(y < 0, 0, Iif(y > iH - 1, iH - 1, y)), Iif(x < 0, 0, Iif(x > iW - 1, iW - 1, x)))
GdipCreateHatchBrush(9, &h70FFFFFF And col, col, @hBrush)
GdipSetPenBrushFill(hPen, hBrush)
'GdipSetPenColor(hPen, &h70FFFFFF And col)
sw = map(frame, 0, drawLength, 32, 1)
GdipSetPenWidth(hPen, sw)
angle = SimplexNoise2D(x * noiseScale, y * noiseScale, 0.2) * 3.3333
lengthVariation = RandomRange(0.75, 1.25)
xx += Cos((angle - fPi) * rad) * strokeLength
yy += Sin((angle - fPi) * rad) * strokeLength
x += Cos(angle * rad) * strokeLength
y += Sin(angle * rad) * strokeLength
GdipDrawLine(hCanvas, hPen, x, y, xx + strokeLength * lengthVariation, yy)
col = RandomRange(&h18, &h40) Shl 24 Or Min(Red(col) * 3, 255) Shl 16 Or Min(Green(col * 3), 255) Shl 8 Or Min(Blue(col * 3), 255)
GdipSetPenColor(hPen, col)
GdipSetPenWidth(hPen, sw * 0.85)
GdipDrawLine(hCanvas, hPen, x, y - sw * 0.15, xx + strokeLength * lengthVariation, yy - sw * 0.15)
strokeLength = fMSL
GdipDeleteBrush(hBrush)
Next
frame += 0.25
End If
BitBlt(hDC, 0, 0, iW, iH, hDC_backbuffer, 0, 0, SRCCOPY)
If(Timer - fTimer > 0.99) Then
Windowtitle (sTitle & iFPS & " / Rendered: " & Format(frame / drawLength, "###%"))
iFPS = 0
fTimer = Timer
Else
iFPS += 1
Endif
If (Screenevent(@evt)) Then
Select Case evt.Type
Case SC_ESCAPE, EVENT_WINDOW_CLOSE
'GDI
SelectObject(hDC_backbuffer, hDC_obj)
DeleteDC(hDC_backbuffer)
DeleteObject(hHBitmap)
ReleaseDC(hHWND, hDC)
'GDIPlus
GdipDeletePen(hPen)
GdipDeleteGraphics(hCanvas)
GdiplusShutdown(gdipToken)
End
Case EVENT_MOUSE_BUTTON_RELEASE
If evt.button = BUTTON_RIGHT Then
GdipCreateBitmapFromHBITMAP(hHBitmap, 0, @hBitmap)
_GDIPlus_ImageSaveToFile(hBitmap, Curdir & "\Painting4_" & Format(Now(), "yyyymmdd_hhmmss") & ".jpg")
GdipDisposeImage(hBitmap)
Elseif evt.button = BUTTON_MIDDLE Then
GdipGraphicsClear(hCanvas, &hFFFFFFFF)
frame = 0
End If
End Select
Endif
Sleep(10, 1)
Loop
Function RandomRange(fStart as Single, fEnd as Single) as Single
Return Rnd() * (fEnd - fStart) + fStart
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_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 Integer) As Byte Ptr
Dim As HINTERNET hOpen = InternetOpen("IE", INTERNET_OPEN_TYPE_DIRECT, NULL, NULL, 0), _
hFile = InternetOpenUrl(hOpen, sURL, NULL, 0, INTERNET_FLAG_RELOAD, 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
More examples will follow from time to time.