Working with Regions and APIs in visual foxpro

Published on by Yousfi Benameur

 

Regions are used in common windows advanced tasks and are defined in gdi32 library.
they are also used in gdiplusX with paths,drawing,...
see this link
http://yousfi.over-blog.com/2015/02/gdiplusx-effects-operations-on-images.html

 can see the functions around this subject in this msdn link:
https://msdn.microsoft.com/en-us/library/windows/desktop/dd162915%28v=vs.85%29.aspx

Regions are device independent, which means that a device context (DC) is not need to create or use one.
Some of the useful places for a region are:
*Update Region, Paint
*Clipping, Paint
* Define window shape, Irregular Shaped Windows

Below i give 9 codes relative to this subject.Suggestions and Bug Reports are always  Welcome.


*1-*

this code uses APIs to draw regions on a top level form.
the form can be rectangular,circular or roundrectangular
it uses also gdiplusX to draw on an imgcanvas control and save the image drawn.
-Simply the code asks to point to system.app and gdilusX.vcx to make it working

 


 

*Begin Code

clea all
do locfile("system.app")
set classlib to locfile("gdiplusX.vcx") addi
_screen.windowstate=1
publi oform
oform=newObject("yregion")
release classlib "gdiplusX.vcx"
oform.show
read events
retu
*
DEFINE CLASS yregion AS form
    BorderStyle = 0
    Top = 30
    Left = 164
    Height = 395
    Width = 395
    ShowWindow = 2
    ShowTips = .T.
    Picture = ""
    Caption = "Regions"
    MousePointer = 15
    BackColor = RGB(0,0,0)
    hrgn = 0
    Name = "Form1"

    ADD OBJECT label1 AS label WITH ;
        AutoSize = .T., ;
        FontBold = .T., ;
        FontSize = 14, ;
        BackStyle = 0, ;
        Caption = "X", ;
        Height = 25, ;
        Left = 248, ;
        MousePointer = 15, ;
        Top = 26, ;
        Width = 15, ;
        ForeColor = RGB(255,0,0), ;
        Name = "Label1"

    ADD OBJECT label2 AS label WITH ;
        AutoSize = .T., ;
        FontBold = .T., ;
        FontSize = 12, ;
        BackStyle = 0, ;
        Caption = "-", ;
        Height = 22, ;
        Left = 236, ;
        MousePointer = 15, ;
        Top = 25, ;
        Width = 7, ;
        ForeColor = RGB(255,0,0), ;
        Name = "Label2"

    ADD OBJECT image1 AS image WITH ;
        Picture = home(1)+"graphics\icons\misc\face03.ico", ;
        BackStyle = 0, ;
        Height = 32, ;
        Left = 70, ;
        Top = 51, ;
        Width = 32, ;
        Name = "Image1"

    ADD OBJECT label3 AS label WITH ;
        FontBold = .T., ;
        FontSize = 14, ;
        Alignment = 2, ;
        BackStyle = 0, ;
        Caption = "yRoundRect", ;
        Height = 25, ;
        Left = 114, ;
        MousePointer = 15, ;
        Top = 42, ;
        Width = 133, ;
        ForeColor = RGB(0,255,0), ;
        Name = "Label3"

    ADD OBJECT spinner1 AS spinner WITH ;
        Height = 24, ;
        Left = 263, ;
        SpinnerHighValue = 255.00, ;
        SpinnerLowValue =   0.00, ;
        ToolTipText = "Transparency", ;
        Top = 288, ;
        Width = 20, ;
        Name = "Spinner1"


    ADD OBJECT imgcanvas1 AS imgcanvas WITH ;
        Anchor = 15, ;
        Height = 190, ;
        Left = 45, ;
        MousePointer = 15, ;
        Top = 88, ;
        Width = 293, ;
        Name = "Imgcanvas1"

    ADD OBJECT optiongroup1 AS optiongroup WITH ;
        AutoSize = .T., ;
        ButtonCount = 3, ;
        BackStyle = 0, ;
        BorderStyle = 0, ;
        Value = 2, ;
        Height = 27, ;
        Left = 64, ;
        MousePointer = 15, ;
        Top = 290, ;
        Width = 188, ;
        Name = "Optiongroup1", ;
        Option1.FontSize = 8, ;
        Option1.BackStyle = 0, ;
        Option1.Caption = "Normal", ;
        Option1.Value = 0, ;
        Option1.Height = 16, ;
        Option1.Left = 5, ;
        Option1.Top = 5, ;
        Option1.Width = 51, ;
        Option1.AutoSize = .T., ;
        Option1.ForeColor = RGB(255,0,0), ;
        Option1.Name = "Option1", ;
        Option2.FontSize = 8, ;
        Option2.BackStyle = 0, ;
        Option2.Caption = "Circ", ;
        Option2.Value = 1, ;
        Option2.Height = 16, ;
        Option2.Left = 68, ;
        Option2.Top = 6, ;
        Option2.Width = 37, ;
        Option2.AutoSize = .T., ;
        Option2.ForeColor = RGB(255,0,0), ;
        Option2.Name = "Option2", ;
        Option3.FontSize = 8, ;
        Option3.BackStyle = 0, ;
        Option3.Caption = "Roundrect", ;
        Option3.Height = 16, ;
        Option3.Left = 115, ;
        Option3.Top = 5, ;
        Option3.Width = 68, ;
        Option3.AutoSize = .T., ;
        Option3.ForeColor = RGB(255,0,0), ;
        Option3.Name = "Option3"

    ADD OBJECT optiongroup2 AS optiongroup WITH ;
        AutoSize = .T., ;
        ButtonCount = 1, ;
        BackStyle = 0, ;
        BorderStyle = 0, ;
        Value = 1, ;
        Height = 27, ;
        Left = 285, ;
        Top = 281, ;
        Width = 28, ;
        Name = "Optiongroup2", ;
        Option1.Caption = "", ;
        Option1.Value = 1, ;
        Option1.Height = 17, ;
        Option1.Left = 5, ;
        Option1.ToolTipText = "Show/hide imgc", ;
        Option1.Top = 5, ;
        Option1.Width = 18, ;
        Option1.AutoSize = .T., ;
        Option1.Name = "Option1"

    ADD OBJECT optiongroup3 AS optiongroup WITH ;
        AutoSize = .T., ;
        ButtonCount = 1, ;
        BackStyle = 0, ;
        BorderStyle = 0, ;
        Value = 1, ;
        Height = 27, ;
        Left = 310, ;
        Top = 281, ;
        Width = 28, ;
        ToolTipText = "", ;
        Name = "Optiongroup3", ;
        Option1.Caption = "", ;
        Option1.Value = 1, ;
        Option1.Height = 17, ;
        Option1.Left = 5, ;
        Option1.ToolTipText = "Save imgcanvas/png", ;
        Option1.Top = 5, ;
        Option1.Width = 18, ;
        Option1.AutoSize = .T., ;
        Option1.Name = "Option1"

    PROCEDURE regionOn
        #DEFINE badgeDiameter 380  
            #DEFINE topMargin 4
            #DEFINE leftMargin 2

        #DEFINE SM_CYSIZE  31
        #DEFINE SM_CXFRAME 32
        #DEFINE SM_CYFRAME 33

            IF THIS.hRgn <> 0
                RETURN
            ENDIF

            LOCAL hwnd, x0, y0, x1, y1

            x0 = GetSystemMetrics (SM_CXFRAME) +;
                leftMargin
            y0 = GetSystemMetrics (SM_CYSIZE) +;
                GetSystemMetrics (SM_CYFRAME) + topMargin
            x1 = x0 + badgeDiameter
            y1 = y0 + badgeDiameter

           do case
           case xtype=1
            THIS.hRgn = CreateEllipticRgn (x0, y0, x1, y1)
           case xtype=2
            this.hRgn=createRoundRectRgn(x0,y0,x1,y1,80,80)
            endcase

            hwnd = thisform.hwnd
            IF SetWindowRgn (hwnd, THIS.hRgn, 1) = 0
                = DeleteObject (THIS.hRgn)
                THIS.hRgn = 0
            ENDIF
    ENDPROC

    PROCEDURE Load
        do locfile("system.app")
           DECLARE SetWindowLong In Win32Api AS _Sol_SetWindowLong Integer, Integer, Integer
           DECLARE SetLayeredWindowAttributes In Win32Api AS ;
            _Sol_SetLayeredWindowAttributes Integer, String, Integer, Integer

            DECLARE INTEGER GetFocus IN user32
            DECLARE INTEGER DeleteObject IN gdi32 INTEGER hObject
            DECLARE SHORT GetCursorPos IN user32 STRING @ lpPoint
            DECLARE INTEGER GetSystemMetrics IN user32 INTEGER nIndex

            DECLARE INTEGER CreateEllipticRgn IN gdi32;
                INTEGER nLeftRect, INTEGER nTopRect,;
                INTEGER nRightRect, INTEGER nBottomRect

            DECLARE INTEGER  CreateRoundRectRgn IN gdi32 ;
             INTEGER x1, INTEGER Y1,;
             INTEGER x2, INTEGER y2,;
             INTEGER x3, INTEGER y3

            DECLARE INTEGER SetWindowRgn IN user32;
                INTEGER hWnd, INTEGER hRgn, INTEGER bRedraw
    ENDPROC

    PROCEDURE MouseMove
        LPARAMETERS nButton, nShift, nXCoord, nYCoord
    ENDPROC

    PROCEDURE MouseDown
        LPARAMETERS nButton, nShift, nXCoord, nYCoord
        DECLARE INTEGER GetFocus IN WIN32API
        lnHandle = thisform.hwnd  &&GetFocus()
        param1 = 274
        param2 = 0xF012
        DECLARE INTEGER ReleaseCapture IN WIN32API
        DECLARE INTEGER SendMessage IN WIN32API INTEGER, INTEGER, INTEGER, INTEGER
        bb=ReleaseCapture()
        bb=SendMessage(lnHandle, param1, param2,0)
    ENDPROC

    PROCEDURE Move
        LPARAMETERS nLeft, nTop, nWidth, nHeight
    ENDPROC

    PROCEDURE Activate

        this.regionOn
    ENDPROC

    PROCEDURE Init
        publi m.yrep
        m.yrep=addbs(justpath(sys(16,1)))
        set defa to (yrep)

        publi xtype
        xtype=1
          this.setall("mousepointer",15)

        _Sol_SetWindowLong(THISFORM.hWnd, -20, 0x00080000)
        _Sol_SetLayeredWindowAttributes(THISFORM.hWnd, 0,255, 2)
    ENDPROC

    PROCEDURE KeyPress
        LPARAMETERS nKeyCode, nShiftAltCtrl
        if nkeycode=27
        thisform.release
        endi
    ENDPROC

    PROCEDURE Destroy
        clea events
    ENDPROC

    PROCEDURE label1.Click
        clea
        thisform.release
    ENDPROC

    PROCEDURE label2.Click
        thisform.windowstate=1
    ENDPROC

    PROCEDURE spinner1.InteractiveChange
        lnValue=this.value
        _Sol_SetLayeredWindowAttributes(THISFORM.hWnd, 0,lnValue, 2)
        this.tooltiptext="Transparency="+trans(lnValue)
    ENDPROC

    PROCEDURE spinner1.Init
        this.value=200
    ENDPROC

    PROCEDURE imgcanvas1.MouseLeave
        LPARAMETERS nButton, nShift, nXCoord, nYCoord
    ENDPROC

    PROCEDURE imgcanvas1.beforedraw
        LOCAL loBrush AS xfcLinearGradientBrush

        black  = RGB(0,0,0)
        blue   = RGB(0,0,255)
        green  = RGB(0,255,0)
        cyan   = RGB(0,255,255)
        red    = RGB(255,0,0)
        pink   = RGB(255,0,255)
        yellow = RGB(255,255,0)
        white  = RGB(255,255,255)
        grey   = RGB(192,192,192)

        WITH _Screen.System.Drawing
        This.Clear()

        tncolor1=red
        tncolor2=green

        &&linearGradientBrush color
           loBrush = .Drawing2D.LinearGradientBrush.New(This.Rectangle,;
             .Color.FromRGB(tncolor1), ;
             .Color.FromRGB(tncolor2),;
             2)
          This.oGfx.FillRectangle(loBrush, This.Rectangle)
        &&title
          yTitle="yRoundRect"
           xsize=14
          
