Forum AtoutFox : Re: WIN32 API   

ven. 28 septembre 2018, 17h10
eddymaue
atoutfox.public.association

Re: WIN32 API

trouvé

a+ Eddy

********************************************************************
* GDI+ wrapper
********************************************************************
* Classes defined:
* gdiplusbase, graphics, gdiimage, gdibitmap, gdifontcollection,
* gdifontfamily, gdifont, gdipen, gdimatrix, gdistringformat,
* gdiplusinit
********************************************************************
* an instance of gdiplusinit should be created before
* and released after using any of gdi+ objects
********************************************************************

DEFINE CLASS gdiplusbase As Custom
* abstract base class for graphics, gdiimage, gdifontcollection,
* gdifontfamily, gdifont and others
errorcode=0
ENDDEFINE

********************************************************************
DEFINE CLASS graphics As gdiplusbase
SmoothingMode=0
graphics=0
hdc=0

PROCEDURE SmoothingMode_ACCESS
LOCAL nSmoothingMode
nSmoothingMode = 0

IF GdipGetSmoothingMode(THIS.graphics, @nSmoothingMode) = 0
THIS.SmoothingMode = nSmoothingMode
ENDIF
RETURN THIS.SmoothingMode

PROCEDURE SmoothingMode_ASSIGN(vValue)
IF VARTYPE(vValue) = "N" AND;
GdipSetSmoothingMode(THIS.graphics, vValue) = 0
THIS.SmoothingMode = vValue
ENDIF

PROCEDURE Init(p1, p2)
IF PCOUNT()>0
THIS.CreateGraphics(p1, p2)
ENDIF

PROCEDURE Destroy
THIS.ReleaseGraphics
DODEFAULT()

PROCEDURE ReleaseGraphics
IF THIS.graphics = 0
RETURN
ENDIF

THIS.ReleaseDC
= GdipDeleteGraphics(THIS.graphics)
THIS.graphics=0

FUNCTION CreateGraphics(p1, p2)
#DEFINE OBJ_DC 3
THIS.ReleaseGraphics

LOCAL graphics, nObjType
STORE 0 TO graphics
nObjType = GetObjectType(m.p1)

DO CASE
CASE nObjType=0 AND IsWindow(m.p1)<>0
THIS.errorcode = GdipCreateFromHWND(m.p1, @graphics)
CASE nObjType=OBJ_DC AND PCOUNT()=1
THIS.errorcode = GdipCreateFromHDC(m.p1, @graphics)
CASE nObjType=OBJ_DC AND PCOUNT()=2
THIS.errorcode = GdipCreateFromHDC2(m.p1, m.p2, @graphics)
OTHERWISE
THIS.errorcode = -1
RETURN .F.
ENDCASE
THIS.graphics = m.graphics
RETURN (THIS.errorcode=0)

PROCEDURE GetDC
THIS.ReleaseDC
LOCAL hdc
hdc=0
IF THIS.graphics <> 0
= GdipGetDC(THIS.graphics, @hdc)
ENDIF
THIS.hdc = m.hdc
RETURN m.hdc

PROCEDURE ReleaseDC
IF THIS.hdc <> 0
= GdipReleaseDC(THIS.graphics, THIS.hdc)
THIS.hdc=0
ENDIF

PROCEDURE DrawImage(oImage, nX, nY, nWidth, nHeight)
IF VARTYPE(nWidth) <> "N"
nWidth = oImage.imgwidth
ENDIF
IF VARTYPE(nHeight) <> "N"
nHeight = oImage.imgheight
ENDIF
THIS.errorcode = GdipDrawImageRectI(THIS.graphics,;
oImage.himage, m.nX, m.nY, m.nWidth, m.nHeight)

PROCEDURE DrawText(cStr, oFont, p1, p2, p3, p4)
LOCAL rectf
IF VARTYPE(m.p1)="O"
rectf = p1.ToString()
ELSE
WITH CREATEOBJECT("rectf", m.p1, m.p2, m.p3, m.p4)
rectf = .ToString()
ENDWITH
ENDIF

