SocioGraph

[Eoeo]

How I can create this SocioGraph ?




But exist another type




a test sample info :

[Antonio Linares]

Coding it

Use functions Line(), MoveTo(), Rectangle(), Circle(), etc...

[Eoeo]

Antonio,
tonight I made some tests


Sgram.ch

Code: Select all  Expand view

#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  Expand view

#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  Expand view

#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 ?