fn = .Font.New([Verdana],;
            xsize)
            sf = .StringFormat.GenericTypographic.Clone()
            sf.Alignment = 1 && StringAlignment.Center
            sf.LineAlignment = 1 && StringAlignment.Center
            this.oGfx.DrawString(ytitle, fn, .Brushes.blue, ;
                .RectangleF.New(30, 5, This.Width , 20),sf)    

        &&text

         local m.ystr
          text to m.ystr noshow
        This movable form can be round ,rectangular,or elliptic(circular).
        Its build with APIs createEllipticRegion, createRoundrectRegion and SetWindowRgn.
        The form transparency is checked in the spinner(255-0).
        Press ESC to release the form -or [X].

        Yousfi Benameur El Bayadh Algeria Saturday November 15 2008
        endtext        
    
         fn = .Font.New([Arial],;
9,.FontStyle.Bold)        
            sf = .StringFormat.GenericTypographic.Clone()
            sf.Alignment = 1   &&1  StringAlignment.Center
            sf.LineAlignment = 1&& 1 StringAlignment.Center
            this.oGfx.DrawString(m.ystr, fn, .Brushes.Black, ;
                .RectangleF.New(0, 25, This.Width-20, This.Height-10 ), sf)
        &&if want logo-icone (png)
        *this.oGfx.DrawImage(thisform.oBmpLogo, 0, 0) 
        fn.Dispose()
        ENDWITH
    ENDPROC

    PROCEDURE imgcanvas1.DragDrop
        LPARAMETERS oSource, nXCoord, nYCoord
    ENDPROC

    PROCEDURE imgcanvas1.MouseMove
        LPARAMETERS nButton, nShift, nXCoord, nYCoord
    ENDPROC

    PROCEDURE imgcanvas1.MouseDown
        LPARAMETERS nButton, nShift, nXCoord, nYCoord
        DECLARE INTEGER GetFocus IN WIN32API
        lnHandle =thisform.hwnd  && GetFocus()
        param1 = 274
        param2 = 0xF012
        DECLARE INTEGER ReleaseCapture IN WIN32API
        DECLARE INTEGER SendMessage IN WIN32API INTEGER, INTEGER, INTEGER, INTEGER
        bb=ReleaseCapture()
        bb=SendMessage(lnHandle, param1, param2,0)
    ENDPROC

    PROCEDURE optiongroup1.Click

        do case
        case this.Value=1
        IF THISform.hRgn <> 0    &&region off
                = SetWindowRgn(GetFocus(), 0, 1)
                THISform.hRgn=0
         ENDIF

        case this.value=2
        xtype=1
        IF THISform.hRgn <> 0    &&region off
                = SetWindowRgn(GetFocus(), 0, 1)
                THISform.hRgn=0
            ENDIF
        *inkey(1)    &&views the normal form
        thisform.RegionOn

        case this.value=3
        xtype=2

        IF THISform.hRgn <> 0    &&region off
                = SetWindowRgn(GetFocus(), 0, 1)
                THISform.hRgn=0
            ENDIF
        *inkey(1)    &&views the normal form
        thisform.RegionOn

        endcase
    ENDPROC

    PROCEDURE optiongroup2.Click
        if this.value=0
        thisform.imgCanvas1.visible=.f.
        else
        thisform.imgCanvas1.visible=.t.
        endi
    ENDPROC

    PROCEDURE optiongroup3.Click
        local m.lcdest
        m.lcdest=m.yrep+"_"+sys(2015)+".png"
        thisform.imgcanvas1.obmp.save(m.lcdest,_screen.system.drawing.imaging.imageformat.png)
        if file(m.lcdest)
        messagebox(m.lcdest +".....saved!",0+32+4096,'',600)
        endi
    ENDPROC