= GdipSetTextRenderingHint(THIS.graphics, 0) && 0..5

THIS.errorcode = GdipDrawString(THIS.graphics,;
ToWideChar(m.cStr), -1, oFont.fnt, @rectf, 0, oFont.brush)
RETURN (THIS.errorcode=0)

FUNCTION MeasureString(cStr, oFont) As RectF
LOCAL fmt As gdistringformat, oRect, cRectSrc, cRectDst,;
nCharsFitted, nLinesFitted

fmt = CREATEOBJECT("gdistringformat", 0)

oRect = CREATEOBJECT("rectf", 0, 0, 0, 0)
STORE oRect.ToString() TO cRectSrc, cRectDst

STORE 0 TO nCharsFitted, nLinesFitted

THIS.errorcode = GdipMeasureString(THIS.graphics,
STRCONV(m.cStr+CHR(0),5),;
LEN(m.cStr), oFont.fnt, cRectSrc, fmt.fmt, @cRectDst,;
@nCharsFitted, @nLinesFitted)

oRect.FromString(m.cRectDst)
RETURN m.oRect

PROCEDURE FillRectangle(p1, p2, p3, p4, p5)
LOCAL brush
IF VARTYPE(m.p1)="O"
brush = p1.brush
ELSE
LOCAL oBrush
oBrush = CREATEOBJECT("gdisolidbrush", m.p1)
brush = oBrush.brush
ENDIF

IF VARTYPE(p2)="O"
= GdipFillRectangle(THIS.graphics, m.brush,;
p2.rleft, p2.rtop, p2.rwidth, p2.rheight)
ELSE
= GdipFillRectangle(THIS.graphics, m.brush,;
m.p2, m.p3, m.p4, m.p5)
ENDIF

PROCEDURE FillEllipse(p1, p2, p3, p4, p5)
LOCAL brush
IF VARTYPE(m.p1)="O"
brush = p1.brush
ELSE
LOCAL oBrush
oBrush = CREATEOBJECT("gdisolidbrush", m.p1)
brush = oBrush.brush
ENDIF

IF VARTYPE(p2)="O"
= GdipFillEllipse(THIS.graphics, m.brush,;
p2.rleft, p2.rtop, p2.rwidth, p2.rheight)
ELSE
= GdipFillEllipse(THIS.graphics, m.brush,;
m.p2, m.p3, m.p4, m.p5)
ENDIF

PROCEDURE DrawRectangle(p1, p2, p3, p4, p5)
LOCAL nHandle
IF VARTYPE(m.p1)="O"
nHandle = p1.hpen
ELSE
LOCAL oPenObj
oPenObj = CREATEOBJECT("gdipen", m.p1, 1)
nHandle = oPenObj.hpen
ENDIF

IF VARTYPE(p2)="O"
= GdipDrawRectangle(THIS.graphics, m.nHandle,;
p2.rleft, p2.rtop, p2.rwidth, p2.rheight)
ELSE
= GdipDrawRectangle(THIS.graphics, m.nHandle,;
m.p2, m.p3, m.p4, m.p5)
ENDIF

PROCEDURE DrawEllipse(p1, p2, p3, p4, p5)
LOCAL nHandle
IF VARTYPE(m.p1)="O"
nHandle = p1.hpen
ELSE
LOCAL oPenObj
oPenObj = CREATEOBJECT("gdipen", m.p1, 1)
nHandle = oPenObj.hpen
ENDIF

IF VARTYPE(p2)="O"
= GdipDrawEllipse(THIS.graphics, m.nHandle,;
p2.rleft, p2.rtop, p2.rwidth, p2.rheight)
ELSE
= GdipDrawEllipse(THIS.graphics, m.nHandle,;
m.p2, m.p3, m.p4, m.p5)
ENDIF

PROCEDURE DrawLine(p1, p2, p3, p4, p5)
LOCAL nHandle
IF VARTYPE(m.p1)="O"
nHandle = p1.hpen
ELSE
LOCAL oPenObj
oPenObj = CREATEOBJECT("gdipen", m.p1, 1)
nHandle = oPenObj.hpen
ENDIF

