hat eine Weile gedauert bis ich das Prinzip halbwegs verstanden habe.
Anstoss sind die unschönen Linien in der 2DDrawing Bibliothek
Verbesserungen am Code und der Anwendung der Vectorbefehle sind erwünscht.
Code: Alles auswählen
;HJBremer PB 5.41 LTS x86 / 5.62 x64 - 25.02.2019 V1.0
DeclareModule DiagrammModul
Declare.i DiagrammMax(Array daten(1), lastmax=0)
Declare.i Diagramm(canvasnr, titel$, size, max)
Declare.i DiagrammPaint(canvasnr, info$, Array daten(1) , color, txt=0, dotpath=0)
EndDeclareModule
Module DiagrammModul
EnableExplicit
Global abstand_w.f = 20 ;Abstand der Gitterlinien waagerecht
Global abstand_s.f ;Abstand der Gitterlinien senkrecht - wird in Diagramm() bestimmt
Global teiler.f ;Wert für Skala senkrecht und Daten - wird in Diagramm() bestimmt
Global info_y = 10 ; für Infotext links
Global null_x = 130 ; x senkrechte Linie
Global null_y ; wird in Diagramm() bestimmt
Global font = FontID(LoadFont(#PB_Any, "Consolas", 10))
Macro VectorColor(color, alpha=$FF)
VectorSourceColor(color + ($FFFFFF * alpha + alpha))
EndMacro
Macro DrawTextLeftX(x, y, text)
MovePathCursor(x-VectorTextWidth(text), y - VectorTextHeight("0")/2)
DrawVectorText(text)
EndMacro
Procedure.i Diagramm(canvasnr, titel$, size, max)
; size = anzahl Daten
; max = größter Datenwert
Protected i, x, y
Protected cbr = GadgetWidth(canvasnr)
Protected chh = GadgetHeight(canvasnr)
Protected dbr = cbr - 20 - null_x ; verfügbare Breite waagerecht, für Linien + Abstand
Protected dhh = chh ; verfügbare Höhe senkrecht, für Linien, hier einfach Gadgethöhe
Protected lines_s = size ; Anzahl Gitterlinien senkrecht
Protected lines_w = chh / abstand_w ; Anzahl Gitterlinien waagerecht
Protected skala = max / abstand_w ; für Text senkrecht und teiler
;Global
teiler = skala / abstand_w ; für Datenkurve in DiagrammPaint()
abstand_s = dbr / size ; Abstand senkrechte Linien und für die Kurve
null_y = 21 * abstand_w ; y Nullpunkt = Abstand * waagerechte Linien
;oder
null_y = ((max/skala)+1) * abstand_w ;berechnen falls Resize gewünscht
If StartVectorDrawing(CanvasVectorOutput(canvasnr))
VectorColor(#Yellow, 40)
AddPathBox(10, 10, cbr - 20, chh - 20)
FillVectorOutput()
ClipPath() ;Zeichnen innerhalb der Box, gilt nur für diesen StartVectorDrawing Bereich
;Titel
VectorColor(#Black)
VectorFont(font, 16)
MovePathCursor(10, info_y)
DrawVectorText(titel$): info_y + VectorTextHeight(titel$) * 3
TranslateCoordinates(null_x, 0) ;Startpunkt nach rechts rücken
;Gitterlinien waagerecht; alle grau bis auf null_y
For i = 1 To lines_w
y = i * abstand_w - abstand_w
VectorColor(#Gray, 40)
If y = null_y: VectorColor(#Red): EndIf
MovePathCursor(-5, y)
AddPathLine(dbr, y)
StrokePath(1) ;StrokePath() muß innerhalb ForNext sein, sonst nix Farbe ändern
Next
;Gitterlinien senkrecht; 1.Linie Blau, alle anderen grau
For i = 1 To lines_s
x = i * abstand_s - abstand_s
VectorColor(#Gray, 40)
If i = 1: VectorColor(#Blue): EndIf
MovePathCursor(x, 0)
AddPathLine(x, dhh)
StrokePath(1)
Next
ResetCoordinates() ;auf 0,0 - Gadget oben links zurückstellen
TranslateCoordinates(null_x, null_y) ;Start fürs Zeichnen ist jetzt Schnittpunkt XY vom Gitter
;Text waagerecht
VectorFont(font, 14)
VectorColor(#Blue)
For i = 1 To size
x = i * abstand_s - abstand_s
If i > 9: x-7: EndIf
MovePathCursor(x, 5)
RotateCoordinates(x, 0, -20)
DrawVectorText(Str(i))
RotateCoordinates(x, 0, 20)
Next i
;Text senkrecht oben
VectorColor(#Blue)
For i = 1 To 30
x = -8 : y = i * 20
DrawTextLeftX(x, -y, Str(i*skala))
Next i
;Text senkrecht unten
VectorColor(#Red)
For i = 1 To 20
x = -8 : y = i * 20
DrawTextLeftX(x, y, Str(i*skala))
Next i
StopVectorDrawing()
EndIf
EndProcedure
Procedure.i DiagrammMax(Array daten(1), lastmax=0)
;max ermitteln und auf volle 500er erhöhen
Protected i, max, size = ArraySize(daten())
max = daten(1)
For i = 2 To size
If daten(i) > max : max = daten(i) : EndIf
Next
max = (max / 500 + 1) * 500
If lastmax > max: max = lastmax: EndIf
ProcedureReturn max
EndProcedure
Procedure.i DiagrammPaint(canvasnr, info$, Array daten(1) , color, txt=0, dotpath=0)
Protected i, x, y, size = ArraySize(daten())
If StartVectorDrawing(CanvasVectorOutput(canvasnr))
VectorColor(color)
VectorFont(font, 12)
MovePathCursor(10, info_y)
DrawVectorText(info$) : info_y + VectorTextHeight(info$) * 3
TranslateCoordinates(null_x, null_y) ;Start bzw. Nullpunkt fürs Zeichnen ist jetzt Schnittpunkt XY
VectorColor(color, 240)
MovePathCursor(0, -daten(1) / teiler)
AddPathCircle (0, -daten(1) / teiler, 2)
For i = 2 To size
If daten(i)
x = i * abstand_s - abstand_s
y = daten(i) / teiler
AddPathLine(x, -y)
EndIf
Next
If dotpath
DotPath(2, 5, #PB_Path_RoundEnd)
Else
StrokePath(1.6, #PB_Path_DiagonalCorner)
EndIf
VectorColor(color)
For i = 1 To size
If daten(i)
x = i * abstand_s - abstand_s
y = daten(i) / teiler
AddPathCircle(x, -y, 2)
EndIf
Next
StrokePath(1)
If txt
VectorFont(font,11)
VectorColor(color)
For i = 1 To size
If daten(i)
x = i * abstand_s - abstand_s + 6
y = daten(i) / teiler + VectorTextHeight("X")/2
MovePathCursor(x, -y): DrawVectorText("[" + Str(daten(i)) + "]")
EndIf
Next
EndIf
StopVectorDrawing()
EndIf
EndProcedure
EndModule
UseModule DiagrammModul
;- Test
;{
Procedure.i MakeTestDaten(Array daten(1), max)
size = ArraySize(daten())
For j = 1 To size
daten(j) = Random(max, 10)
nr = Random(size) : daten(nr) = 0
Next
nr = Random(size) : daten(nr) = -max/6
EndProcedure
#canvas = 1
br = 900
hh = 600
If OpenWindow(0, 0, 0, br, hh, "VectorDrawing", #PB_Window_SystemMenu | #PB_Window_ScreenCentered)
CanvasGadget(#canvas, 0, 0, br, hh)
anz = 31
Dim daten1(anz)
MakeTestDaten(daten1(),1200)
Dim daten2(anz) ; Feld kann kleiner sein als andere
MakeTestDaten(daten2(),1400)
Dim daten3(anz)
MakeTestDaten(daten3(),500)
max = DiagrammMax(daten1())
max = DiagrammMax(daten2(), max)
max = DiagrammMax(daten3(), max) ;max ist jetzt der größte Wert der 3 Felder
Diagramm(#canvas, "02.2019", anz, max) ;anz sollte gleich dem größten Feld sein sonst fehlt was
DiagrammPaint(#canvas, "Konto 1", daten1() , #Blue, 1) ;mit Text
DiagrammPaint(#canvas, "Konto 2", daten2() , #Magenta) ;ohne Text
DiagrammPaint(#canvas, "PayPal", daten3() , #Gray, 0, 1) ;ohne Text, gepunktete Linie
Repeat
Event = WaitWindowEvent()
Until Event = #PB_Event_CloseWindow
EndIf
;}