Liberty BASIC Community Forum
« Coupled graphic boxes »

Welcome Guest. Please Login or Register.
Nov 23rd, 2017, 03:17am


Rules|Home|Help|Search|Recent Posts|Notification


« Previous Topic | Next Topic »
Pages: 1  Notify Send Topic Print
 thread  Author  Topic: Coupled graphic boxes  (Read 755 times)
hans
Junior Member
ImageImage


member is offline

Avatar




PM

Gender: Male
Posts: 56
xx Coupled graphic boxes
« Thread started on: Nov 13th, 2014, 02:40am »

A program is shown here where the graphic boxes are coupled by their scrollbars. When you scroll one box, you also scroll the other.
What I needed was a sort of spreadsheet with row and column indicators which do not disappear when scrolling in a large spreadsheet.

  • I've made 3 graphic boxes, the coupling is done using GetScrollBar and SetScrollBar.
  • The drawing of content is done in memory.
  • To fill the spreadsheet with (dummy) content, use the menu: open
  • The code is commented
  • Before it's a real spreadsheet the code needs, of course, to be extended

Enjoy it, Hans

Code:
    call SET.COLORS : global White
    global numcol, numrow, numColInd
[gui]
    WindowWidth=1830:WindowHeight=890 : UpperLeftX=1 : UpperLeftY=1
    RowIndWidth=200 : ColIndHeight=70 : TableHeight=WindowHeight-ColIndHeight-80 : TableWidth=WindowWidth-RowIndWidth-40
    menu #st, "File",_
              "Open",[open],_
              "Exit",[quit]
    graphicbox #st.table, RowIndWidth+10, ColIndHeight+10, TableWidth, TableHeight
    graphicbox #st.ColInd, RowIndWidth+10,5,TableWidth,ColIndHeight 'Column indicator box
    graphicbox #st.RowInd,5,ColIndHeight+10,RowIndWidth,TableHeight 'Row indicator box
    open "Table with row indicator and columm indicator" for window as #st
    #st "trapclose [quit]"
    GLOBAL hBmpTable,hBmpColInd,hBmpRowInd,memdcTable,memdcColInd,memdcRowInd,handleTable$,handleColInd$,handleRowInd$,bmpTable$,bmpColInd$,bmpRowInd$,oldTable,oldColInd,oldRowInd
    handleTable$="#st.table" : handleColInd$="#st.ColInd" : handleRowInd$="#st.RowInd"
    call Init.MemoryGraphicbox handleTable$,  hTable,hdcTable,memdcTable
    call Init.MemoryGraphicbox handleColInd$, hColInd,hdcColInd,memdcColInd
    call Init.MemoryGraphicbox handleRowInd$,hRowInd,hdcRowInd,memdcRowInd
    global fontheight,fontwidth : fontheight=16 : fontwidth=6
    global numcolchar : numcolchar=4 'how many characters per column
    r=GDI.SETFONT(memdcTable,fontheight,fontwidth,"Arial",_FW_NORMAL,0,0)
    r=GDI.SETFONT(memdcRowInd,fontheight,fontwidth,"Arial",_FW_NORMAL,0,0)
    r=GDI.SETFONT(memdcColInd,fontheight,fontwidth,"Arial",_FW_NORMAL,0,0)
goto [scanloop]
[open]
    numColInd=2 : numcol=100 : numrow=100 : gosub [prepare.tables]: call Fill.Tables  'Testing
goto [scanloop]
[scanloop] 'extended WAIT, needed to couple the GB's
    calldll #kernel32,"Sleep",10 as ulong,r as void '10 ms delay to save processor cycles
    SCAN
    x=GetScrollPos(hTable, _SBS_HORZ) : y=GetScrollPos(hTable, _SBS_VERT)
    if y<>yTable or x<>xTable then
        xTable=x : yTable=y : xColInd=xTable : yRowInd=yTable
        r=SetScrollPos(hColInd,_SBS_HORZ, xColInd)
        r=SetScrollPos(hRowInd,_SBS_VERT, yRowInd)
    end if
    x=GetScrollPos(hColInd, _SBS_HORZ)
    if x<>xColInd then
        xColInd=x : xTable=xColInd
        r=SetScrollPos(hTable,_SBS_HORZ, xTable)
    end if
    y=GetScrollPos(hRowInd, _SBS_VERT)
    if y<>yRowInd then
        yRowInd=y : yTable=yRowInd
        r=SetScrollPos(hTable,_SBS_VERT, yTable)
    end if