IF VARTYPE(p2)="O"
= GdipDrawLine(THIS.graphics, m.nHandle,;
p2.rleft, p2.rtop, p2.rwidth, p2.rheight)
ELSE
= GdipDrawLine(THIS.graphics, m.nHandle,;
m.p2, m.p3, m.p4, m.p5)
ENDIF

PROCEDURE SetTransform(vMatrix)
DO CASE
CASE VARTYPE(m.vMatrix) = "O"
THIS.errorcode = GdipSetWorldTransform(;
THIS.graphics, vMatrix.hmatrix)
CASE VARTYPE(m.vMatrix) = "N"
THIS.errorcode = GdipSetWorldTransform(;
THIS.graphics, m.vMatrix)
ENDCASE

PROCEDURE ResetTransform
THIS.errorcode=GdipResetWorldTransform(;
THIS.graphics)

ENDDEFINE

********************************************************************
DEFINE CLASS gdidbrush As gdiplusbase
brush=0
PROCEDURE Destroy
THIS.ReleaseBrush
PROTECTED PROCEDURE ReleaseBrush
IF THIS.brush <> 0
= GdipDeleteBrush(THIS.brush)
THIS.brush=0
ENDIF
ENDDEFINE

DEFINE CLASS gdisolidbrush As gdidbrush
PROCEDURE Init(argbcolor)
IF VARTYPE(m.argbcolor) <> "N"
argbcolor=0
ENDIF
THIS.SetBrushColor(argbcolor)

PROCEDURE SetBrushColor(argbcolor)
THIS.ReleaseBrush
LOCAL brush
brush=0
THIS.errorcode = GdipCreateSolidFill(m.argbcolor, @brush)
THIS.brush = m.brush
RETURN (THIS.errorcode=0)

ENDDEFINE

********************************************************************
DEFINE CLASS gdiimage As gdiplusbase
himage=0
hbitmap=0
filename=""
imgtype=0
imgwidth=0
imgheight=0
imgflags=0
guid=""
graphics=0

PROCEDURE Init(p1, p2, p3, p4, p5, p6)
DO CASE
CASE PCOUNT()=1 AND VARTYPE(p1)="C"
THIS.CreateFromFile(p1)
CASE PCOUNT()=1 AND VARTYPE(p1)="N"
THIS.CreateFromHandle(p1)
CASE PCOUNT()=1 AND VARTYPE(p1)="O"
THIS.CloneFromGdiBitmap1(p1)
CASE PCOUNT()>1 AND VARTYPE(p1)="O"
THIS.CloneFromGdiBitmap2(p1, p2, p3, p4, p5, p6)
ENDCASE

PROCEDURE Destroy
THIS.ReleaseImage
DODEFAULT()

PROCEDURE ReleaseImage
#DEFINE OBJ_BITMAP 7
IF VARTYPE(THIS.graphics)="O"
THIS.graphics=0
ENDIF
IF THIS.himage <> 0
= GdipDisposeImage(THIS.himage)
THIS.himage=0
ENDIF
IF THIS.hbitmap <> 0
IF GetObjectType(THIS.hbitmap)=OBJ_BITMAP
= DeleteObject(THIS.hbitmap)
ENDIF
THIS.hbitmap=0
ENDIF
THIS.filename=""
THIS.imgtype=0
THIS.imgwidth=0
THIS.imgheight=0
THIS.imgflags=0
THIS.guid=""
THIS.errorcode = 0

FUNCTION CreateFromFile(cFile)
THIS.ReleaseImage
THIS.filename = m.cFile

LOCAL img, imgtype, imgwidth, imgheight, imgflags, guid
STORE 0 TO img, imgtype, imgwidth, imgheight, imgflags

TRY
THIS.errorcode = GdipLoadImageFromFile(;
ToWideChar(cFile), @img)
CATCH
THIS.errorcode =-1
ENDTRY

THIS.himage=m.img
THIS.GetImageParameters
RETURN (THIS.himage<>0)