ENDDEFINE
*

*End code

 


these can be done with the last example (6) of :http://yousfi.over-blog.com/2015/03/form-transparencies-in-visual-foxpro.html
these can be done with the last example (6) of :http://yousfi.over-blog.com/2015/03/form-transparencies-in-visual-foxpro.html
these can be done with the last example (6) of :http://yousfi.over-blog.com/2015/03/form-transparencies-in-visual-foxpro.html
these can be done with the last example (6) of :http://yousfi.over-blog.com/2015/03/form-transparencies-in-visual-foxpro.html

these can be done with the last example (6) of :http://yousfi.over-blog.com/2015/03/form-transparencies-in-visual-foxpro.html


*2*-*this code draws a polygon curve point by point from a defined cursor.

Can make a small cursor filling with  the points you want to capture for a curve you want to produce (can use on click the native  function form.point)
i used this similar code for the free hand capture region in this link

http://yousfi.over-blog.com/2015/02/free-hand-capturing-as-bitmaps.html
Here the points are random on the form area and then are randomly distributed without raising a known curve.A transparency region is applied with the cosntant ( #Define RGN_XOR 3)
the code uses a cursor of points, the APIS
 CreateRectRgn,CombineRgn ,SetWindowRgn and the windows  appropried constants.


*begin code

clea all
_Screen.WindowState=1
Publi yform
yform=Newobject("oform")
yform.Show
Read Events
Return
*
Define Class oform As Form
    BorderStyle = 0
    Top = 0
    Left = 0
    Height = 768
    Width = 1024
    ShowWindow = 2
    Caption = "Form1"
    *Movable = .F.
    FillStyle = 0
    KeyPreview = .T.
    TitleBar = 1
    FillColor = Rgb(255,166,166)
    BackColor=0
    Caption ="Make any polygon region with a cursor of points (close figure)"
    posx = 0
    posy = 0
    hrgn = 0
    hrgnbase =0
    Name = "yFreeHand"

    Procedure Init
        Local m.npoints
        m.npoints=25
        For i=1 To m.npoints
            Insert Into ycurs Values (Thisform.Width*Rand(),Thisform.Height*Rand())
        Endfor
        Locate
        Insert Into ycurs Values(x,Y)  &&close figure with first point
        Sele ycurs
        *Brow
    Endproc

    Procedure Activate
        Thisform.ForeColor=255
        Thisform.DrawWidth=3
        Thisform.ScaleMode=3  &&pixels
        Thisform.PSet(x,Y)
        Scan
            Thisform.Line(x,Y)  && to show the drawing phisycally only (for test).
        Endscan
        Thisform.yregionON()
    Endproc

    Procedure yregionON
        This.hrgnbase=0
        This.hrgn=0
        This.hrgnbase = CreateRectRgn(0, 0, This.Width+2*Sysmetric(3), This.Height+2*Sysmetric(4)+Sysmetric(9))

        #Define Alternate 1
        #Define WINDING 2
        lcPoints = Space(0)

        Sele ycurs
        Scan
            lcPoints = lcPoints + Thisform.num2dword(x) + Thisform.num2dword(Y)
        Endscan
        This.hrgn   =CreatePolygonRgn(@lcPoints,Reccount() ,WINDING)


        #Define RGN_XOR 3  &&make the region transparent
        Local m.yy
        m.yy=  CombineRgn(This.hrgnbase, This.hrgnbase, This.hrgn, RGN_XOR)
        Local m.xx
        m.xx = SetWindowRgn(Thisform.HWnd, This.hrgnbase, "TRUE")  &&.t. dont work ?

        DeleteObject(This.hrgn)
        DeleteObject(This.hrgnbase)
        Thisform.Cls  &&clear red drawing
    Endproc

    Procedure Load
        Declare Integer Sleep In kernel32 Integer
        Declare Integer CreateRectRgn In gdi32;
            INTEGER nLeftRect, Integer nTopRect,;
            INTEGER nRightRect, Integer nBottomRect

        Declare Integer CombineRgn In gdi32;
            INTEGER hrgnDest, Integer hrgnSrc1,;
            INTEGER hrgnSrc2,;
            INTEGER fnCombineMode

        Declare Long SetWindowRgn In WIN32API Long HWnd, Long hRgn, String bRedraw
        Declare Integer CreatePolygonRgn In gdi32 String@ pPoints, Integer nPoints, Integer nfillmode    &&vfp declaration
        Declare Integer DeleteObject In gdi32   Integer hObject
        Create Cursor ycurs (x i,Y i)
    Endproc

    Procedure num2dword
        Lparameters lnValue
        #Define m0 0x0000100
        #Define m1 0x0010000
        #Define m2 0x1000000
        If lnValue < 0
            lnValue = 0x100000000 + lnValue
        Endif
        Local b0, b1, b2, b3
        b3 = Int(lnValue/m2)
        b2 = Int((lnValue - b3*m2)/m1)
        b1 = Int((lnValue - b3*m2 - b2*m1)/m0)
        b0 = Mod(lnValue, m0)
        Return Chr(b0)+Chr(b1)+Chr(b2)+Chr(b3)
    Endproc

    Procedure Destroy
        This.hrgn=Null
        This.hrgnbase=Null
        Clea Dlls
        Clea Events
Enddefine

*endcode


This is a random points closing figure as poygon region.

This is a random points closing figure as poygon region.


*3*This draws a 5 star transparent region

*begin code

clea all
_Screen.WindowState=1
Publi yform
yform=Newobject("oform")
yform.Show
Read Events
Return
*
Define Class oform As Form
BorderStyle = 0
Top = 0
Left = 0
Height =768
Width = 1024
ShowWindow = 2
AutoCenter=.T.
Caption = "Form1"
FillStyle = 0
KeyPreview = .T.
TitleBar = 1
FillColor = Rgb(255,166,166)
BackColor=0
Caption ="Make any polygon region with a cursor of points (close figure)"
posx = 0
posy = 0
hrgn = 0
hrgnbase =0

picture=getpict()  &&in option
Name = "yFreeHand"

Procedure Init
Local m.npoints
m.npoints=25

Locate
Insert Into ycurs Values(x,Y) &&close figure with first point
Sele ycurs
*Brow
Endproc

Procedure Activate
Thisform.ForeColor=255
Thisform.DrawWidth=3
Thisform.ScaleMode=3 &&pixels
Thisform.PSet(x,Y)
Scan
Thisform.Line(x,Y) && to show the drawing phisycally only (for test).
Endscan
Thisform.yregionON()
Endproc

Procedure yregionON
This.hrgnbase=0
This.hrgn=0
This.hrgnbase = CreateRectRgn(0, 0, This.Width+2*Sysmetric(3), This.Height+2*Sysmetric(4)+Sysmetric(9))

#Define Alternate 1
#Define WINDING 2
lcPoints = Space(0)

Sele ycurs
Scan
lcPoints = lcPoints + Thisform.num2dword(x) + Thisform.num2dword(Y)
Endscan
This.hrgn =CreatePolygonRgn(@lcPoints,Reccount() ,WINDING)


#Define RGN_XOR 3 &&make the region transparent
Local m.yy
m.yy= CombineRgn(This.hrgnbase, This.hrgnbase, This.hrgn, RGN_XOR)
Local m.xx
m.xx = SetWindowRgn(Thisform.HWnd, This.hrgnbase, "TRUE") &&.t. dont work ?

DeleteObject(This.hrgn)
DeleteObject(This.hrgnbase)
Thisform.Cls &&clear red drawing
Endproc

Procedure Load
Declare Integer Sleep In kernel32 Integer
Declare Integer CreateRectRgn In gdi32;
INTEGER nLeftRect, Integer nTopRect,;
INTEGER nRightRect, Integer nBottomRect

Declare Integer CombineRgn In gdi32;
INTEGER hrgnDest, Integer hrgnSrc1,;
INTEGER hrgnSrc2,;
INTEGER fnCombineMode

Declare Long SetWindowRgn In WIN32API Long HWnd, Long hRgn, String bRedraw
Declare Integer CreatePolygonRgn In gdi32 String@ pPoints, Integer nPoints, Integer nfillmode &&vfp declaration
Declare Integer DeleteObject In gdi32 Integer hObject
Create Cursor ycurs (x i,Y i)
Insert Into ycurs Values(512,184)
Insert Into ycurs Values(568,307)
Insert Into ycurs Values(702,322)
Insert Into ycurs Values(602,413)
Insert Into ycurs Values(630,546)
Insert Into ycurs Values(512,479)
Insert Into ycurs Values(394,546)
Insert Into ycurs Values(422,413)
Insert Into ycurs Values(322,322)
Insert Into ycurs Values(456,307)
Insert Into ycurs Values(512,184)
Endproc

Procedure num2dword
Lparameters lnValue
#Define m0 0x0000100
#Define m1 0x0010000
#Define m2 0x1000000
If lnValue < 0
lnValue = 0x100000000 + lnValue
Endif
Local b0, b1, b2, b3
b3 = Int(lnValue/m2)
b2 = Int((lnValue - b3*m2)/m1)
b1 = Int((lnValue - b3*m2 - b2*m1)/m0)
b0 = Mod(lnValue, m0)
Return Chr(b0)+Chr(b1)+Chr(b2)+Chr(b3)
Endproc

Procedure Destroy
This.hrgn=Null
This.hrgnbase=Null
Clea Dlls
Clea Events
Enddefine

*endcode

*If issue in code
*#define RGN_AND 1
*m.yy=  CombineRgn(This.hrgnbase, This.hrgnbase, This.hrgn, RGN_AND)
 *you obtain the plain  star figure  as secong image below  only(ALT+F4 to close the form)


can make any color in  backcolor (even draw  gradient) or make a picture to clip  it in region .
can make any color in  backcolor (even draw  gradient) or make a picture to clip  it in region .
can make any color in  backcolor (even draw  gradient) or make a picture to clip  it in region .
can make any color in  backcolor (even draw  gradient) or make a picture to clip  it in region .

can make any color in backcolor (even draw gradient) or make a picture to clip it in region .

*4-* this code demonstrates using of paths,fonts,regions

this code is adapted from original old news2news post : http://www.news2news.com/vfp/index.php?example=144
i make some changes and added a contextuel menu

The form even clipped is movable by mousedown.
 

Right click to

-set any short text to clip
-Clip form region
-Restore initial form
-Invert the clipped text backcolor
.

 


*Begin code

clea all
Do ydeclare

Public frm
frm = Createobject("oform")
frm.Show
Read Events
Retu
*
Define Class oform As Form
    Width=700
    Height=250
    Caption="Working with GDI Path and Region (rightclick..)"
    mouseX=0
    mouseY=0
    MousePointer=15
    ShowWindow=2
    BorderStyle=2
    AutoCenter=.T.
    BackColor =Rgb(215,160,150)
    hFontHeader=0
    hFontMemo=0
    ShowWindow=2
    nMode=.F.
    ytext="Foxpro is rock!"

    Procedure  Init
        This.createFont
    Endproc

    Procedure Activate
        Messagebox("Right click for contextuel menu!",0+32+4096,'',1000)
    Endproc

    Procedure  Destroy
        This.releaseFont
        Clea Events
    Endproc

    Procedure  removeRgn
        This.removeRegion
    Endproc

    Procedure MouseDown
        Lparameters nButton, nShift, nXCoord, nYCoord
        * stores cursor absolute position
        If nButton = 1
            Local lnX, lnY
            = getMousePos (@lnX, @lnY)
            Thisform.mouseX = lnX
            Thisform.mouseY = lnY
        Endif
    Endproc

    Procedure MouseMove
        Lparameters nButton, nShift, nXCoord, nYCoord
        If nButton = 1
            Thisform._move && moves the form
        Endif
    Endproc

    Procedure   oClip()
        Thisform.clipText
    Endproc

    Procedure  createFont
        #Define FW_BOLD             700
        #Define FW_NORMAL           400
        #Define ANSI_CHARSET          0
        #Define OUT_OUTLINE_PRECIS    8
        #Define CLIP_STROKE_PRECIS    2
        #Define PROOF_QUALITY         2
        #Define DEFAULT_PITCH         0

        This.hFontHeader = createFont (;
            100,0, 0,0, FW_BOLD,0,0,0, ANSI_CHARSET,;
            OUT_OUTLINE_PRECIS, CLIP_STROKE_PRECIS,;
            PROOF_QUALITY, DEFAULT_PITCH, "georgia")

        This.hFontMemo = createFont (;
            32,0, 0,0, FW_NORMAL, 0,1,0, ANSI_CHARSET,;
            OUT_OUTLINE_PRECIS, CLIP_STROKE_PRECIS,;
            PROOF_QUALITY, DEFAULT_PITCH, "Segoe script")
    Endproc

    Procedure  releaseFont
        = DeleteObject (This.hFontMemo)
        = DeleteObject (This.hFontHeader)
    Endproc

    Procedure  clipText
        #Define TRANSPARENT  1
        #Define OPAQUE       2
        #Define RGN_COPY     5
        Local lcText, HWnd, hdc, hStoredFont
        HWnd = Thisform.HWnd   
        hdc = GetWindowDC (HWnd)

        = BeginPath (hdc)
        hStoredFont = SelectObject (hdc, This.hFontHeader)
        = SetBkMode (hdc, Iif(Thisform.nMode , OPAQUE,TRANSPARENT))
        This._print (hdc, 15,25, " "+Alltrim(Thisform.ytext)+" ")

        = SelectObject (hdc, This.hFontMemo)
        = SetBkMode (hdc, OPAQUE)
        This._print (hdc, 15,125, " Right click to fire the contextuel menu")
        This._print (hdc, 15,160, " The form is movable by mouseDown")
        = EndPath (hdc)

        hRgn = PathToRegion (hdc)
        = SetWindowRgn (HWnd, hRgn, 1)

        = SelectObject (hdc, hStoredFont)
        = ReleaseDC (HWnd, hdc)

    Procedure  _print (hdc, X,Y, lcText)
        = TextOut (hdc, X,Y, lcText, Len(lcText))

    Procedure  removeRegion
        Local HWnd
        HWnd = Thisform.HWnd   &&GetFocus()
        = SetWindowRgn (HWnd, 0, 1)

    Procedure _move
        Local lnX, lnY, lnPosX, lnPosY
        = getMousePos (@lnX, @lnY) && gets cursor absolute position

        If Not (Thisform.mouseX = lnX And Thisform.mouseY = lnY)
            * moves the form only if cursor absolute position changed
            lnPosX = Thisform.Left + (lnX - Thisform.mouseX)
            lnPosY = Thisform.Top + (lnY - Thisform.mouseY)
            Thisform.Move (lnPosX, lnPosY)

            * stores the current
            Thisform.mouseX = lnX
            Thisform.mouseY = lnY
        Endif

  

Procedure RightClick
        Define Popup raccourci SHORTCUT Relative From Mrow(),Mcol()
        Define Bar 1 Of raccourci Prompt "clip form"
        Define Bar 2 Of raccourci Prompt "Restore form"
        Define Bar 3 Of raccourci Prompt "inverse"
        Define Bar 4 Of raccourci Prompt "Input a text here"
        Define Bar 5 Of raccourci Prompt "Change background color"
        Define Bar 6 Of raccourci Prompt "exit"

        On Selection Bar 1 Of raccourci  _Screen.ActiveForm.oClip()
        On Selection Bar 2 Of raccourci  _Screen.ActiveForm.removeRgn()
        On Selection Bar 3 Of raccourci ;
            DO _4as0quypg
        On Selection Bar 4 Of raccourci ;
            DO _4as0xlbfj
        On Selection Bar 5 Of raccourci  _Screen.ActiveForm.backcolor=getcolor()
        On Selection Bar 6 Of raccourci _Screen.ActiveForm.Release

        Activate Popup raccourci

     endproc

Enddefine


Procedure _4as0quypg
    With _Screen.ActiveForm
        .nMode=!.nMode
        .oClip()
    Endwith
Endproc

Procedure _4as0xlbfj
    Local xtext
    m.xtext=Inputbox("Input a short text here","","Foxpro is rock")
    If Empty(m.xtext)
        m.xtext="Foxpro is rock!"
    Endi
    With _Screen.ActiveForm
        .ytext=m.xtext
        .oClip()
    Endwith
Endproc

Procedure  ydeclare
    Declare Integer GetWindowDC In user32 Integer HWnd
    Declare Integer GetFocus In user32
    Declare Integer ReleaseDC In user32;
        INTEGER HWnd, Integer hdc

    Declare Integer SelectObject In gdi32;
        INTEGER hdc, Integer hObject

    Declare Integer DeleteObject In gdi32 Integer hObject

    Declare Integer SetBkMode In gdi32;
        INTEGER hdc, Integer iBkMode

    Declare Integer TextOut In gdi32;
        INTEGER hdc, Integer x, Integer Y,;
        STRING  lpString, Integer nCount

    Declare Integer CreateFont In gdi32;
        INTEGER nHeight, Integer nWidth,;
        INTEGER nEscapement, Integer nOrientation,;
        INTEGER fnWeight, Integer fdwItalic,;
        INTEGER fdwUnderline, Integer fdwStrikeOut,;
        INTEGER fdwCharSet,;
        INTEGER fdwOutputPrecision,;
        INTEGER fdwClipPrecision,;
        INTEGER fdwQuality,;
        INTEGER fdwPitchAndFamily,;
        STRING  lpszFace

    Declare Integer BeginPath In gdi32 Integer hdc
    Declare Integer EndPath In gdi32 Integer hdc
    Declare Integer PathToRegion In gdi32 Integer hdc

    Declare SetWindowRgn In user32;
        INTEGER HWnd, Integer hRgn, Integer bRedraw

    Declare Integer GetCursorPos In user32 String @ lpPoint
Endproc

Procedure getMousePos (X, Y)
    Local lcBuffer
    lcBuffer = Repli(Chr(0), 8)
    = GetCursorPos (@lcBuffer)
    X = buf2dword(Substr(lcBuffer, 1,4))
    Y = buf2dword(Substr(lcBuffer, 5,4))
Endproc

Function buf2dword (lcBuffer)
    Return Asc(Substr(lcBuffer, 1,1)) + ;
        Asc(Substr(lcBuffer, 2,1)) * 256 +;
        Asc(Substr(lcBuffer, 3,1)) * 65536 +;
        Asc(Substr(lcBuffer, 4,1)) * 16777216
Endfunc

*can also use this code to move the form with nmousedown

* Procedure MouseDown
*        Lparameters nButton, nShift, nXCoord, nYCoord
*        lnHandle = Thisform.HWnd    &&getFocus()
*        param1 = 274
*        param2 = 0xF012
*        Declare Integer ReleaseCapture In WIN32API
*        Declare Integer SendMessage In WIN32API Integer, Integer, Integer, Integer
*        bb=ReleaseCapture()
*        bb=SendMessage(lnHandle, param1, param2,0)
*    Endproc

*End code


These images are clipped forms.if you make adapted background image , can clip text on image and have a cool effect.
These images are clipped forms.if you make adapted background image , can clip text on image and have a cool effect.
These images are clipped forms.if you make adapted background image , can clip text on image and have a cool effect.

These images are clipped forms.if you make adapted background image , can clip text on image and have a cool effect.


*5-*this code uses an API to make transprent shapes on a form as holes,...
*can chose opacity(transparency) to dont access objects behind the form
*This use the color key to make only he wanted color transparent.
*this uses the API SetLayeredWindowAttributes.

*Begin Code

clea all

_screen.windowstate=1
Publi yform
yform=Newobject("yholes")
yform.Show
Read Events
Return
*
Define Class yholes As Form
    BorderStyle = 3
    Height = 369
    Width = 858
    ShowWindow = 2
    AutoCenter = .T.
    Caption = "ColorKey transparency on top level form"
    BackColor = Rgb(0,0,0)
    Name = "Form1"

    Add Object shape1 As Shape With ;
        Top = 72, ;
        Left = 648, ;
        Height = 157, ;
        Width = 157, ;
        Curvature = 99, ;
        BackColor = Rgb(255,0,128), ;
        Name = "Shape1"

    Add Object label1 As Label With ;
        FontBold = .T., ;
        FontName = "Arial Black", ;
        FontShadow = .F., ;
        FontSize = 60, ;
        WordWrap = .T., ;
        BackStyle = 0, ;
        Caption = "FOXPRO IS ROCK !", ;
        Height = 220, ;
        Left = 36, ;
        Top = 48, ;
        Width = 517, ;
        ForeColor = Rgb(255,0,128), ;
        Name = "Label1"

    Procedure Load
        Declare Integer GetWindowLong In user32;
            INTEGER HWnd, Integer nIndex

        Declare Integer SetWindowLong In user32;
            INTEGER HWnd, Integer nIndex, Integer dwNewLong

        Declare Integer SetLayeredWindowAttributes In user32;
            INTEGER HWnd, Integer crKey,;
            SHORT bAlpha, Integer dwFlags
    Endproc

    Procedure Init
        #Define LWA_COLORKEY 1
        #Define LWA_ALPHA 2
        #Define GWL_EXSTYLE -20
        #Define WS_EX_LAYERED 0x80000

        Local nExStyle, nRgb, nAlpha, nFlags
        nExStyle = GetWindowLong(Thisform.HWnd, GWL_EXSTYLE)
        nExStyle = Bitor(nExStyle, WS_EX_LAYERED)
        = SetWindowLong(Thisform.HWnd, GWL_EXSTYLE, nExStyle)

        = SetLayeredWindowAttributes(Thisform.HWnd, Rgb(255,0,128), 80,LWA_COLORKEY)   &&+LWA_ALPHA

    Endproc

    Procedure Destroy
        Clea Events
    Endproc


Enddefine
*

*End code*

 


 Working with Regions and APIs in visual foxpro
 Working with Regions and APIs in visual foxpro

*6-*This code draws elliptic regions on a form and make transparency as holes

*on the form with the XOR constant.

*Begin code

clea all
Do ydeclare

#Define RGN_OR 2
#Define RGN_AND 1
#Define RGN_XOR 3
#Define RGN_DIFF 4
#Define RGN_COPY 5
#Define NULLREGION 1
#Define SIMPLEREGION 2
#Define COMPLEXREGION 3
#Define r_ERROR 0


Public ofrm
ofrm=Createobject("MyForm")
ofrm.Visible=.T.

Define Class MyForm As Form
    ShowWindow=2
    AutoCenter=.T.
    Width=800
    Height=600
    nHoles=5
    ncount=0
    Caption="Wait to Show 3 regions (one by 5 seconds)"
    Add Object timer1 As Timer With ;
        interval=5000,;
        name="timer1"

    Procedure Init
        _Screen.WindowState=1
        Thisform.BackColor=0
        Thisform.timer1.Enabled=.T.
    Endproc

    Procedure Resize
        Try
            Thisform.timer1.Enabled=.T.
        Catch
        Endtry
    Endproc

    Procedure regionOn1
        Local lox0,X1,X2,x3
        lnPow0=1
        lox0 = CreateRectRgn(0, 0, This.Width+2*Sysmetric(3), This.Height+2*Sysmetric(4)+Sysmetric(9))
        X1=CreateEllipticRgn(This.Width/5,This.Height/5,This.Width*0.8,This.Height*0.8)
        X2=CreateEllipticRgn(This.Width*.4,This.Height*.3,This.Width*.7,This.Height*.7)
        CombineRgn(X1,X1,X2,RGN_DIFF)
        CombineRgn(lox0,lox0,X1,RGN_DIFF)
        SetWindowRgn(Thisform.HWnd, lox0, "True")  &&dont work with .t. or 1  !
    Endproc

 

    Procedure regionOn2
        Local lox0,lax[This.nHoles],lnPow0,lnLeft,lnRight,lni,lnWidth,lnHeight
        lnPow0=0.2
        lox0 = CreateRectRgn(0, 0, This.Width+2*Sysmetric(3), This.Height+2*Sysmetric(4)+Sysmetric(9))
        For lni=1 To This.nHoles
            lnLeft=(2^(lni+lnPow0)-1)/2^(lni+lnPow0+1)
            lnRight=(2^(lni+lnPow0)+1)/2^(lni+lnPow0+1)
            lax[lni]=CreateEllipticRgn(This.Width*lnLeft,This.Height*lnLeft,This.Width*lnRight,This.Height*lnRight)
            If lni>1
                CombineRgn(lax[1],lax[1],lax[lni],RGN_XOR)
            Endif
        Next
        CombineRgn(lox0,lox0,lax[1],RGN_DIFF)
        SetWindowRgn(Thisform.HWnd, lox0, "True")
    Endproc

    Procedure  timer1.Timer
        With Thisform
            .ncount=.ncount+1
            If .ncount>2
                .ncount=0
            Endi

            Do Case
                Case Thisform.ncount=0
                    Local HWnd
                    = SetWindowRgn (.HWnd, 0, "True") &&dont work with .t. or 1 !
                    *This.Enabled=.F.

                Case .ncount=1
                    .regionOn1()

                Case .ncount=2
                    .regionOn2()
            Endcase
        Endwith
    Endproc

Enddefine

Procedure ydeclare
    Declare Integer GetWindowRect In user32;
        INTEGER hWindow,;
        STRING @lpRect
    Declare Long CombineRgn In WIN32API Long hrgnDest, Long hrgnSrc1, Long hrgnSrc2, Long fnCombineMode
    Declare Long SetWindowRgn In WIN32API Long HWnd, Long hRgn, String bRedraw
    Declare Long CreateEllipticRgn In WIN32API Long X1, Long Y1, Long X2, Long Y2
    Declare Long CreateRectRgn In WIN32API Long X1, Long Y1, Long X2, Long Y2
    Declare Integer Sleep In kernel32 Integer
Endproc

*end Code


 Working with Regions and APIs in visual foxpro

*7*-
* This is a simple program demonstrating masked region forms.
*Adapted from original work by Rick C. Hodgin
* *The same principle applied here works with pixel-by-pixel bitmaps as per a mask image. The *mechanics of how you read those bits in are application specific, but just create a 1x1 pixel *region and use the same logic as below to remove it.
* I typically use white pixels for where I want the image to show (they are ASC(255) inside the *bitmap image)  and black pixels where I want the parts deleted (they are ASC(0) inside the *bitmap image). 32-bit bitmaps are.
*Begin code

Publi yform
yform=Newobject("rhodgin")
yform.Show
Read Events
Retu
*
Define Class rhodgin As Form
    BorderStyle = 2
    Height = 368
    Width = 836
    ShowWindow = 2
    AutoCenter = .T.
    Caption = "Region APIs"
    MaxButton = .F.
    BackColor = Rgb(155,225,0)
    Name = "Form1"

    Procedure mth_setup
        Lparameters tnMult, tnWidth, tnHeight, taMask
        External Array taMask
        Local lnRow, lnCol, lo, lnLeft, lnTop, lnWidth, lnHeight, lcName, lnWindowRgn, lnThisBlockRgn, lnCombinedRgn
        * Declare required region functions
        #Define RGN_AND     1
        #Define RGN_OR      2
        #Define RGN_XOR     3

        * Set the parameters
        lnWidth         = Sysmetric(3)  + tnWidth   + Sysmetric(3)
        lnHeight        = Sysmetric(4)  + tnHeight  + Sysmetric(4) + Sysmetric(9)
        lnLeft          = Sysmetric(3)
        lnTop           = Sysmetric(9) + Sysmetric(4)
        Thisform.Width  = lnWidth
        Thisform.Height = lnHeight
        * Create the base region
        lnWindowRgn = CreateRectRgn(0, 0, 1920*2, 1080*2)
        * Build region rectangles and overlay the boxes which will provide the outline
        * Iterate for every row
        For lnRow = 1 To Alen(taMask, 1)

            * Iterate for every column on that row
            For lnCol = 1 To Len(taMask[lnRow])

                * Is this a hole?
                If Substr(taMask[lnRow], lnCol, 1) != "."
                    * Yes
                    * Create the color object
                    lcName          = "shp" + Transform(lnRow) + "_" + Transform(lnCol)
                    Thisform.AddObject(lcName, "Shape")
                    With Thisform.&lcName
                        .Left       = (lnCol * tnMult) - 2
                        .Top        = (lnRow * tnMult) - 2
                        .Width      = tnMult + 4
                        .Height     = tnMult + 4
                        .BackColor  = Rgb(0,0,0)  && Black
                    Endwith

                    * Create the associated region
                    lnThisBlockRgn  = CreateRectRgn(lnLeft + (lnCol*tnMult), ;
                        lnTop  + (lnRow*tnMult), ;
                        lnLeft + ((lnCol+1)*tnMult), ;
                        lnTop  + ((lnRow+1)*tnMult))

                    * Combine the two regions by removing this block
                    CombineRgn(lnWindowRgn, lnWindowRgn, lnThisBlockRgn, RGN_XOR)

                    * Delete the temporary block region from our collective memories.  May it region in peace.
                    DeleteObject(lnThisBlockRgn)
                Endif
            Next
        Next
        * Tell the window to respect the drawing region
        SetWindowRgn(Thisform.HWnd, lnWindowRgn, 1)

        * When all processing is completed, make it visible
        * Re-center after the resize
        Thisform.Left       = (_Screen.Width - Thisform.Width) / 2
        Thisform.Top        = (_Screen.Height - Thisform.Height) / 2
        Thisform.Visible    = .T.
    Endproc

    Procedure Destroy
        Clea Events
    Endproc

    Procedure Load
        Set Status          Off
        Set Bell            Off
        Set Dohistory       Off
        Set Talk            Off
        Set Status Bar      On
        Set Safety          Off
        Set Cpdialog        Off

        * Set the app paths
        *SET PROCEDURE   TO custom_shape_rgn.prg     ADDITIVE

        * Declare required region functions
        #Define RGN_AND     1
        #Define RGN_OR      2
        #Define RGN_XOR     3
        Declare Long    CreateRectRgn ;
            IN WIN32API ;
            LONG    nLeftRect, ;
            LONG    nTopRect, ;
            LONG    nRightRect, ;
            LONG    nBottomRect
        Declare Long    CombineRgn ;
            IN WIN32API ;
            LONG    hrgnDest, ;
            LONG    hrgnSrc1, ;
            LONG    hrgnSrc2, ;
            LONG    fnCombineMode
        Declare Long    SetWindowRgn ;
            IN WIN32API ;
            LONG    HWnd, ;
            LONG    hRgn, ;
            LONG    bRedraw
        Declare Long    DeleteObject ;
            IN WIN32API ;
            LONG    hObject
    Endproc

    Procedure Init


        _Screen.WindowState=1
        * Build our mask.  In this example, each character will be a mask bit and will
        * be multiplied into a (lnMult*lnMult) region.
        Declare laMask[18]
        laMask[1]   = "..OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO00000000..."
        laMask[2]   = ".O.............................................................................O..."
        laMask[3]   = ".O......OO00000000000000.......................................................O..."
        laMask[4]   = ".O......OO........................OOOO................OOOO0....................O..."
        laMask[5]   = "..O.....OO.........OO0000000000......OOOO............0000......................O..."
        laMask[6]   = "..O.....OO.........OO........00........0000.........OOOO.......................0..."
        laMask[7]   = ".O......OO.........OO........00..........0000......0000........................0..."
        laMask[8]   = ".O......OO0000000..OO........00............0000...0000..................... ...0..."
        laMask[9]   = ".O......OO0000000..OO........OO..............00OO0000..........................0..."
        laMask[10]  = "..O.....OO.........OO........OO.............0OO00000OO.........................0..."
        laMask[11]  = "..O.....OO.........OO........OO...........0000......OOOO.......................O..."
        laMask[12]  = ".O......OO.........OO........OO..........0000.........0000.....................O..."
        laMask[13]  = ".O......OO.........OO........OO.........0000...........0000....................0..."
        laMask[14]  = "..O.....OO.........OO........OO.......OOOO...............0000..................0..."
        laMask[15]  = "..OO....OO.........00........00.....00000..................00000..............00..."
        laMask[16]  = "..OO....OO.........000000000000...............................................0O..."
        laMask[17]  = "...OO000000000000000000000000000000000000000000000000000000000000000000000000OO...."
        laMask[18]  = "....OOOOOOOOOOOOO000OOOOOOOOOOOOOOOO000OOOOOOOOOOOOOO00000000000000000000000....."
        lnMult      = 12

        * Display the region form
        Thisform.mth_setup(lnMult, Len(laMask[1]) * lnMult, Alen(laMask,1) * lnMult, @laMask)
    Endproc

Enddefine
*

*End code

 


 Working with Regions and APIs in visual foxpro

*8*-

*this code draws algeria map.the points as said above are gathered automatically in a cursor by clicking on the contour of original map (point() vfp native function)
*the cursor produced is used in the code with regions

*can move the form (map) by mousedown

*begin code

clea all
_Screen.WindowState=1
Publi yform
yform=Newobject("oform")
yform.Show
Read Events
Return
*
Define Class oform As Form
    BorderStyle = 0
    Top = 0
    Left = 0
    Height = 380
    Width = 400
    ShowWindow = 2
    AutoCenter=.T.
    Caption = "Form1"
    FillStyle = 0
    KeyPreview = .T.
    TitleBar = 1
    FillColor = Rgb(255,166,166)
    BackColor=Rgb(0,255,0)   &&0
    Caption ="Make any polygon region with a cursor of points (close figure)"
    posx = 0
    posy = 0
    hrgn = 0
    hrgnbase =0

picture=getpict()  &&in option
    Name = "yFreeHand"

    Add Object label1 As Label With ;
        top=300,;
        left=40,;
        caption="Algeria translucid map",;
        forecolor=255,;
        fontsize=16,;
        height=25,;
        width=230,;
        backstyle=0,;
        name="label1"


    Procedure Init
        Local m.npoints
        m.npoints=25

        Locate
        Insert Into ycurs Values(x,Y)  &&close figure with first point
        Sele ycurs
        *Brow
    Endproc

    Procedure Activate
        Thisform.ForeColor=255
        Thisform.DrawWidth=3
        Thisform.ScaleMode=3  &&pixels
        Thisform.PSet(x,Y)
        Scan
            Thisform.Line(x,Y)  && to show the drawing phisycally only (for test).
        Endscan
        Thisform.yregionON()
    Endproc

    Procedure yregionON
        This.hrgnbase=0
        This.hrgn=0
        This.hrgnbase = CreateRectRgn(0, 0, This.Width+2*Sysmetric(3), This.Height+2*Sysmetric(4)+Sysmetric(9))

        #Define Alternate 1
        #Define WINDING 2
        lcPoints = Space(0)

        Sele ycurs
        Scan
            lcPoints = lcPoints + Thisform.num2dword(x) + Thisform.num2dword(Y)
        Endscan
        This.hrgn   =CreatePolygonRgn(@lcPoints,Reccount() ,WINDING)

          #Define RGN_XOR 3  &&make the region transparent
         #Define RGN_AND 1
        Local m.yy
        m.yy=  CombineRgn(This.hrgnbase, This.hrgnbase, This.hrgn, RGN_XOR)  &&
RGN_AND
        Local m.xx
        m.xx = SetWindowRgn(Thisform.HWnd, This.hrgnbase, "TRUE")  &&.t. dont work ?

        DeleteObject(This.hrgn)
        DeleteObject(This.hrgnbase)
        Thisform.Cls  &&clear red drawing
    Endproc

    Procedure Load
        Declare Integer Sleep In kernel32 Integer
        Declare Integer CreateRectRgn In gdi32;
            INTEGER nLeftRect, Integer nTopRect,;
            INTEGER nRightRect, Integer nBottomRect

        Declare Integer CombineRgn In gdi32;
            INTEGER hrgnDest, Integer hrgnSrc1,;
            INTEGER hrgnSrc2,;
            INTEGER fnCombineMode

        Declare Long SetWindowRgn In WIN32API Long HWnd, Long hRgn, String bRedraw
        Declare Integer CreatePolygonRgn In gdi32 String@ pPoints, Integer nPoints, Integer nfillmode    &&vfp declaration
        Declare Integer DeleteObject In gdi32   Integer hObject
        Create Cursor ycurs (x i,Y i)
        Insert Into ycurs Values (116,54)
        Insert Into ycurs Values (123,45)
        Insert Into ycurs Values (134,41)
        Insert Into ycurs Values (141,43)
        Insert Into ycurs Values (145,39)
        Insert Into ycurs Values (153,35)
        Insert Into ycurs Values (166,34)
        Insert Into ycurs Values (179,33)
        Insert Into ycurs Values (180,30)
        Insert Into ycurs Values (186,30)
        Insert Into ycurs Values (191,25)
        Insert Into ycurs Values (196,25)
        Insert Into ycurs Values (199,29)
        Insert Into ycurs Values (209,29)
        Insert Into ycurs Values (219,25)
        Insert Into ycurs Values (224,26)
        Insert Into ycurs Values (229,25)
        Insert Into ycurs Values (242,29)
        Insert Into ycurs Values (242,40)
        Insert Into ycurs Values (240,53)
        Insert Into ycurs Values (240,62)
        Insert Into ycurs Values (232,67)
        Insert Into ycurs Values (221,67)
        Insert Into ycurs Values (233,82)
        Insert Into ycurs Values (238,87)
        Insert Into ycurs Values (241,95)
        Insert Into ycurs Values (251,101)
        Insert Into ycurs Values (251,115)
        Insert Into ycurs Values (251,127)
        Insert Into ycurs Values (251,129)
        Insert Into ycurs Values (257,141)
        Insert Into ycurs Values (257,157)
        Insert Into ycurs Values (256,175)
        Insert Into ycurs Values (251,177)
        Insert Into ycurs Values (260,195)
        Insert Into ycurs Values (267,204)
        Insert Into ycurs Values (277,207)
        Insert Into ycurs Values (281,216)
        Insert Into ycurs Values (261,229)
        Insert Into ycurs Values (237,242)
        Insert Into ycurs Values (214,262)
        Insert Into ycurs Values (208,272)
        Insert Into ycurs Values (181,277)
        Insert Into ycurs Values (179,265)
        Insert Into ycurs Values (168,264)
        Insert Into ycurs Values (166,259)
        Insert Into ycurs Values (156,253)
        Insert Into ycurs Values (141,240)
        Insert Into ycurs Values (119,224)
        Insert Into ycurs Values (88,204)
        Insert Into ycurs Values (54,181)
        Insert Into ycurs Values (34,166)
        Insert Into ycurs Values (34,146)
        Insert Into ycurs Values (44,141)
        Insert Into ycurs Values (53,133)
        Insert Into ycurs Values (59,136)
        Insert Into ycurs Values (59,131)
        Insert Into ycurs Values (72,129)
        Insert Into ycurs Values (77,122)
        Insert Into ycurs Values (91,116)
        Insert Into ycurs Values (92,106)
        Insert Into ycurs Values (100,105)
        Insert Into ycurs Values (103,99)
        Insert Into ycurs Values (121,97)
        Insert Into ycurs Values (127,93)
        Insert Into ycurs Values (123,84)
        Insert Into ycurs Values (118,74)
        Insert Into ycurs Values (121,63)
        Insert Into ycurs Values (116,55)
        Locate
    Endproc

    Procedure num2dword
        Lparameters lnValue
        #Define m0 0x0000100
        #Define m1 0x0010000
        #Define m2 0x1000000
        If lnValue < 0
            lnValue = 0x100000000 + lnValue
        Endif
        Local b0, b1, b2, b3
        b3 = Int(lnValue/m2)
        b2 = Int((lnValue - b3*m2)/m1)
        b1 = Int((lnValue - b3*m2 - b2*m1)/m0)
        b0 = Mod(lnValue, m0)
        Return Chr(b0)+Chr(b1)+Chr(b2)+Chr(b3)
    Endproc

procedure mousedown
LPARAMETERS nButton, nShift, nXCoord, nYCoord
lnHandle =thisform.hwnd
param1 = 274
param2 = 0xF012
DECLARE INTEGER ReleaseCapture IN WIN32API
DECLARE INTEGER SendMessage IN WIN32API INTEGER, INTEGER, INTEGER, INTEGER
bb=ReleaseCapture()
bb=SendMessage(lnHandle, param1, param2,0)
endproc

    Procedure Destroy
        This.hrgn=Null
        This.hrgnbase=Null
        Clea Dlls
        Clea Events
Enddefine

*endcode

*If issue in code
*#define RGN_AND 1
*m.yy=  CombineRgn(This.hrgnbase, This.hrgnbase, This.hrgn, RGN_AND)
 *you obtain the plain second figure  in image below(ALT+F4  to close the form)

 


can make any color in  backcolor (even draw a gradient) or make a picture to clip  it in region .
can make any color in  backcolor (even draw a gradient) or make a picture to clip  it in region .
can make any color in  backcolor (even draw a gradient) or make a picture to clip  it in region .

can make any color in backcolor (even draw a gradient) or make a picture to clip it in region .

*9* This is another example of drawing a map point by point with a cursor
*it uses gdiplusX to draw and make some effects.
*point to system.app and gdip)lusX.vcx to make the code working