goto [scanloop]
[prepare.tables]
'to clean the GB and to make sure text fits exactly in GB
    bmpTable$="bmpTable" : bmpColInd$="bmpColInd" : bmpRowInd$="bmpRowInd"
    maxheight=(numrow+2)*fontheight : maxwidth=(numcol+2)*fontwidth*numcolchar
    ExtraScrollWidth=maxwidth-TableWidth+22 : ExtraScrollHeight=maxheight-TableHeight+22 : ExtraScrollHeight=max(0,ExtraScrollHeight) : ExtraScrollWidth=max(0,ExtraScrollWidth)'22=width.height scrollbar
    call Prepare.MemoryGraphicbox handleTable$,  memdcTable,      bmpTable$,hBmpTable,oldTable,TableWidth,TableHeight,ExtraScrollWidth,ExtraScrollHeight
    call Prepare.MemoryGraphicbox handleColInd$, memdcColInd,   bmpColInd$,hBmpColInd,oldColInd,TableWidth,ColIndHeight,ExtraScrollWidth,0
    call Prepare.MemoryGraphicbox handleRowInd$,memdcRowInd,bmpRowInd$,hBmpRowInd,oldRowInd,RowIndWidth,TableHeight,0,ExtraScrollHeight
RETURN
[quit]
    call Kill.MemoryGraphicbox hTable,hdcTable,memdcTable,bmpTable$
    call Kill.MemoryGraphicbox hColInd,hdcColInd,memdcColInd,bmpColInd$
    call Kill.MemoryGraphicbox hRowInd,hdcRowInd,memdcRowInd,bmpRowInd$
    close #st
END
SUB Fill.Tables
'=Create interpretated syntaxonomical table in memory, then place it in graphicbox
'column indicator
    for i=1 to numColInd
        for j=1 to numcol
            call GDIDRAW.TEXTOUT memdcColInd,(j-1)*numcolchar*fontwidth+5,(i-1)*fontheight+5,using("####",j)
        next j
    next i
    CallDLL #gdi32,"SelectObject",memdcColInd As ulong,oldColInd As ulong,hBmpColInd As ulong
    #st.ColInd "drawbmp ";bmpColInd$;" 0 0; flush"
'row indicator
    for i=1 to numrow
        call GDIDRAW.TEXTOUT memdcRowInd,3,(i-1)*fontheight+5,"Row "+using("####",i)
    next i
    CallDLL #gdi32,"SelectObject",memdcRowInd As ulong,oldRowInd As ulong,hBmpRowInd As ulong
    #st.RowInd "drawbmp ";bmpRowInd$;" 0 0; flush"
'data table
    for i=1 to numrow
        for j=1 to numcol
            call GDIDRAW.TEXTOUT memdcTable,(j-1)*numcolchar*fontwidth+5,(i-1)*fontheight+5,using("####",j)
        next j
    next i
    CallDLL #gdi32,"SelectObject",memdcTable As ulong,oldTable As ulong,hBmpTable As ulong
    #st.table "drawbmp ";bmpTable$;" 0 0; flush"
END SUB
FUNCTION GetScrollPos(hWin, nBar)
    CallDLL #user32, "GetScrollPos", hWin As ulong, nBar As long, GetScrollPos As long
END FUNCTION
FUNCTION SetScrollPos(hWin, nBar, Pos)
'nBar=_SBS_HORZ or _SBS_VERT
    if nBar=_SBS_HORZ then scrollFlag=_WM_HSCROLL else scrollFlag=_WM_VSCROLL
    CallDLL #user32, "SetScrollPos", hWin As ulong, nBar As long, Pos As long,1 as Boolean, result as Long
    hPos = Pos * HexDec("&H10000")+_SB_THUMBPOSITION 'The position must be converted to hexadecimal + H10000
    CallDLL #user32, "PostMessageA", hWin as Ulong,_
        scrollFlag as Long, _ '_WM_HSCROLL or _WM_VSCROLL
        hPos as Long, 0 as Long, _ 'No significance
        result as Boolean
