But exist another type
a test sample info :
SocioGraph
SocioGraph
How I can create this SocioGraph ?
But exist another type
a test sample info :
But exist another type
a test sample info :
-
Antonio Linares
- Site Admin
- Posts: 37481
- Joined: Thu Oct 06, 2005 5:47 pm
- Location: Spain
- Contact:
Re: SocioGraph
Coding it 
Use functions Line(), MoveTo(), Rectangle(), Circle(), etc...
Use functions Line(), MoveTo(), Rectangle(), Circle(), etc...
Re: SocioGraph
Antonio,
tonight I made some tests
Sgram.ch
TsGram class
test.prg
this is a base class .... perhaps someone can help me to modifiy it ?
tonight I made some tests
Sgram.ch
Code: Select all
#xcommand @ <nRow>, <nCol> SOCIOGRAM [<oGram>] ;
[ <dlg: OF, WINDOW, DIALOG> <oWnd> ] ;
[ SIZE <nWidth>, <nHeight> ] ;
[ <border: BORDER>] ;
[ <vScroll: VSCROLL, VERTICAL SCROLL> ] ;
[ <hScroll: HSCROLL, HORIZONTAL SCROLL> ] ;
[ <color: COLOR, COLORS> <nClrFore> [,<nClrBack>] ] ;
=> ;
[<oGram> := ] TSocioGram():New( <nRow>, <nCol>, <nWidth>, <nHeight>, <oWnd>,;
<.border.>, [<.vScroll.>], [<.hScroll.>], <nClrFore>,;
<nClrBack> )TsGram class
Code: Select all
#include "FiveWin.ch"
// PROJECT SOCIOGRAM
// Eoeo and web SotfWare
// APRILE 13.06.2012
/*
#xcommand @ <nRow>, <nCol> SOCIOGRAM [<oGram>] ;
[ <dlg: OF, WINDOW, DIALOG> <oWnd> ] ;
[ SIZE <nWidth>, <nHeight> ] ;
[ <border: BORDER>] ;
[ <vScroll: VSCROLL, VERTICAL SCROLL> ] ;
[ <hScroll: HSCROLL, HORIZONTAL SCROLL> ] ;
[ <color: COLOR, COLORS> <nClrFore> [,<nClrBack>] ] ;
=> ;
[<oGram> := ] TSocioGram():New( <nRow>, <nCol>, <nWidth>, <nHeight>, <oWnd>,;
<.border.>, [<.vScroll.>], [<.hScroll.>], <nClrFore>,;
<nClrBack> )
*/
CLASS TSocioGram FROM TControl
CLASSDATA lRegistered AS LOGICAL
METHOD New( nTop, nLeft, nBottom, nRight, oWnd,lBorder,lVScroll, lHScroll, nClrFore, nClrBack) CONSTRUCTOR
METHOD Paint()
METHOD Display() INLINE ::BeginPaint(), ::Paint(), ::EndPaint(), 0
METHOD EraseBkGnd( hDC )
METHOD End()
// 1 Box
// 7 Triangule
// 8 Circle
METHOD AddItem(ntype,ntop,nLeft,nHeight,nRight)
ENDCLASS
METHOD New( nTop, nLeft, nBottom, nRight, oWnd,lBorder,lVScroll, lHScroll, nClrFore, nClrBack ) CLASS TSocioGram
DEFAULT nTop := 0, nLeft := 0, nBottom := 400, nRight := 400,;
lBorder := .T.,;
lVScroll := .f., lHScroll := .f.,;
oWnd := GetWndDefault()
::nTop = nTop
::nLeft = nLeft
::nBottom = nBottom
::nRight = nRight
::oWnd = oWnd
::nStyle = nOr( WS_CHILD,;
If( lBorder, WS_BORDER, 0 ),;
If( lVScroll, WS_VSCROLL, 0 ),;
If( lHScroll, WS_HSCROLL, 0 ),;
WS_VISIBLE, WS_TABSTOP)
::Register() // nOR(CS_VREDRAW,CS_HREDRAW) )
if oWnd:lVisible
::Create()
::Default()
::lVisible = .t.
oWnd:AddControl( Self )
else
oWnd:DefControl( Self )
::lVisible = .f.
endif
* SetWndDefault( Self )
return Self
METHOD Paint() CLASS TSocioGram
local nTop, nLeft, nHeight, nWidth, nBevel
local aInfo := ::DispBegin()
FillRect( ::hDC, GetClientRect( ::hWnd ), ::oBrush:hBrush )
if ValType( ::bPainted ) == "B"
Eval( ::bPainted, ::hDC, ::cPS, Self )
endif
::DispEnd( aInfo )
return 0
METHOD End() CLASS TSocioGram
Super:End()
RETURN NIL
METHOD EraseBkGnd( hDC ) CLASS TSocioGram
if ::oWnd != nil .and. IsAppThemed() .and. ;
Upper( ::oWnd:ClassName() ) $ "TFOLDER,TFOLDEREX,TREBAR,TGROUP,TPANEL,TSOCIOGRAM"
DrawPBack( ::hWnd, hDC )
return 1
endif
return 1
METHOD AddItem(ntype,ntop,nLeft,nBottom,nRight) CLASS TSocioGram
Local oBject
oBject:=TDraw():New( self, nTop, nLeft, nBottom, nRight )
oBject:nLineType:= ntype
* oBject:Paint()
RETURN NIL
// elements for sociogram
CLASS TDraw FROM TSocioGram
CLASSDATA lRegistered AS LOGICAL
DATA nLineType AS NUMERIC
DATA nLineWidth AS NUMERIC
DATA nRound AS NUMERIC
DATA lShadow AS LOGIC
DATA bAction
DATA ColorFill
DATA ColorBorder
METHOD New( oWnd, nTop, nLeft, nBottom, nRight ) CONSTRUCTOR
METHOD Paint()
METHOD Display() INLINE ::BeginPaint(), ::Paint(), ::EndPaint(), 1
METHOD Circle( nTop, nLeft, nBottom, nRight)
METHOD Triangulo(nTop,nLeft,nVal1, nVal2, nVal3)
METHOD Line( nTop, nLeft, nBottom, nRight, oPen )
METHOD Say( nRow, nCol, cText, nClrFore, nClrBack, oFont, lPixel,lTransparent, nAlign )
METHOD Click( nRow, nCol, nFlags )
ENDCLASS
METHOD New( oWnd, nTop, nLeft, nBottom, nRight,bAction ) CLASS TDraw
DEFAULT nTop := 20, nLeft := 20, nBottom := 10, nRight := 100,;
oWnd := GetWndDefault()
::nTop := nTop
::nLeft := nLeft
::nBottom := nBottom
::nRight := nRight
::oWnd := oWnd
::nStyle := nOr( WS_CHILD, WS_VISIBLE )
::lDrag := .t.
::nLineType := 1
::nLineWidth := 2
::nRound := 0
::nClrPane := CLR_WHITE
::nClrText := CLR_BLACK
::lShadow := .t.
::bAction = bAction
::ColorFill := CLR_RED
::ColorBorder := ::nClrText
::SetBrush( TBrush():New( "NULL" ) )
#ifdef __XPP__
DEFAULT ::lRegistered := .f.
#endif
::Register()
if ! Empty( ::oWnd:hWnd )
::Create( "BUTTON" ) // ::Create()
::oWnd:AddControl( Self )
else
::oWnd:DefControl( Self )
endif
if ::lDrag
::CheckDots()
endif
return Self
METHOD Paint() CLASS TDraw
local nTop, nLeft, nHeight, nWidth, nBevel
LOCAL n, hPen, hOldPen, hOldBrush
LOCAL nAmpla, nOld
LOCAL oPen, oBrush, oDummy
::CoorsUpdate()
nAmpla := ::nLineWidth / 2
DO CASE
CASE ::nLinetype == 1
::nRound := 0
MoveTo( ::hDC, nAmpla, nAmpla )
LineTo(::hDC, nAmpla, ::nHeight - nAmpla , hPen )
LineTo(::hDC, ::nWidth - nAmpla, ::nHeight - nAmpla , hPen )
LineTo(::hDC, ::nWidth - nAmpla , nAmpla, hPen )
LineTo(::hDC, nAmpla, nAmpla, 0, hPen )
CASE ::nLinetype == 2
::nRound := 0
MoveTo( ::hDC, nAmpla, nAmpla )
LineTo(::hDC, ::nWidth - nAmpla, nAmpla )
CASE ::nLinetype == 3
::nRound := 0
MoveTo( ::hDC, nAmpla, nAmpla )
LineTo(::hDC, nAmpla, ::nHeight - nAmpla )
CASE ::nLinetype == 4
::nRound := 0
MoveTo( ::hDC, nAmpla, ::nHeight - nAmpla )
LineTo(::hDC, ::nWidth - nAmpla, ::nHeight - nAmpla )
CASE ::nLinetype == 5
::nRound := 0
MoveTo( ::hDC, ::nWidth - nAmpla, ::nHeight - nAmpla )
LineTo(::hDC, ::nWidth - nAmpla, nAmpla )
CASE ::nLinetype == 6
IF ::nRound == 0
::nRound := 25
ENDIF
::CoorsUpdate()
oDummy := ::GetCliRect()
Roundrect( ::hDC, nAmpla, nAmpla, ::nWidth - nAmpla, ::nHeight - nAmpla, ::nRound, ::nRound )
CASE ::nLinetype == 7
::Triangulo(ntop, nLeft,::nWidth - nAmpla, ::nHeight - nAmpla, ::nHeight - nAmpla,::ColorFill,::ColorBorder)
CASE ::nLinetype == 8
::CIRCLE( ::nTop, ::nLeft, ::nHeight - nAmpla, ::nWidth - nAmpla,::ColorFill,::ColorBorder)
ENDCASE
SelectObject( ::hDc, hOldPen )
DeleteObject( hPen )
RETURN NIL
METHOD Triangulo(nTop,nLeft,nVal1, nVal2, nVal3) CLASS TDraw
hBrush := CreateSolidBrush( ::ColorFill )
SelectObject( ::hDC, hBrush )
MoveTo( ::hDC, nVal1, nTop )
LineTo( ::hDC, nVal2, nVal3 )
LineTo( ::hDC, nLeft, nVal3 )
LineTo( ::hDC, nVal1, nTop)
DeleteObject( hBrush )
return nil
METHOD CIRCLE( nTop, nLeft, nBottom, nRight) CLASS TDraw
LOCAL hPen, hBrush
Local nStartRow, nStartCol, nEndRow, nEndCol
* hPen := CreatePen( 0, 2, ::colorborder )
* hBrush := CreateSolidBrush( CLR_RED )
* SelectObject( ::hDC, hPen )
* SelectObject( ::hDC, hBrush )
* Ellipse(::hDC,nTop, nLeft, nBottom, nRight)
Pie( ::hDC,nTop, nLeft, nBottom, nRight,;
nStartRow, nStartCol, nEndRow, nEndCol )
* DeleteObject( hPen )
* DeleteObject( hBrush )
RETURN ( NIL )
METHOD Line( nTop, nLeft, nBottom, nRight, oPen ) CLASS TDraw
local hPen := if( oPen = nil, 0, oPen:hPen )
::GetDC()
MoveTo( ::hDC, nLeft, nTop )
LineTo( ::hDC, nRight, nBottom, hPen )
::ReleaseDC()
return nil
METHOD Say( nRow, nCol, cText, nClrFore, nClrBack, oFont, lPixel,;
lTransparent, nAlign ) CLASS TDraw
DEFAULT nClrFore := ::nClrText,;
nClrBack := ::nClrPane,;
oFont := ::oFont,;
lPixel := .f.,;
lTransparent := .f.
if ValType( nClrFore ) == "C" // xBase Color string
nClrBack = nClrFore
nClrFore = nGetForeRGB( nClrFore )
nClrBack = nGetBackRGB( nClrBack )
endif
::GetDC()
DEFAULT nAlign := GetTextAlign( ::hDC )
WSay( ::hWnd, ::hDC, nRow, nCol, cValToChar( cText ), nClrFore, nClrBack,;
If( oFont != nil, oFont:hFont, 0 ), lPixel, lTransparent, nAlign )
::ReleaseDC()
return nil
METHOD Click( nRow, nCol, nFlags ) CLASS TDraw
return 0
test.prg
Code: Select all
#include "FiveWin.ch"
#include "SGram.ch"
Function Test()
Local oWndGram
Local oSgram
Local obarGram
local cTitle := "SocioGram Test 1.00"
Local wClrBack
wClrBack:=GetSysColor(15)
DEFINE CURSOR oHand HAND
DEFINE CURSOR oCross NAME 'Cross'
DEFINE WINDOW oWndGram ;
TITLE cTitle
DEFINE BUTTONBAR obarGram 3D OF oWndGram SIZE 26, 26 2007
@ 30,10 SOCIOGRAM oSgram;
SIZE 800,800 ;
BORDER ;
COLORS CLR_BLACK, wclrBack
// box
oSgram:AddItem(1,14,14,120,120)
//Triangule
oSgram:AddItem(7,20,40,120,120)
//Circle
oSgram:AddItem(8,100,00,90,90)
//LINE
oSgram:AddItem(2,20,20,90,90)
oWndGram:bInit := {|| (TScrWnd():New( oSgram,1,335,1,30) ) } // NOT RUN
ACTIVATE WINDOW oWndGram
RETURN NIL
Function Testgraphs(oWnd,oSgram)
RETURN NIL
this is a base class .... perhaps someone can help me to modifiy it ?