FUNCTION CreateFromHandle(img)
THIS.ReleaseImage
THIS.himage=m.img
THIS.GetImageParameters
IF THIS.imgtype <> 0
RETURN .T.
ELSE
THIS.ReleaseImage
RETURN .F.
ENDIF

FUNCTION CloneFromGdiBitmap1(src)
LOCAL srcHBitmap, dstHImage, dst
srcHBitmap = src.GetHBITMAP()
IF srcHBitmap <> 0
dstHImage=0
THIS.errorcode = GdipCreateBitmapFromHBITMAP(;
m.srcHBitmap, 0, @dstHImage)
IF THIS.errorcode = 0
RETURN THIS.CreateFromHandle(dstHImage)
ENDIF
ENDIF
RETURN .F.

FUNCTION CloneFromGdiBitmap2(src, dstfmt, x0, y0, dstwidth, dstheight)
LOCAL dstHImage
dstHImage = 0
THIS.errorcode = GdipCloneBitmapArea(;
m.x0, m.y0, m.dstwidth, m.dstheight,;
dstfmt, src.himage, @dstHImage)
IF THIS.errorcode = 0
RETURN THIS.CreateFromHandle(dstHImage)
ENDIF
RETURN .F.

PROTECTED PROCEDURE GetImageParameters
LOCAL imgtype, imgwidth, imgheight, imgflags, guid, graphics
STORE 0 TO imgtype, imgwidth, imgheight, imgflags, graphics
guid = REPLICATE(CHR(0), 16)

IF THIS.himage <> 0
= GdipGetImageType(THIS.himage, @m.imgtype)
= GdipGetImageWidth(THIS.himage, @m.imgwidth)
= GdipGetImageHeight(THIS.himage, @m.imgheight)
= GdipGetImageFlags(THIS.himage, @m.imgflags)
= GdipGetImageRawFormat(THIS.himage, @m.guid)
ENDIF
THIS.imgtype = m.imgtype
THIS.imgwidth = m.imgwidth
THIS.imgheight = m.imgheight
THIS.imgflags = m.imgflags
THIS.guid = m.guid

IF VARTYPE(THIS.graphics) = "N"
THIS.errorcode =;
GdipGetImageGraphicsContext(THIS.himage, @graphics)
IF THIS.errorcode = 0
* 3=OutOfMemory
THIS.graphics = CREATEOBJECT("graphics")
THIS.graphics.graphics = m.graphics
ENDIF
ENDIF

FUNCTION GetHBITMAP
LOCAL hbitmap
hbitmap=0
IF THIS.hbitmap = 0
THIS.errorcode = GdipCreateHBITMAPFromBitmap(;
THIS.himage, @hbitmap, 0)
IF THIS.errorcode = 0
THIS.hbitmap = m.hbitmap
ENDIF
ENDIF
RETURN THIS.hbitmap

PROCEDURE CreateHICON
LOCAL hIcon
hIcon=0
THIS.errorcode = GdipCreateHICONFromBitmap(;
THIS.himage, @hIcon)
RETURN m.hIcon

FUNCTION SaveToFile(cTargetFile)
#DEFINE ccEncoderBitmap "{557cf400-1a04-11d3-9a73-0000f81ef32e}"
#DEFINE ccEncoderJpeg "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
#DEFINE ccEncoderGif "{557cf402-1a04-11d3-9a73-0000f81ef32e}"
#DEFINE ccEncoderTiff "{557cf405-1a04-11d3-9a73-0000f81ef32e}"
#DEFINE ccEncoderPng "{557cf406-1a04-11d3-9a73-0000f81ef32e}"
LOCAL cType, cEncoder
cType = UPPER(ALLTRIM(SUBSTR(cTargetFile,;
RAT(".",cTargetFile)+1)))