END FUNCTION
SUB Init.MemoryGraphicbox handle$,byref h,byref hDC,byref memDC
'=Initiation for drawing in memory
    h=hwnd(#handle$)  'graphicbox handle
    calldll #user32, "GetDC",h as ulong,hDC as ulong
    CallDLL #gdi32,"CreateCompatibleDC",hDC As ulong,memDC As ulong
END SUB
SUB Prepare.MemoryGraphicbox handle$,memDC,bmp$,byref hBmp,byref oldObject,winWide,winHigh,extraWide,extraHigh
'=Sets up the right size of gdi. On screen. And in memory. Clean drawing area in memory
    #handle$, "horizscrollbar   on 0 ";extraWide
    #handle$, "vertscrollbar    on 0 ";extraHigh
    #handle$ "getbmp "+bmp$+" 0 0 ";winWide+extraWide;" ";winHigh+extraHigh
    hBmp=hbmp(bmp$)'handle of LB bitmap
    oldObject=SelectObject(memDC,hBmp)
    call GDISET.USERPEN memDC,hPen,_PS_SOLID,1,White
    call GDIDRAW.RECTANGLE memDC,0,0,winWide+extraWide,winHigh+extraHigh 'sort of equivalent of CLS in memory
END SUB
SUB Kill.MemoryGraphicbox h,hdc,memdc,bmp$
'=Free memory from all stuff used for drawing in memory
    if bmp$<>"" then unloadbmp bmp$
    calldll #user32, "ReleaseDC",h as ulong,hdc as ulong,ret as long
    if ret=0 then notice "error in releasing DC"
    CallDLL #gdi32, "DeleteDC",memdc As ulong,r As boolean
    if ret=0 then notice "error in deleting DC"
END SUB
FUNCTION SelectObject(hDC, hMem)
    CallDLL #gdi32, "SelectObject", _
        hDC as Ulong,hMem as Ulong,SelectObject as Ulong
END FUNCTION
FUNCTION GDI.SETFONT(hdc,fontheight,fontwidth,fontname$,weight,italic,underline)
'=set font for drawing text in gdi
'A lot of posible properties ignored in this function: 0 in CreateFontA
    Calldll #gdi32, "CreateFontA",fontheight as long, fontwidth as long,1 as long, 0 as long, weight as long, italic as long,underline as long,_
    0 as long, 1 as long, 0 as long,0 as long, 0 as long,0 as long,fontname$ as PTR, newfont as ulong 'returns handle to font
    Calldll #gdi32, "SelectObject",hdc as ulong, newfont as ulong, oldfont as ulong 'handle to the previous font
    SelectFont=newfont
END FUNCTION
SUB GDIDRAW.TEXTOUT hDC,x,y,t$
'=draw text in gdi
    ln=Len(t$)
    CallDLL #gdi32, "TextOutA",hDC As ulong,x As long,y As long,t$ As ptr,ln As long, r As long
    if r=0 then notice "GDIDRAW.TEXTOUT fails"
END SUB
SUB GDIDRAW.RECTANGLE hDC,x1,y1,x2,y2
'=draw rectangele in gdi
    CallDLL #gdi32, "Rectangle",hDC As Long, x1 As Long, y1 As Long,x2 As Long, y2 As Long, r As Boolean
    if r=0 then notice "GDIDRAW.RECTANGLE fails"
END SUB
SUB GDISET.USERPEN hDC,byref hPen,PenStyle,PenWidth,rgbColor
'=set pen for drawing lines in gdi
    call GDICREATE.PEN hPen,PenStyle,PenWidth,rgbColor
    oldPen=SelectObject(hDC, hPen)
    CallDLL #gdi32, "DeleteObject", oldPen As ULong, result As Long 'remove old pen from memory
END SUB
SUB GDICREATE.PEN byref hPen,PenStyle,PenWidth,rgbColor
    CallDll #gdi32, "CreatePen",_
        PenStyle as long,PenWidth as long,rgbColor as long,hPen as ulong 'returns handle of pen, or 0 on error
        if hPen=0 then notice "Error creating pen"
END SUB
SUB GDISET.TEXTCOLOR hDC,red,green,blue
'=Set text color in gdi
    crColor=red+(green*256)+(blue*256*256)
    CallDLL #gdi32, "SetTextColor",hDC As long,crColor As long,result As long
END SUB
SUB SET.COLORS
'=Hexadecimal values of default colors
    White   = hexdec("FFFFFF")
    'the rest removed
END SUB

 
User IP Logged

Pages: 1  Notify Send Topic Print
« Previous Topic | Next Topic »

Rules|Home|Help|Search|Recent Posts|Notification

Donate $6.99 for 50,000 Ad-Free Pageviews!

| |

This forum powered for FREE by Conforums ©
Sign up for your own Free Message Board today!
Terms of Service | Privacy Policy | Conforums Support | Parental Controls