PureBoard

Code: Alles auswählen

;Infobox by HJBremer - Februar 2015 - 1.12, ab Purebasic 5.20(x86) Windows Vista

;Hinweis: es gibt Fonts welche sich nicht eignen für Text in einer Box
; weil Unter- und/oder Oberlängen zu groß sind.

XIncludeFile "Fontliste.pbi"

DeclareModule InfoBox   
   Declare.i InfoBox(pbnr, x, y, w, h, text$, flag = 0)
   Declare.i InfoBox_Font(pbnr, lmr, fontname$, fontstyle = 0)
   Declare.i InfoBox_Color(pbnr, left, info, right, back = #PB_Ignore)   
   Declare.i InfoBox_Text(pbnr, pos, text$, width = -1, flag = 0)
   
   Macro InfoBox_Left(pbnr, text, width = -1, flag = 0)
      InfoBox_Text(pbnr, 0, text, width, flag)
   EndMacro   
   Macro InfoBox_Right(pbnr, text, width = -1, flag = 0)
      InfoBox_Text(pbnr, 1, text, width, flag)
   EndMacro   
EndDeclareModule

Module Infobox     
   EnableExplicit  
   UseModule FontListe  
   
   Structure Infobox      ;interne Struktur
      pbnr.i
      oldproc.i
      borders.i
      bkbrush.i
      midpbnr.i  : midhwnd.i  : midcolor.i
      leftpbnr.i : lefthwnd.i : leftcolor.i
      rightpbnr.i: righthwnd.i: rightcolor.i
   EndStructure   
   
   #leftmargin = 2            ;linker Rand
   #infomargin = 3            ;Abstand zwischen den TextGadgets
   #rightmargin = 2           ;rechter Rand
   Global NewList infolist()  ;Liste verwaltet Gadgetdaten
   
   Procedure InfoBox_CB(hWnd, Msg, wParam, lParam) 
      Protected *ib.Infobox = GetWindowLongPtr_(hwnd, #GWL_USERDATA)
      Protected oldwndproc = *ib\oldproc
      
      Select msg
         Case #WM_DESTROY:    ;first Destroy Message (PB destroy all Childs)                        
         Case #WM_NCDESTROY:  ;last Destroy Message (PB destroy Parent)           
            DeleteObject_(*ib\bkbrush): FreeMemory(*ib)            
            
         Case #WM_CTLCOLORSTATIC            
            SetBkMode_(wParam, #TRANSPARENT)    ;wParam ist das DC
            Select lparam                       ;TextColor setzen
               Case *ib\lefthwnd:  SetTextColor_(wparam, *ib\leftcolor)
               Case *ib\midhwnd:  SetTextColor_(wparam, *ib\midcolor)
               Case *ib\righthwnd: SetTextColor_(wparam, *ib\rightcolor)                  
            EndSelect            
            ProcedureReturn *ib\bkbrush         ;BackBrush (Color) setzen           
            
         Case #WM_SETTEXT:    ; SetText umleiten aufs ChildTextgadget
            msg = 0: SetGadgetText(*ib\midpbnr, PeekS(lparam))
            
         Case #WM_COMMAND, #WM_PARENTNOTIFY: ;from RightTextGadget (Future)
      EndSelect            
      ProcedureReturn CallWindowProc_(oldwndproc, hwnd, msg, wParam, lParam)
   EndProcedure 
         
   Procedure.i InfoBox_Text(pbnr, pos, text$, width = -1, flag = 0)
      Protected *ib.Infobox
      Protected x, w, gadget, innerwidth, leftwidth, rightwidth
      
      ForEach infolist()
         *ib = infolist()
         If *ib\pbnr = pbnr
            If pos = 0: gadget = *ib\leftpbnr: Else: gadget = *ib\rightpbnr: EndIf            
            SetGadgetText(gadget, text$)            
            If width = -1: width = GadgetWidth(gadget, #PB_Gadget_RequiredSize): EndIf
            innerwidth = GadgetWidth(*ib\pbnr) - *ib\borders - #leftmargin - #rightmargin            
            
            If gadget = *ib\leftpbnr    
               ResizeGadget(gadget, #leftmargin, 0, width, #PB_Ignore)  ;TextGadget links
               If width: width + #infomargin: EndIf            ;Abstand danach addieren               
               rightwidth = GadgetWidth(*ib\rightpbnr)         ;
               If rightwidth: rightwidth + #infomargin: EndIf  ;Abstand davor addieren               
               x = #leftmargin + width                         ;Spalte mittleres Gadget
               w = innerwidth - rightwidth - width             ;dessen Breite
               ResizeGadget(*ib\midpbnr, x, 0, w, #PB_Ignore)               
            Else
               x = GadgetWidth(*ib\pbnr) - *ib\borders - #rightmargin - width        
               ResizeGadget(gadget, x, 0, width, #PB_Ignore)               
               If width: width + #infomargin: EndIf                
               leftwidth = GadgetWidth(*ib\leftpbnr)
               If leftwidth: leftwidth + #infomargin: EndIf               
               w = innerwidth - width - leftwidth           
               ResizeGadget(*ib\midpbnr, #PB_Ignore, 0, w, #PB_Ignore) 
            EndIf
            
            If Bool(flag & #PB_Text_Right)
               flag = GetWindowLongPtr_(GadgetID(gadget), #GWL_STYLE)
               SetWindowLongPtr_(GadgetID(gadget), #GWL_STYLE, flag|#SS_RIGHT)
            EndIf            
         EndIf
      Next
      ProcedureReturn width      
   EndProcedure
   
   Procedure.i InfoBox_Color(pbnr, left, info, right, back = #PB_Ignore)
      Protected *ib.Infobox      
      ForEach infolist()
         *ib = infolist()
         If *ib\pbnr = pbnr Or pbnr = #PB_All
            If left <> #PB_Ignore: *ib\leftcolor = left: EndIf
            If info <> #PB_Ignore: *ib\midcolor = info: EndIf
            If right <> #PB_Ignore: *ib\rightcolor = right: EndIf
            If back  <> #PB_Ignore
               DeleteObject_(*ib\bkbrush)
               *ib\bkbrush = CreateSolidBrush_(back)
               SetGadgetColor(*ib\pbnr, #PB_Gadget_BackColor, back)
            EndIf
            InvalidateRect_(GadgetID(*ib\pbnr), 0, 1): UpdateWindow_(GadgetID(*ib\pbnr))    
            ;oder RedrawWindow_(GadgetID(*ib\pbnr), 0, 0, #RDW_ERASE|#RDW_INTERNALPAINT|#RDW_INVALIDATE)
         EndIf
      Next      
   EndProcedure
   
   Procedure.i InfoBox_Font(pbnr, lmr, fontname$, fontstyle = 0)
      Protected *ib.Infobox     
      ForEach infolist()
         *ib = infolist()
         If *ib\pbnr = pbnr Or pbnr = #PB_All
            Select lmr
               Case 0: FontSearch(*ib\leftpbnr, fontname$, FontSize(*ib\leftpbnr), fontstyle) 
               Case 1: FontSearch(*ib\midpbnr, fontname$, FontSize(*ib\midpbnr), fontstyle) 
               Case 2: FontSearch(*ib\rightpbnr, fontname$, FontSize(*ib\rightpbnr), fontstyle) 
               Case #PB_All
                  FontSearch(*ib\leftpbnr, fontname$, FontSize(*ib\leftpbnr), fontstyle) 
                  FontSearch(*ib\midpbnr, fontname$, FontSize(*ib\midpbnr), fontstyle) 
                  FontSearch(*ib\rightpbnr, fontname$, FontSize(*ib\rightpbnr), fontstyle)                 
            EndSelect
         EndIf
      Next      
   EndProcedure
   
   Procedure.i InfoBox(pbnr, x, y, w, h, text$, flag = 0)
      Protected *ib.Infobox, nr, id, fonthh, fontid
      
      If IsGadget(pbnr): FreeGadget(pbnr): EndIf      
      *ib = AllocateMemory(SizeOf(Infobox))      
      
      flag & ~ #PB_Text_Border      ;Standard entfernen, falls existiert
      flag | #SS_SUNKEN             ;neuen Border setzen
      *ib\borders = 2               ;je 1 links + rechts      
      If pbnr = #PB_Any
         nr = TextGadget(#PB_Any, x, y, w, h, "", flag): id = GadgetID(nr)
      Else
         nr = pbnr: id = TextGadget(pbnr, x, y, w, h, "", flag)
      EndIf      
      fonthh = FontSize(nr) 
      fontid = FontSearch(nr, "Arial", fonthh)  ;Font zuweisen, falls abgefragt wird 
      
      With *ib  
         \pbnr = nr
         \midpbnr = TextGadget(#PB_Any, 0, 0, 0, h, "", #SS_CENTERIMAGE|#SS_ENDELLIPSIS)
         \leftpbnr = TextGadget(#PB_Any, 0, 0, 0, h, "", #SS_CENTERIMAGE|#SS_ENDELLIPSIS)
         \rightpbnr = TextGadget(#PB_Any, 0, 0, 0, h, "", #SS_CENTERIMAGE|#SS_ENDELLIPSIS|#SS_NOTIFY)
         
         SetGadgetFont(\midpbnr, fontid)         
         SetGadgetFont(\leftpbnr, fontid): SetGadgetFont(\rightpbnr, fontid)
         
         SetGadgetColor(nr, #PB_Gadget_BackColor, $FAFAFA)     ;#red zum Testen
         \bkbrush = CreateSolidBrush_($FAFAFA)                 ;Backcolor für Textgadgets
         \midcolor = #Blue: \leftcolor = #Gray: \rightcolor = #Gray       
         
         \midhwnd = GadgetID(\midpbnr): SetParent_(\midhwnd, id)
         \lefthwnd = GadgetID(\leftpbnr): SetParent_(\lefthwnd, id)
         \righthwnd = GadgetID(\rightpbnr): SetParent_(\righthwnd, id)         
         \oldproc = SetWindowLongPtr_(id, #GWL_WNDPROC, @InfoBox_CB())
         SetWindowLongPtr_(id, #GWL_USERDATA, *ib)
         
         ;mittleres TextGadget
         w = w - \borders - #leftmargin - #rightmargin
         ResizeGadget(\midpbnr, #leftmargin, 0, w, #PB_Ignore)         
         If Bool(flag & #PB_Text_Right)
            flag = GetWindowLongPtr_(\midhwnd, #GWL_STYLE)
            SetWindowLongPtr_(\midhwnd, #GWL_STYLE, flag|#SS_RIGHT)
         EndIf 
         SetGadgetText(\midpbnr, text$)         
      EndWith
      
      AddElement(infolist()): infolist() = *ib            
      If pbnr = #PB_Any
         ProcedureReturn  nr
      Else
         ProcedureReturn  id
      EndIf       
   EndProcedure
   
EndModule

UseModule Infobox

OpenWindow(0, 0, 0, 320, 250, "Infobox", #PB_Window_SystemMenu | #PB_Window_ScreenCentered)


InfoBox(1, 11, 11, 200, 22, "3,99", #PB_Text_Right)
InfoBox_Left(1, "Bananen")
InfoBox_Right(1, #euro)

InfoBox(2, 11, 60, 250, 22, "100", #PB_Text_Right)
InfoBox_Left(2, "Klopapier:", 90, #PB_Text_Right)
InfoBox_Right(2, "Rollen", 66)

InfoBox(3, 11, 90, 250, 22, "22", #PB_Text_Right)
InfoBox_Left(3, "Latten:", 90, #PB_Text_Right)
InfoBox_Right(3, "3x6 cm", 66)

InfoBox(4, 11, 120, 150, 22, "45")
InfoBox_Left(4, "Schuhgröße:")

InfoBox(5, 11, 150, 100, 18, "45")
InfoBox_Left(5, "Schuhgröße:")

InfoBox(6, 11, 180, 100, 22, "1003", #PB_Text_Right)
InfoBox_Right(6, "Kg")

InfoBox_Font(1, 0, "Arial", #PB_Font_Bold|#PB_Font_Italic)
InfoBox_Left(1, "Bananen")

InfoBox_Font(2, 2, "New Times", #PB_Font_Bold)
InfoBox_Font(3, #PB_All, "Courier New")

ButtonGadget(9, 10, 210, 88, 22, "new colors")


Repeat
   Event = WaitWindowEvent()
   
   Select Event
         
      Case #PB_Event_Gadget
         Select EventGadget()
            Case 9 : 
               InfoBox_Color(#PB_All, #Blue, #Red, #Black, #White)
               SetGadgetText(1, "102,55")
               InfoBox_Left(1, "Äpfel")
               
         EndSelect
         
   EndSelect
Until Event = #PB_Event_CloseWindow