DO CASE
CASE cType == "BMP"
cEncoder=StringToCLSID(ccEncoderBitmap)
CASE cType == "JPG" OR cType == "JPEG"
cEncoder=StringToCLSID(ccEncoderJpeg)
CASE cType == "GIF"
cEncoder=StringToCLSID(ccEncoderGif)
CASE cType == "TIF" OR cType == "TIFF"
cEncoder=StringToCLSID(ccEncoderTiff)
CASE cType == "PNG"
cEncoder=StringToCLSID(ccEncoderPng)
OTHERWISE
THIS.errorcode=-1
RETURN .F.
ENDCASE
THIS.errorcode = GdipSaveImageToFile(THIS.himage,;
ToWideChar(m.cTargetFile), m.cEncoder, 0)
RETURN (THIS.errorcode=0)
ENDDEFINE

********************************************************************
DEFINE CLASS gdibitmap As gdiimage

PROCEDURE Init(p1, p2)
IF PCOUNT()=2 AND VARTYPE(p1)="N" AND VARTYPE(p2)="N"
THIS.CreateBitmap(p1, p2)
ENDIF

PROCEDURE CreateBitmap(nWidth, nHeight)
RETURN THIS.CreateFromHWND(nWidth, nHeight, GetDesktopWindow())

PROCEDURE CreateFromHWND(nWidth, nHeight, hwindow)
LOCAL gr, lResult
gr = CREATEOBJECT("graphics", m.hwindow)
lResult = THIS.CreateFromGraphics(nWidth, nHeight, gr.graphics)
RETURN m.lResult

PROCEDURE CreateFromGraphics(nWidth, nHeight, graphics)
LOCAL img
img=0
THIS.errorcode = GdipCreateBitmapFromGraphics(;
m.nWidth, m.nHeight, m.graphics, @img)
IF THIS.errorcode = 0
RETURN THIS.CreateFromHandle(m.img)
ELSE
RETURN .F.
ENDIF

PROCEDURE CreateFromHBITMAP(hBitmap)
LOCAL img
img=0
THIS.errorcode = GdipCreateBitmapFromHBITMAP(;
m.hBitmap, 0, @m.img)
IF THIS.errorcode = 0
RETURN THIS.CreateFromHandle(m.img)
ELSE
RETURN .F.
ENDIF

PROCEDURE CreateFromHICON(hIcon)
LOCAL img
img=0
THIS.errorcode = GdipCreateBitmapFromHICON(;
m.hIcon, @m.img)
IF THIS.errorcode = 0
RETURN THIS.CreateFromHandle(m.img)
ELSE
RETURN .F.
ENDIF

PROCEDURE CreateFromBITMAPINFO(hBitmapinfo, hBitmapdata)
#DEFINE BITMAPINFOHEADER_SIZE 40
IF VARTYPE(hBitmapdata) <> "N" OR hBitmapdata=0
* simplified: null color table is assumed
hBitmapdata = hBitmapinfo +;
BITMAPINFOHEADER_SIZE
ENDIF
LOCAL img
img=0
THIS.errorcode = GdipCreateBitmapFromGdiDib(hBitmapinfo,;
hBitmapdata, @img)
IF THIS.errorcode = 0
RETURN THIS.CreateFromHandle(m.img)
ELSE
RETURN .F.
ENDIF

ENDDEFINE

********************************************************************
DEFINE CLASS gdifontcollection As gdiplusbase
* collection of fonts installed on the system
fontfamilies=0

PROCEDURE Init
THIS.GetFontFamilies

PROCEDURE GetFontFamily(vFamilyName)
LOCAL oFamily, ex as Exception
TRY
oFamily = THIS.fontfamilies.Item(vFamilyName)
CATCH TO ex
IF VARTYPE(vFamilyName)="C"
oFamily = THIS.GetFamilyByName(vFamilyName)
ELSE
oFamily = CREATEOBJECT("gdifontfamily")
ENDIF
ENDTRY
RETURN m.oFamily

PROTECTED PROCEDURE GetFamilyByName(cFamilyName)
cFamilyName = LOWER(ALLTRIM(m.cFamilyName))
LOCAL oFamily As gdifontfamily
FOR EACH oFamily IN THIS.fontfamilies
IF LOWER(oFamily.familyname) = m.cFamilyName
RETURN oFamily
ENDIF
NEXT
oFamily = CREATEOBJECT("gdifontfamily")
RETURN m.oFamily

