kann man noch erweitern, aber man kann ja klein anfangen.
Vorschläge willkommen.
Code: Alles auswählen
;WheelButton, V.2.0, PB 5.41 x86 - Feb.2020 by HJBremer
DeclareModule WheelButton
Declare.i WheelButton(pbnr, x, y, width, height, text$, flag=0, format$="######.##")
Declare.i WheelButton_Free(pbnr)
Declare.i WheelButton_AddText (pbnr, text$)
Declare.s WheelButton_GetText (pbnr, item=-1)
Declare.i WheelButton_SetText (pbnr, info$, idx=1)
Declare.i WheelButton_SetItem (pbnr, item)
Declare.i WheelButton_SetSize (pbnr, size.d, font=-1)
Declare.i WheelButton_SetColor(pbnr, color, idx=0)
#Wheel_Info1 = 1: #Wheel_Liste = 2: #Wheel_Info2 = 3: #Wheel_Result = 4
EndDeclareModule
Module WheelButton
EnableExplicit
Global def_font = LoadFont(#PB_Any, "Verdana", 12, #PB_Font_Bold) ;Vorgabe Font für Text
;- Structure
Structure WheelButton
pbnr.i ;PbNr vom Canvasgadget
lvnr.i ;PbNr vom ListViewgadget
font.i : size.d ;
item.i ;intern: aktuelles Listenelement
flag.i ;#PB_Text_Border | #PB_String_Numeric | [#PB_Text_Right #PB_Text_Center]
format.s ;wenn Listentext Zahlen und flag #PB_String_Numeric, Vorgabe="######.##"
text.s[5] ;index 0-4, nur 1-4 wird genutzt, 1=InfoText 2=ListenText 3=Infotext 4=Text rechts
color.i[5] ;index 0-4, 0-4 wird genutzt, [0] ist Windowfarbe, 1-4 Textfarben
EndStructure
Procedure.i WheelButton_Draw(*wb.WheelButton)
Protected a = $FF000000 ;Alphawert von VectorSourceColor
Protected gw, gh, j, abstand = 2
Protected.d x, y, w, h, z = 0.001 ;damit w+h in DrawVectorParagraph > null, z addieren
With *wb
StartVectorDrawing(CanvasVectorOutput(\pbnr))
gw = GadgetWidth(\pbnr): gh = GadgetHeight(\pbnr)
AddPathBox(0, 0, gw, gh): VectorSourceColor(a|\color[0]): FillPath() ;Canvas Background
If \flag & #PB_Text_Border
AddPathBox(0, 0, gw, gh): VectorSourceColor(a|#Gray): StrokePath(2) ;Rahmen
EndIf
;- Text
VectorFont(FontID(\font), \size)
\text[2] = Trim(GetGadgetItemText(\lvnr, \item)) ;Text aus der Liste
h = VectorTextHeight(\text[2]) + z
w = VectorTextWidth(\text[1] + \text[2] + \text[3] + \text[4]) + (z*3)
x = 0 : y = gh/2 - h/2
If \flag & #PB_Text_Border : x = abstand : gw - abstand : EndIf
If \flag & #PB_Text_Right : x + (gw-w-abstand-abstand) : EndIf
If \flag & #PB_Text_Center : x + ((gw-w)/2) - 1 : EndIf
;AddPathBox(x, y, w, h): VectorSourceColor(a|#Blue): StrokePath(1)
For j = 1 To 4 ;1=Info links, 2=Text aus Liste, 3=mitte, 4=rechts
MovePathCursor(x, y) : VectorSourceColor(a | \color[j])
w = VectorTextWidth(\text[j]) + z
DrawVectorParagraph(\text[j], w, h) : x + w
;DrawVectorText(\text[j]) : x + w
Next
StopVectorDrawing()
EndWith
EndProcedure
Procedure.s WheelButton_Numeric(text$, format$)
Protected p, d, komma$ = "."
If FindString(format$, ","): komma$ = ",": text$ = ReplaceString(text$, "," , "."): EndIf ;Komma ?
p = FindString(format$, komma$) ;suche Komma
If p : d = Len(format$) - p : EndIf ;Anzahl Kommastellen
text$ = StrF(ValF(text$), d) ;Kommastellen auffüllen/abschneiden
text$ = RSet(text$, Len(format$)) ;Leerzeichen vorweg sonst sortiert die Liste falsch
If komma$ = ",": text$ = ReplaceString(text$, "." , ","): EndIf ;falls Komma, Punkt weg
ProcedureReturn text$
EndProcedure
Procedure.i WheelButton_Free(pbnr)
Protected *wb.WheelButton = GetGadgetData(pbnr)
FreeGadget(*wb\lvnr) : FreeGadget(*wb\pbnr) : FreeStructure(*wb)
EndProcedure
Procedure.i WheelButton_AddText(pbnr, text$)
Protected *wb.WheelButton = GetGadgetData(pbnr)
If *wb\flag & #PB_String_Numeric : text$ = WheelButton_Numeric(text$, *wb\format) : EndIf
SendMessage_(GadgetID(*wb\lvnr), #LB_ADDSTRING, 0, @text$)
EndProcedure
Procedure.s WheelButton_GetText(pbnr, item=-1)
Protected *wb.WheelButton = GetGadgetData(pbnr)
If item = -1
ProcedureReturn GetGadgetItemText(*wb\lvnr, *wb\item)
Else
ProcedureReturn GetGadgetItemText(*wb\lvnr, item)
EndIf
EndProcedure
Procedure.i WheelButton_SetText(pbnr, info$, idx=1)
Protected *wb.WheelButton = GetGadgetData(pbnr)
;1=links; 2=mitte links (Liste); 3=mitte rechts; 4=rechts
If idx < 5 And idx > 0 : *wb\text[idx] = info$ : EndIf
WheelButton_Draw(*wb)
EndProcedure
Procedure.i WheelButton_SetColor(pbnr, color, idx=0)
Protected *wb.WheelButton = GetGadgetData(pbnr)
;0=Window; 1=links; 2=mitte links (Liste); 3=mitte rechts; 4=rechts
If idx < 5 And idx > -1 : *wb\color[idx] = color : EndIf
WheelButton_Draw(*wb)
EndProcedure
Procedure.i WheelButton_SetItem(pbnr, item)
Protected *wb.WheelButton = GetGadgetData(pbnr)
*wb\item = item
WheelButton_Draw(*wb)
EndProcedure
Procedure.i WheelButton_SetSize(pbnr, size.d, font=-1)
Protected *wb.WheelButton = GetGadgetData(pbnr)
*wb\size = size
If font > -1: *wb\font = font: EndIf
WheelButton_Draw(*wb)
EndProcedure
Procedure.i WheelButton_Event()
Protected *wb.WheelButton = GetGadgetData(EventGadget())
Protected mx, flag=#True, min=0, max=CountGadgetItems(*wb\lvnr)-1
If EventType() = #PB_EventType_MouseWheel ;wenn mehrere EventTypes muß Abfrage sein
*wb\item + GetGadgetAttribute(*wb\pbnr, #PB_Canvas_WheelDelta) ;:Debug *wb\item
If *wb\item < min : *wb\item = min : flag = #False : EndIf
If *wb\item > max : *wb\item = max : flag = #False : EndIf
If flag = #True
PostEvent(#PB_Event_Gadget, EventWindow(), *wb\pbnr, #PB_EventType_Change)
WheelButton_Draw(*wb)
EndIf
EndIf
EndProcedure
Procedure.i WheelButton(pbnr, x, y, width, height, text$, flag=0, format$="######.##")
Protected id, *wb.WheelButton = AllocateStructure(WheelButton)
id = CanvasGadget(pbnr, x, y, width, height)
If pbnr = #PB_Any : pbnr = id : EndIf
SetGadgetData(pbnr, *wb)
With *wb
\pbnr = pbnr
\lvnr = ListViewGadget(#PB_Any, 0,0,0,0, #LBS_SORT) : HideGadget(\lvnr, 1)
\font = def_font
\size = 12
\flag = flag
\format = format$
\color[0] = $f0f0f0
\color[1] = #Gray : \color[3] = #Gray
\color[2] = #Blue : \color[4] = #Red
SetGadgetAttribute(\pbnr, #PB_Canvas_Cursor, #PB_Cursor_Hand)
BindGadgetEvent(\pbnr, @WheelButton_Event(), #PB_EventType_MouseWheel)
EndWith
WheelButton_AddText(pbnr, text$)
WheelButton_Draw(*wb)
ProcedureReturn id
EndProcedure
EndModule
UseModule WheelButton
CompilerIf #PB_Compiler_IsMainFile
Procedure.s BerechneInfo1(pbnr)
Protected a$ = WheelButton_GetText(pbnr)
Protected wert.f = ValF(a$) * 1.19 : a$ = StrF(wert, 2)
;a$ = ReplaceString(a$, "." , ",") ;mit Komma
WheelButton_SetText(pbnr, a$, #Wheel_Result)
ProcedureReturn a$
EndProcedure
Define event, test$, j, item
OpenWindow(10, 0, 0, 820, 420, "Canvas example", #PB_Window_SystemMenu | #PB_Window_ScreenCentered)
WheelButton(1, 11, 50, 320, 30, "50", #PB_Text_Border|#PB_Text_Center|#PB_String_Numeric)
WheelButton_AddText(1, "75")
WheelButton_AddText(1, "100")
WheelButton_AddText(1, "125")
WheelButton_AddText(1, "150")
WheelButton_AddText(1, "175")
WheelButton_AddText(1, "57.22")
WheelButton_AddText(1, "200")
WheelButton_AddText(1, "1200")
WheelButton_SetSize(1, 14)
WheelButton_SetItem(1, 3)
WheelButton_SetText(1, "Netto: ", #Wheel_Info1)
WheelButton_SetText(1, " + 19% MwSt: ", #Wheel_Info2)
WheelButton_SetColor(1, #Magenta, #Wheel_Result)
BerechneInfo1(1)
Repeat
Event = WaitWindowEvent()
If Event = #PB_Event_Gadget
Select EventGadget()
Case 1
If EventType() = #PB_EventType_Change ;EventType() Abfrage muß beim Canvas sein !!!!
a$ = BerechneInfo1(1)
EndIf
EndSelect
EndIf
Until Event = #PB_Event_CloseWindow
CompilerEndIf