Updated on 03/12/15 02:11:33 PM

*Begin code
Do Locfile("system.app")
Set Classlib To Locfile("gdiplusX.vcx") AddI
Publi yform
yform=Newobject("ymap")
yform.Show
Release Classlib "gdiplusX"
Read Events
Return
*
Define Class ymap As Form
    Top = 29
    Left = 176
    Height = 295
    Width = 569
    ShowWindow = 2
    Caption = "Mousemove to see effects"
    ycount = .F.
    ye = .F.
    mousepointer0 = .F.

    Add Object imgcanvas1 As imgcanvas With ;
        Height = 289, ;
        Left = 2, ;
        MousePointer = 15, ;
        Top = 3, ;
        Width = 321, ;
        Name = "imgcanvas1"

    Add Object edit1 As EditBox With ;
        FontSize = 12, ;
        Enabled = .F., ;
        Height = 114, ;
        Left = 332, ;
        ScrollBars = 0, ;
        Top = 5, ;
        Width = 234, ;
        ForeColor = Rgb(255,0,0), ;
        DisabledForeColor = Rgb(255,0,0), ;
        Name = "Edit1"

    Procedure Load
    Create Cursor ycurs (x i,Y i)
    Insert Into ycurs Values (116,54)
    Insert Into ycurs Values (123,45)
    Insert Into ycurs Values (134,41)
    Insert Into ycurs Values (141,43)
    Insert Into ycurs Values (145,39)
    Insert Into ycurs Values (153,35)
    Insert Into ycurs Values (166,34)
    Insert Into ycurs Values (179,33)
    Insert Into ycurs Values (180,30)
    Insert Into ycurs Values (186,30)
    Insert Into ycurs Values (191,25)
    Insert Into ycurs Values (196,25)
    Insert Into ycurs Values (199,29)
    Insert Into ycurs Values (209,29)
    Insert Into ycurs Values (219,25)
    Insert Into ycurs Values (224,26)
    Insert Into ycurs Values (229,25)
    Insert Into ycurs Values (242,29)
    Insert Into ycurs Values (242,40)
    Insert Into ycurs Values (240,53)
    Insert Into ycurs Values (240,62)
    Insert Into ycurs Values (232,67)
    Insert Into ycurs Values (221,67)
    Insert Into ycurs Values (233,82)
    Insert Into ycurs Values (238,87)
    Insert Into ycurs Values (241,95)
    Insert Into ycurs Values (251,101)
    Insert Into ycurs Values (251,115)
    Insert Into ycurs Values (251,127)
    Insert Into ycurs Values (251,129)
    Insert Into ycurs Values (257,141)
    Insert Into ycurs Values (257,157)
    Insert Into ycurs Values (256,175)
    Insert Into ycurs Values (251,177)
    Insert Into ycurs Values (260,195)
    Insert Into ycurs Values (267,204)
    Insert Into ycurs Values (277,207)
    Insert Into ycurs Values (281,216)
    Insert Into ycurs Values (261,229)
    Insert Into ycurs Values (237,242)
    Insert Into ycurs Values (214,262)
    Insert Into ycurs Values (208,272)
    Insert Into ycurs Values (181,277)
    Insert Into ycurs Values (179,265)
    Insert Into ycurs Values (168,264)
    Insert Into ycurs Values (166,259)
    Insert Into ycurs Values (156,253)
    Insert Into ycurs Values (141,240)
    Insert Into ycurs Values (119,224)
    Insert Into ycurs Values (88,204)
    Insert Into ycurs Values (54,181)
    Insert Into ycurs Values (34,166)
    Insert Into ycurs Values (34,146)
    Insert Into ycurs Values (44,141)
    Insert Into ycurs Values (53,133)
    Insert Into ycurs Values (59,136)
    Insert Into ycurs Values (59,131)
    Insert Into ycurs Values (72,129)
    Insert Into ycurs Values (77,122)
    Insert Into ycurs Values (91,116)
    Insert Into ycurs Values (92,106)
    Insert Into ycurs Values (100,105)
    Insert Into ycurs Values (103,99)
    Insert Into ycurs Values (121,97)
    Insert Into ycurs Values (127,93)
    Insert Into ycurs Values (123,84)
    Insert Into ycurs Values (118,74)
    Insert Into ycurs Values (121,63)
    Insert Into ycurs Values (116,55)
    Locate
    Endproc

    Procedure Init
    Thisform.mousepointer0=0
    Endproc

    Procedure imgcanvas1.beforedraw
    With _Screen.System.drawing
        logfx=This.ogfx
        This.Clear(.Color.green)
        This.ogfx.SmoothingMode = .Drawing2D.SmoothingMode.AntiAlias

        ypath = .Drawing2D.GraphicsPath.New()
        x0=x
        y0=Y
        Sele ycurs
        Scan
            ypath.AddLine(x0,y0,x,Y)
            x0=x
            y0=Y
        Endscan
        Locate
        ypath.AddLine(x,Y,x0,y0)

        logfx.DrawPath(.Pens.Blue, ypath)
        Do Case
        Case Thisform.ye=.F.
            br = .Drawing2D.LinearGradientBrush.New(This.rectangle,.Color.red,.Color.white,2,.F.)
            logfx.FillPath(br,ypath)
        Case Thisform.ye=.T.
            br = .Drawing2D.LinearGradientBrush.New(This.rectangle,.Color.green,.Color.red,2,.F.)
            logfx.FillPath(br,ypath)
        Endcase

    Endwith
    Endproc

    Procedure imgcanvas1.MouseEnter
    Lparameters nButton, nShift, nXCoord, nYCoord
    TEXT to thisform.edit1.value noshow
        Algeria map
        -area=2580000 km2
        -population : 36 millions
        -religion: islam
        -capitale: Algiers
    ENDTEXT
    Thisform.edit1.Visible=.T.
    Thisform.ye=.T.
    Thisform.imgcanvas1.Draw
    Endproc

    Procedure imgcanvas1.MouseLeave
    Lparameters nButton, nShift, nXCoord, nYCoord
    Thisform.ye=.F.
    Thisform.imgcanvas1.Draw
    Thisform.edit1.Visible=.F.
    Endproc

Procedure destroy
clea events
endproc

Enddefine
*

*End code

 

 Working with Regions and APIs in visual foxpro

Published on Visual foxpro, regions, path, font, API, Maps

To be informed of the latest articles, subscribe:
Comment on this post