PROTECTED PROCEDURE GetFontFamilies
THIS.fontfamilies = CREATEOBJECT("Collection")

LOCAL fonts, familycount, cBuffer, hfontfamily, nIndex
STORE 0 TO fonts, familycount
= GdipNewInstalledFontCollection(@fonts)
= GdipGetFontCollectionFamilyCount(fonts, @familycount)

cBuffer = REPLICATE(CHR(0), m.familycount*4)
= GdipGetFontCollectionFamilyList(fonts, familycount,;
@cBuffer, @familycount)
FOR nIndex=0 TO familycount-1
LOCAL oFontFamily
hfontfamily = buf2dword(SUBSTR(cBuffer,;
nIndex*4+1,4))
oFontFamily = CREATEOBJECT("gdifontfamily", m.hfontfamily)
THIS.fontfamilies.Add(oFontFamily, oFontFamily.familyname)
NEXT
ENDDEFINE

********************************************************************
DEFINE CLASS gdifontfamily As gdiplusbase
hfontfamily=0
familyname=""
hasregular=.F.
hasbold=.F.
hasitalic=.F.
hasbolditalic=.F.
hasunderline=.F.
hasstrikeout=.F.

PROCEDURE Init(hfontfamily)
IF VARTYPE(m.hfontfamily)="N"
THIS.hfontfamily = m.hfontfamily
THIS.GetFamilyData
ENDIF

PROTECTED PROCEDURE GetFamilyData
#DEFINE LF_FACESIZE 32
LOCAL familyname, langid
langid = VAL(SYS(3004))
familyname = REPLICATE(CHR(0), (LF_FACESIZE+1)*2) && widechar
= GdipGetFamilyName(THIS.hfontfamily, @m.familyname, m.langid)
THIS.familyname = STRCONV(m.familyname,6)
THIS.hasregular=THIS.IsStyleAvailable(0)
THIS.hasbold=THIS.IsStyleAvailable(1)
THIS.hasitalic=THIS.IsStyleAvailable(2)
THIS.hasbolditalic=THIS.IsStyleAvailable(3)
THIS.hasunderline=THIS.IsStyleAvailable(4)
THIS.hasstrikeout=THIS.IsStyleAvailable(8)

PROTECTED FUNCTION IsStyleAvailable(nStyle)
LOCAL nAvailable
nAvailable=0
= GdipIsStyleAvailable(THIS.hfontfamily, nStyle, @nAvailable)
RETURN (nAvailable<>0)
ENDDEFINE

********************************************************************
DEFINE CLASS gdifont As gdiplusbase
PROTECTED fontfamilycreated
hfontfamily=0
fnt=0
brush=0

PROCEDURE Init(vFamily, fntsize, fntstyle, argbcolor)
DO CASE
CASE PCOUNT()=0
THIS.InitFont("Arial", 10, 0, ARGB(0,0,0))
CASE PCOUNT()=1
THIS.InitFont(vFamily, 10, 0, ARGB(0,0,0))
CASE PCOUNT()=2
THIS.InitFont(vFamily, fntsize, 0, ARGB(0,0,0))
CASE PCOUNT()=3
THIS.InitFont(vFamily, fntsize, fntstyle, ARGB(0,0,0))
CASE PCOUNT()=4
THIS.InitFont(vFamily, fntsize, fntstyle, argbcolor)
ENDCASE

PROTECTED PROCEDURE InitFont(vFamily, fntsize, fntstyle, argbcolor)
THIS.ClearFont

DO CASE
CASE VARTYPE(m.vFamily)="O"
THIS.hfontfamily = vFamily.hfontfamily
CASE VARTYPE(m.vFamily)="N"
THIS.hfontfamily = m.vFamily
CASE VARTYPE(m.vFamily)="C"
LOCAL hfontfamily
hfontfamily=0
Permalink : http://www.atoutfox.org/nntp.asp?ID=0000019213