PureBasic Forums - English

Posted: **Mon Jun 27, 2005 5:31 pm**

Code updated for 5.20+

Delphi has a calendar that is string based called Tstring calendar. while ive been fooling around with ownerdrawn listboxes, i whipped up a beginning to a string calendar that anyone can feel free to use.

NOTE: when dealing with a listbox, item order goes from TOP TO BOTTOM, not left to right like a normal calendar does.

Does anyone know how to get the item order of a listbox left to right by the way?

Code: Select all

Global OriginProc,editcontrol.l ,editprocedure.l ,crtitem.l

Global Dim itemrect.RECT(50)

Procedure GetPanelDisplayWindowID(hwnd,item)
  tc_item.TC_ITEM
  tc_item\Mask=#TCIF_PARAM
  SendMessage_(hwnd,#TCM_GETITEM,item,tc_item)
  ProcedureReturn tc_item\lParam
EndProcedure
Procedure EditProc(hwnd,msg,wParam,lParam)
  Select msg
    Case #WM_RBUTTONDOWN
     
      ProcedureReturn 0
  EndSelect
  ProcedureReturn CallWindowProc_(editprocedure,hwnd,msg,wParam,lParam)
EndProcedure

Procedure ListboxProc( hwnd, msg,wParam,lParam)
  Select msg
    Case #WM_DRAWITEM
      hbrushSelectedFocus.l = CreateSolidBrush_(RGB(0, 0, 80))
      textbuffer$ = Space(255)
      listb=GetWindow_(hwnd,#GW_CHILD)
      *lpdis.DRAWITEMSTRUCT=lParam
      *lptris.DRAWITEMSTRUCT=*lpdis.DRAWITEMSTRUCT
      Select *lpdis\CtlType
        Case #ODT_LISTBOX
          If *lpdis\itemID= 0 Or *lpdis\itemID= 6 Or *lpdis\itemID= 12 Or *lpdis\itemID=18 Or *lpdis\itemID=24 Or *lpdis\itemID=30 Or *lpdis\itemID=36
            Else
          itemHeight=SendMessage_(*lpdis\hwndItem,#LB_GETITEMHEIGHT,0,0)
          Select *lpdis\itemState
            Case #ODS_SELECTED
              dtFlags = #DT_LEFT | #DT_VCENTER
              currentBrush = CreateSolidBrush_(RGB(0, 0, 80))
              currentTextColor = #White
              drawfoc=#False
              drawbox=#False
            Case #ODS_SELECTED | #ODS_FOCUS
              dtFlags = #DT_LEFT | #DT_VCENTER
              currentBrush = hbrushSelectedFocus
              currentTextColor = #White
              drawfoc=#True
            Case 0
              dtFlags = #DT_LEFT | #DT_VCENTER
              currentBrush = #White
              currentTextColor = RGB(0, 0, 0)
              drawfoc=#False
              drawbox=#True
          EndSelect
          SendMessage_(*lpdis\hwndItem,#LB_GETTEXT,*lpdis\itemID,textbuffer$)
          lbText$=textbuffer$
          FillRect_(*lpdis\hdc, *lpdis\rcItem, currentBrush)
          If drawfoc=#True
            DrawFocusRect_(*lpdis\hdc, *lpdis\rcItem)
          EndIf
          If drawbox=#True
            hpen=CreatePen_(#PS_INSIDEFRAME      ,0,#Black)
            Rectangle_(*lpdis\hdc,*lpdis\rcItem\left,*lpdis\rcItem\top,*lpdis\rcItem\right,*lpdis\rcItem\bottom)
          EndIf
          SetBkMode_(*lpdis\hdc, #TRANSPARENT)
          SetTextColor_(*lpdis\hdc, currentTextColor)
          *lpdis\rcItem\left+5
          DrawText_(*lpdis\hdc, lbText$, Len(lbText$), *lpdis\rcItem, dtFlags)
          ProcedureReturn 0
        EndIf
      EndSelect
  EndSelect
  ProcedureReturn CallWindowProc_(OriginProc,hwnd,msg,wParam,lParam)
EndProcedure   

ProcedureDLL LBGrid(x,y,width,height,itemHeight,type,parent,tabitem)
  class.s=Space(255)
  cs=GetClassName_(parent,@class, Len(class))
  If class = "SysTabControl32"
    finalparent=GetPanelDisplayWindowID(parent,tabitem)
  Else
    finalparent=parent
  EndIf
  window=OpenWindow(#PB_Any,x,y,width,height,"", #PB_Window_BorderLess|#PB_Window_Invisible)
  SetWindowLong_(WindowID(window),#GWL_STYLE, #WS_CHILD|#WS_DLGFRAME|#WS_EX_CLIENTEDGE|#WS_CLIPCHILDREN|#WS_CLIPSIBLINGS )
  SetParent_(WindowID(window),finalparent)
  ShowWindow_(WindowID(window),#SW_SHOW)
  lb=ListViewGadget(#PB_Any,0,0,width,height,#LBS_OWNERDRAWFIXED|#LBS_HASSTRINGS|#LBS_MULTICOLUMN|#LBS_NOTIFY)
  OriginProc= SetWindowLong_(WindowID(window), #GWL_WNDPROC, @ListboxProc())
  SendMessage_(GadgetID(lb), #LB_SETITEMHEIGHT, 0, itemHeight)
  SendMessage_(GadgetID(lb), #LB_SETCOLUMNWIDTH, 30,0)
  SetWindowLong_(GadgetID(lb),#GWL_STYLE,GetWindowLong_(GadgetID(lb),#GWL_STYLE)|#WS_BORDER   )
   ShowWindow_(GadgetID(lb),#SW_SHOW)
  For a=0 To 41
    AddGadgetItem(lb,-1,"")
  Next
  UseGadgetList(GadgetID(lb))
  For a=0 To 41 Step 6
    day$="Sun"
    If a=6 :day$="Mon": ElseIf a=12: day$="Tue":ElseIf a=18:day$="Wed":ElseIf a=24:day$="Thu":ElseIf a=30
  day$="Fri": ElseIf a=36: day$="Sat":EndIf
    SendMessage_(GadgetID(lb),#LB_GETITEMRECT,a,itemrect(a))
    ButtonGadget(#PB_Any,itemrect(a)\left,itemrect(a)\top,itemrect(a)\right-itemrect(a)\left,20,day$,#BS_FLAT)
    Next

  UseGadgetList(finalparent)
  ProcedureReturn lb
EndProcedure

#WindowWidth  = 390
#WindowHeight = 350
If OpenWindow(0, 100, 200, #WindowWidth, #WindowHeight, "", #PB_Window_MinimizeGadget)
  grid=LBGrid(30,20,215,125,20,0,WindowID(0),0)
  
  ;- create some images 
 
  ;- add some items 
  
  ;- event loop
  Repeat
   
    EventID = WaitWindowEvent()
   
    If EventID = #PB_Event_Gadget
     
      Select EventGadget()
       
       
       
      EndSelect
     
    EndIf
   
  Until EventID = #PB_Event_CloseWindow
 
EndIf
 
End

Posted: **Mon Jun 27, 2005 6:38 pm**

Did you ever try running your code with enabled debugger ?

I guess not, otherwise you would have seen an errormessage...

PureBasic Forums - English

Tstring Calendar clone

Tstring Calendar clone