Generate gradients images with APIs
*For listview or even vfp grids i need sometime to build images gradients to set as backgrounds
*for listview there is a native background row picture (can be tiled on listview surface)
*for grid must build images background in a container as currentcontrol and code with dynamicBackcolor property.
*this code generates any gradient image form 2 colors.
*set 2 colors , the code generates 8 images in folder "images" (created if not exists).
*Can generate PNG,JPG,BMP ,GIF (or even TIF).
*This code needs only APIs to do the job (no need to load gdiplusX class/system.app) and its very light.
*This can be done also easily with gdiplus and gdiplusX classes.
*1*
*Begin code
Clea All
Set Date short
Set Safe Off
Local m.yrep
m.yrep = Addbs(Justpath(Sys(16,1))) && source folder (starting prg)
Set Default To (yrep)
If ! Directory(m.yrep+"images")
Md (m.yrep+"images")
Else
Dele File (m.yrep+"images\*.*")
Endi
Local m.ext,m.xCLSID
m.ext=Upper(Inputbox("Images outputs as:BMP PNG JPG GIF","","BMP"))
If !Inlist(Upper(m.ext),"BMP","PNG","JPG","GIF")
m.ext="BMP"
Endi
#Define PixelFormat 0x00022009 &&"32bpprgb"
#Define BMPClsID 0h00F47C55041AD3119A730000F81EF32E &&BMP Format
*can use other images format with the gdi encoders (PNG,JPG,GIF,TIF)
#Define JPGClsID 0h01F47C55041AD3119A730000F81EF32E &&JPG Format
#Define GIFClsID 0h02F47C55041AD3119A730000F81EF32E &&GIF Format
#Define TIFClsID 0h05F47C55041AD3119A730000F81EF32E &&TIF Format
#Define PNGClsID 0h06F47C55041AD3119A730000F81EF32E &&PNG Format
*get start color & endcolor
Local lnWidth, lnHeight, lnBrushWidth, lnBrushHeight, lnStartColor, lnEndColor
Local lnMode, lnWrapModeTile, lcOutFile, lnBitMap, lnGraphics, lnBrush, lcRect
Local lnStat, lcPath
Local tnColor, loColor
For i=1 To 2
tnColor=Getcolor() &&get 2 colors to build linear gradient
If tnColor=-1
Return .F.
Endi
loColor = Newobject("Empty")
AddProperty(loColor, "nR", Bitand(tnColor, 0xFF))
AddProperty(loColor, "nG", Bitand(Bitrshift(tnColor, 8), 0xFF))
AddProperty(loColor, "nB", Bitand(Bitrshift(tnColor, 16), 0xFF))
AddProperty(loColor, "cHTMLcolor", Strtran("#" + ;
TRANSFORM(loColor.nR, "@0") + ;
TRANSFORM(loColor.nG, "@0") + ;
TRANSFORM(loColor.nB, "@0"), "0x000000", "" ))
**RETURN loColor
If i=1
lnStartColor=Eval("0xA1"+Strtran(loColor.cHTMLcolor,"#",""))
Else
lnEndColor =Eval("0xA8"+Strtran(loColor.cHTMLcolor,"#",""))
Endi
loColor=Null
Endfor
For lnMode=0 To 3 &¶meter 0 to 3 determine the interpolation mode of colors
Do ydeclare
lnWidth = 130 && set image width here (px)
lnHeight = 34 && set image height here (px)
lnBrushWidth =130
lnBrushHeight = 34
lnWrapModeTile = 0 && paraemter 0 to 3, détermines transitions colors nature
Local m.xx
m.xx="ycap_"+Ttoc(Datetime())
m.xx=Strtran(m.xx,"/","_")
m.xx=Strtran(m.xx,":","_")
m.xx=Strtran(m.xx,";","_")
m.lcOutfile0=m.yrep+"images\"+m.xx+Sys(2015)+'.'+m.ext
m.lcOutFile=m.lcOutfile0
lnBitMap = 0
lnStat = GdipCreateBitmapFromScan0(lnWidth, lnHeight, 0, PixelFormat, 0, @lnBitMap)
If lnStat = 0
lnGraphics = 0
lnStat = GdipGetImageGraphicsContext(lnBitMap, @lnGraphics)
Endif
If lnStat = 0
lnBrush = 0
lcRect = BinToC(0, "4RS") + ;
BinToC(0, "4RS") + ;
BinToC(lnBrushWidth, "4RS") + ;
BinToC(lnBrushHeight/2, "4RS")
lnStat = GdipCreateLineBrushFromRectI(lcRect, lnStartColor, lnEndColor, ;
lnMode, lnWrapModeTile, @lnBrush)
Endif
If lnStat = 0
lnStat = GdipFillRectangleI(lnGraphics, lnBrush, 0, 0, lnWidth, lnHeight/2)
Endif
If lnStat = 0
lnBrush = 0
lcRect = BinToC(0, "4RS") + ;
BinToC(lnHeight/2, "4RS") + ;
BinToC(lnBrushWidth, "4RS") + ;
BinToC(lnBrushHeight/2, "4RS")
lnStat = GdipCreateLineBrushFromRectI(lcRect,lnEndColor, lnStartColor, ;
lnMode, lnWrapModeTile, @lnBrush)
Endif
If lnStat = 0
lnStat = GdipFillRectangleI(lnGraphics, lnBrush, 0, lnHeight/2, lnWidth, lnHeight/2)
Endif
If lnStat = 0
lcOutFile = Strconv(lcOutFile + Chr(0), 5) && Unicode
Do Case
Case m.ext="BMP"
m.xCLSID=BMPClsID
Case m.ext="PNG"
m.xCLSID=PNGClsID
Case m.ext="JPG"
m.xCLSID=JPGClsID
Case m.ext="GIF"
m.xCLSID=GIFClsID
Endcase
lnStat = GdipSaveImageToFile(m.lnBitMap, m.lcOutFile, m.xCLSID, Null)
Endif
= GdipDeleteBrush(lnBrush)
= GdipDeleteGraphics(lnGraphics)
= GdipDisposeImage(lnBitMap)
Clear Dlls
If lnStat != 0
= Messagebox('error in GDI: ' + Ltrim(Str(lnStat)))
Endif
Endfor
Messagebox("4 images saved !",0+32+4096,"",1000)
Local m.oo
m.oo=m.yrep+"images"
Run /N explorer &oo
&&APIs declarations
Procedure ydeclare
Declare Long GdipCreateLineBrushFromRectI In GDIPlus.Dll ;
String Rect, Long Color1, Long Color2, Long Mode, ;
Long WrapModeTile, Long @ brush
Declare Long GdipDeleteBrush In GDIPlus.Dll Long brush
Declare Long GdipFillRectangleI In GDIPlus.Dll ;
Long Bitmap, Long brush, Long x, Long Y, Long Width, Long Height
Declare Long GdipCreateBitmapFromScan0 In GDIPlus.Dll ;
Long Width, Long Height, Long stride, Long Format, Long scan0, Long @ Bitmap
Declare Long GdipSaveImageToFile In GDIPlus.Dll Long nativeImage, ;
String cUnicodeFileName, String ClsidEncoder, String EncoderParameters
Declare Long GdipDisposeImage In GDIPlus.Dll Long Bitmap
Declare Long GdipDeleteGraphics In GDIPlus.Dll Long graphics
Declare Long GdipGetImageGraphicsContext In GDIPlus.Dll Long Bitmap, Long @ graphics
Endproc
*End code
Click on code to select [then copy] -click outside to deselect
*2* created on 11 of may 2017
*!* this code shows how to build programmatly images with linear gradients in 2 methods
*!* can generate images to fill any image control or form.picture....
*!* images created are erased.can uncomment to reuse the image saved in temp folder.
Publi oform
oform=Newobject("ygrad")
oform.Show
Read Events
Retu
*
Define Class ygrad As Form
Height = 293
Width = 659
ShowWindow = 2
ShowTips = .T.
AutoCenter = .T.
Caption = "Building bitmap with 2 methods"
Name = "Form1"
Add Object command1 As CommandButton With ;
Top = 24, ;
Left = 12, ;
Height = 37, ;
Width = 132, ;
FontBold = .T., ;
Caption = "Random gradient", ;
ToolTipText = "Click and reclick...", ;
SpecialEffect = 2, ;
Name = "Command1"
Add Object command2 As CommandButton With ;
Top = 84, ;
Left = 12, ;
Height = 48, ;
Width = 132, ;
FontBold = .T., ;
Caption = "Gradients h,vert,diag", ;
SpecialEffect = 2, ;
Name = "Command2"
Add Object image1 As Image With ;
Stretch = 2, ;
Height = 37, ;
Left = 264, ;
Top = 24, ;
Visible = .F., ;
Width = 228, ;
Name = "Image1"
Add Object shape1 As Shape With ;
Top = 84, ;
Left = 150, ;
Height = 24, ;
Width = 36, ;
BorderStyle = 0, ;
Curvature = 15, ;
MousePointer = 15, ;
BackColor = Rgb(255,128,0), ;
Name = "Shape1"
Add Object shape2 As Shape With ;
Top = 115, ;
Left = 150, ;
Height = 24, ;
Width = 36, ;
BorderStyle = 0, ;
Curvature = 15, ;
MousePointer = 15, ;
BackColor = Rgb(0,255,0), ;
Name = "Shape2"
Add Object spinner1 As Spinner With ;
Height = 24, ;
KeyboardHighValue = 3, ;
KeyboardLowValue = 1, ;
Left = 192, ;
MousePointer = 15, ;
SpinnerHighValue = 3.00, ;
SpinnerLowValue = 1.00, ;
ToolTipText = "Horizontal,diagonal,vertical gradient", ;
Top = 96, ;
Width = 48, ;
Value = 2, ;
Name = "Spinner1"
Procedure rgb2html
Lparameters tnColor
Local loColor
loColor = Createobject("Empty")
AddProperty(loColor, "nR", Bitand(tnColor, 0xFF))
AddProperty(loColor, "nG", Bitand(Bitrshift(tnColor, 8), 0xFF))
AddProperty(loColor, "nB", Bitand(Bitrshift(tnColor, 16), 0xFF))
AddProperty(loColor, "cHTMLcolor", Strtran("#" + ;
TRANSFORM(loColor.nR, "@0") + ;
TRANSFORM(loColor.nG, "@0") + ;
TRANSFORM(loColor.nB, "@0"), "0x000000", "" ))
Return loColor.cHTMLcolor
Endproc
Procedure Destroy
Clea Events
Endproc
Procedure command1.Click
*create horizontal bmp image with linear gradient 2 colors
Local nWidth,lnHeight As Integer
Set Classlib To Locfile (Home(1)+"ffc\_gdiplus.vcx")
Local OBitmap, oGraphics, Open, nY,nX, cFileName
*hoprizontal
lnWidth= Thisform.Width
lnHeight= Thisform.Height
m.cFileName =Addbs(Sys(2023))+"ygrad_"+Sys(2015)+".jpg"
m.OBitmap = Createobject ("gpBitmap")
m.OBitmap. Create (lnWidth, lnHeight)
m.oGraphics = Createobject ("gpGraphics")
m.oGraphics.CreateFromImage (m.OBitmap)
Local tnRed, tnGreen, tnBlue, tnAlpha,xcolor
tnRed=Int(255*Rand())
tnGreen=Int(255*Rand())
tnBlue=Int(255*Rand())
m.xcolor=Thisform.rgb2html(Rgb(tnRed,tnGreen,tnBlue))
m.xcolor="0x"+Strtran(m.xcolor,"#","") +"00" &&build a compatible vfp color like 0xAAAA0000 with html color
m.oPen = Createobject ("gpPen", 0)
For m.nY = 0 To (lnHeight - 1) Step 1
m.oPen.PenColor = Eval(m.xcolor)+ (m.nY * 255 / lnHeight)
m.oGraphics.DrawLine (m.oPen, 0, m.nY, lnWidth - 1, m.nY)
Endfor
m.OBitmap.SaveToFile (m.cFileName, "image/jpeg")
*can be mimes as image/bmp,image/png,image/gif....
* can blur result image here with gdiplusX (for a better effect)
Thisform.image1.Picture=m.cFileName
Thisform.image1.Visible=.T.
m.oPen=Null
m.oGraphics=Null
m.OBitmap=Null
Set Classlib To
Erase ( m.cFileName) &&&&can not erase and use it saved as it
Endproc
Procedure command2.Click
*build a bitmap with dimensions in pixels 256x1
*can fill any bitmap with anchor=15
With _Screen
.AddProperty("red1",0)
.AddProperty("green1",0)
.AddProperty("blue1",0)
.AddProperty("red2",0)
.AddProperty("green2",0)
.AddProperty("blue2",0)
Endwith
Local m.xcolor1,m.xcolor2
m.xcolor1=Thisform.shape1.BackColor
If m.xcolor1=-1
m.xcolor1=255
Endi
With _Screen
.red1=Asc(Substr(Left(BinToC(m.xcolor1,'R'),3),1,1)) && RED
.green1=Asc(Substr(Left(BinToC(m.xcolor1,'R'),3),2,1)) && GREEN
.blue1=Asc(Substr(Left(BinToC(m.xcolor1,'R'),3),3,1)) && BLUE
Endwith
m.xcolor2=Thisform.shape2.BackColor
If m.xcolor2=-1
m.xclor1=255
Endi
With _Screen
.red2=Asc(Substr(Left(BinToC(m.xcolor2,'R'),3),1,1)) && RED
.green2=Asc(Substr(Left(BinToC(m.xcolor2,'R'),3),2,1)) && GREEN
.blue2=Asc(Substr(Left(BinToC(m.xcolor2,'R'),3),3,1)) && BLUE
Endwith
Local m.X
m.X=Thisform.spinner1.Value
Do Case
Case m.X=1
* Horizontal
m.bmp="BM6"+Chr(3)+Replicate(Chr(0),6)+Chr(0x36)+Replicate(Chr(0),3)+ ;
chr(0x28)+Replicate(Chr(0),4)+Chr(1)+Replicate(Chr(0),2)+ ;
chr(1)+Replicate(Chr(0),3)+Chr(1)+Chr(0)+Chr(0x18)+Replicate(Chr(0),6)+ ;
chr(3)+Replicate(Chr(0),18)
For m.i=0 To 255
m.red=Round(_Screen.red1*(255-m.i)/255+_Screen.red2*m.i/255,0)
m.blue=Round(_Screen.blue1*(255-m.i)/255+_Screen.blue2*m.i/255,0)
m.green=Round(_Screen.green1*(255-m.i)/255+_Screen.green2*m.i/255,0)
m.bmp=m.bmp+Chr(m.blue)+Chr(m.green)+Chr(m.red)
Next
Case m.X=2
* Vertical
m.bmp="BM6"+Chr(4)+Replicate(Chr(0),6)+Chr(0x36)+Replicate(Chr(0),3)+ ;
chr(0x28)+Replicate(Chr(0),3)+Chr(1)+Replicate(Chr(0),4)+ ;
chr(1)+Replicate(Chr(0),2)+Chr(1)+Chr(0)+Chr(0x18)+Replicate(Chr(0),6)+ ;
chr(4)+Replicate(Chr(0),18)
*!* Vertical
For m.i=0 To 255
m.red=Round(_Screen.red1*(255-m.i)/255+_Screen.red2*m.i/255,0)
m.blue=Round(_Screen.blue1*(255-m.i)/255+_Screen.blue2*m.i/255,0)
m.green=Round(_Screen.green1*(255-m.i)/255+_Screen.green2*m.i/255,0)
m.bmp=m.bmp+Chr(m.blue)+Chr(m.green)+Chr(m.red)+Chr(0)
Next
*!* diagonal
Case m.X=3
m.bmp="BM6"+Chr(3)+Replicate(Chr(0),6)+Chr(0x36)+Replicate(Chr(0),3)+ ;
chr(0x28)+Replicate(Chr(0),4)+Chr(1)+Replicate(Chr(0),2)+ ;
chr(1)+Replicate(Chr(0),3)+Chr(1)+Chr(0)+Chr(0x18)+Replicate(Chr(0),6)+ ;
chr(3)+Replicate(Chr(0),18)
For m.i=0 To 255
m.red=Round(_Screen.red1*(255-m.i)/255+_Screen.red2*m.i/255,0)
m.blue=Round(_Screen.blue1*(255-m.i)/255+_Screen.blue2*m.i/255,0)
m.green=Round(_Screen.green1*(255-m.i)/255+_Screen.green2*m.i/255,0)
m.bmp=m.bmp+Chr(m.blue)+Chr(m.green)+Chr(m.red)
Next
Endcase
Local m.ytemp
m.ytemp=Addbs(Sys(2023))+"ygrad"+Sys(2015)+".bmp"
Strtofile(m.bmp,m.ytemp)
Thisform.image1.Picture=m.ytemp
Thisform.image1.Visible=.T.
Erase (m.ytemp) &&can not erase and use it saved as it
Endproc
Procedure image1.Init
With This
.Anchor=15
.Left=0
.Top=0
.Width=.Parent.Width
.Height=.Parent.Height
.ZOrder(1)
Endwith
Endproc
Procedure shape1.Click
Local m.xcolor
m.xcolor=Getcolor()
If m.xcolor=-1
Return .F.
Endi
This.BackColor=m.xcolor
Thisform.command2.Click
Endproc
Procedure shape2.Click
Local m.xcolor
m.xcolor=Getcolor()
If m.xcolor=-1
Return .F.
Endi
This.BackColor=m.xcolor
Thisform.command2.Click
Endproc
Procedure spinner1.InteractiveChange
Thisform.command2.Click
Endproc
Enddefine
*
*-- EndDefine: ygrad
Click on code to select [then copy] -click outside to deselect
*3* created on 14 of february 2018
*generate directly a gradient bitmap with colors (256x1 px)-can resize it or use it as it.
Local m.xcolor1,m.xcolor2
m.xcolor1=Getcolor()
m.xcolor2=Getcolor()
If Empty(m.xcolor1) Or Empty(m.xcolor2)
Return .F.
Endi
Local m.x1,m.x2,m.red1,m.green1,m.blue1,m.red2,m.green2,m.blue2
m.x1= color2RGB(m.xcolor1)
m.red1 =Int(Val(Getwordnum(m.x1,1,",") ))
m.green1 =Int(Val(Getwordnum(m.x1,2,",") ))
m.blue1 =Int(Val(Getwordnum(m.x1,3,",")))
m.x2=color2RGB(m.xcolor2)
m.red2 =Int(Val(Getwordnum(m.x2,1,",") ))
m.green2 =Int(Val(Getwordnum(m.x2,2,",") ))
m.blue2 =Int(Val(Getwordnum(m.x2,3,",")))
Local m.bmp,m.red,m.green,m.blue,mfn
*bmp header
m.bmp="BM6"+Chr(3)+Replicate(Chr(0),6)+Chr(0x36)+Replicate(Chr(0),3)+ ;
chr(0x28)+Replicate(Chr(0),4)+Chr(1)+Replicate(Chr(0),2)+ ;
chr(1)+Replicate(Chr(0),3)+Chr(1)+Chr(0)+Chr(0x18)+Replicate(Chr(0),6)+ ;
chr(3)+Replicate(Chr(0),18)
*fill fill linear gradient
For m.i=0 To 255
m.red=Round(red1*(255-m.i)/255+red2*m.i/255,0)
m.blue=Round(blue1*(255-m.i)/255+blue2*m.i/255,0)
m.green=Round(green1*(255-m.i)/255+green2*m.i/255,0)
m.bmp=m.bmp+Chr(m.blue)+Chr(m.green)+Chr(m.red)
Next
*save to unique bm^p
m.fn="bmp"+Sys(2015)+".bmp"
Strtofile(m.bmp,m.fn)
Run/N explorer &fn
Retu
Function color2RGB
*convert any color to red,green,blue components
Lparameters RGBChr
m.RGBChr=Left(BinToC(RGBChr,'R'),3)
Local m.rr,m.gg,m.bb
rr=Asc(Substr(m.RGBChr,1,1)) && RED
gg=Asc(Substr(m.RGBChr,2,1)) && GREEN
bb=Asc(Substr(m.RGBChr,3,1)) && BLUE
Return (Trans(rr)+','+Trans(gg)+','+Trans(bb))
Endfunc