Generate gradients images with APIs

Published on by Yousfi Benameur

*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 &&parameter 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

 

here generated images desserve row colors but can set other dimensions in code.

here generated images desserve row colors but can set other dimensions in 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

Generate gradients images with APIs
Generate gradients images with APIs
Generate gradients images with APIs

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

Published on Visual foxpro, gradients, API, classic gradients images, gdiplus, gdi32 api, linear gradient bitmap

To be informed of the latest articles, subscribe:
You might also like:
My last post with Visual Foxpro
My last post with Visual Foxpro
Working with IE11 fullscreen apps from vfp
Working with IE11 fullscreen apps from vfp
Grid cosmetics part 3
Grid cosmetics part 3
Working with "EveryThing" filer instant search.
Working with "EveryThing" filer instant search.
Advanced gdiplusX drawings : polygons
Who said that vfp IE browser died ?
Comment on this post