PureBoard

Code: Alles auswählen

Procedure Balkendiagramm2(info$, Array dinfo$(1), Array daten(1), parent)
  
;sollte ein Fix-Font sein !!!
fontnr = LoadFont(#PB_Any, "Courier New", 8)
  
winbr = 600
winhh = 400
winnr = OpenWindow(#PB_Any,0,0,winbr,winhh,info$,#PB_Window_SystemMenu|1,WindowID(parent))
  
  ;max des Datenfeldes finden
  size = ArraySize(daten())
  For j = 0 To size
      If daten(j) > maxwert: maxwert = daten(j): EndIf
  Next    

  ;Mod wert x
  Select maxwert
    Case 0 To 10: x = 1
    Case 11 To 100: x = 10
    Case 101 To 1000: x = 10
    Case 1001 To 10000: x = 100
    Case 10001 To 100000: x = 100
    Default: x = 1000
  EndSelect 
  
  ;max des Datenfeldes bis nächsten glatten Wert erhöhen 
  While maxwert % x  ;für senkrechte Y Skala 
   maxwert + 1
  Wend

  ; -----------------------------------------------------------------
  
  ;nur für Höhe + Breite eines Zeichens, sollte Fix-Font sein
  StartDrawing(WindowOutput(winnr))
    DrawingFont(FontID(fontnr))
    chrbr = TextWidth("X")
    chrhh = TextHeight("X")
  StopDrawing()
  
  balken = ArraySize(daten())
  rows = 10
  baseX = chrbr * 7           ;senkrechte Linie vom linken Fensterrand
  baseY = winhh - chrhh * 3   ;waagerechte Linie von unten
  
  ;Balkenabstand in Pixel, -1 kann auch wegfallen  
  pixelX = ((winbr - baseX) / balken) - 1  
  If pixelX < 1: pixelX = 1: EndIf    ;null verhindern
  
  scaleY = maxwert / rows             ;Abstand der Zahlen pro Reihe
  pixelY = baseY / rows               ;Abstand der Reihen in Pixel  
  If scaleY < 1: scaleY = 1: EndIf    ;null verhindern
  If pixelY < 1: pixelY = 10: EndIf
   
  nr = CreateImage(#PB_Any, winbr, winhh, 16)  ;16 Bit Farbtiefe
  dc = StartDrawing(ImageOutput(nr))
          
      Box(0, 0, winbr, winhh, #White)
      Line(baseX, 0, 0, baseY, #Blue)             ;senkrechteLinie
      Line(baseX, baseY, winbr - baseX, 0, #Blue) ;waagerechte Linie
      
      ; gestrichelte Linien + Text links der senkrechten Linie
      DrawingFont(FontID(fontnr))  
      pen = CreatePen_(#PS_DOT,0,#Gray)  ;für gestrichelte Linie	
      SelectObject_(dc,pen)
      
      r.rect
      y = baseY                          ;Basis unten für 0
      For j = 0 To rows
          If j
             MoveToEx_(dc, baseX, y, 0)
             LineTo_(dc, winbr, y)      ;gestrichelte Linie
          EndIf
          txt$ = Str(scaleY * j)        ;Text links z.B.0,5,10,15...50 
          r\top = y - chrhh / 3
          r\left = 0             
          r\right = baseX - 2
          r\bottom = r\top + chrhh             
          SetTextAlign_(dc, #TA_TOP)
          DrawText_(dc, txt$, -1, r, 2) ;2 = #DT_RIGHT
          y - pixelY                    ;Y-Pixelwert ist für nächste Zahl
      Next
      
      DeleteObject_(pen)
      
      ; -------------------------------------------
      
      baseX + 4  ;etwas Abstand zur senkrechten Linie für Text + Balken
      
      ;Text unten für Balken            
      altX = 0
      For j = 1 To balken 
          x = baseX + ((j-1) * pixelX)  ;pixelposi für nächsten Balken   
          txt$ = dinfo$(j)
          breite = TextWidth(txt$) 
          br = breite: If pixelX > breite: br = pixelX: EndIf
          If altX + br <= x           ;kein Platz, kein Text   
             r\top = baseY + 3        ;r.rect definiert den Raum für Text
             r\left = x - 2           ; -2 um baseX + 4 auszugleichen 
             r\right = r\left + br    ; + br ist Textbreite oder Balkenabstand
             r\bottom = r\top + TextHeight(txt$)             
             SetTextAlign_(dc, #TA_TOP)     ;ohne geht nix
             DrawText_(dc, txt$, -1, r, 1)  ;1 = #DT_CENTER
             ;DrawTextR(dc, r, txt$, 90, 0, 12)
             altX = x
             InflateRect_(r,1,1)            ;vergrößert r.rect für DrawEdge
             DrawEdge_(dc,r,1,#BF_RECT)	    ;nur für die Optik
          EndIf
      Next
      
      ;Balken 
      balkenbr = pixelX - 4
      If balkenbr < 1: balkenbr = 1: EndIf
       
      For j = 1 To balken 
          lh = (daten(j) * pixelY) / scaleY  ;höhe des Balken
          x = baseX + ((j-1) * pixelX)       ;pixelposi für nächsten Balken
          farbe = #Cyan                      ;
          If lh > 3 * pixelY: farbe = #Blue: EndIf
          If lh > 6 * pixelY: farbe = #Green: EndIf
          Box(x, baseY, balkenbr, -lh, farbe) ;-lh, damit Balken von unten
      Next                                    ;      nach oben gemalt wird
  
  StopDrawing()
       
ImageGadget(#PB_Any,0,0, 0,0,ImageID(nr))

FreeFont(fontnr)

ProcedureReturn winnr
EndProcedure

Procedure BalkenDiagramm(main)

;zwischen geschobene Prozedur, welche die Daten bereitstellt

DisableWindow(main, 1)

max = 31               ;31 Balken
Dim tt$(max)
Dim dtn(max)
For j = 1 To max
 tt$(j) = Str(j)
 dtn(j) = Random(441)  ;Wert zwischen 0 und 441
Next

ProcedureReturn Balkendiagramm2(Str(max) + " Werte", tt$(), dtn(), main)
EndProcedure

;------------------------------------

main = 0
OpenWindow(main,0,0,800,600,"",#PB_Window_SystemMenu|1)

subwin = Balkendiagramm(main)
       
Repeat: event = WaitWindowEvent() 
        If event = #PB_Event_CloseWindow         
           If EventWindow() = subwin
              event = 0
              DisableWindow(0, 0)
              CloseWindow(subwin)
           EndIf   
        EndIf   
        
Until event = #PB_Event_CloseWindow 

End

Code: Alles auswählen

Procedure DrawTextR(dc, *r.rect, txt$, angle, fontid, fontsize, quality=2) 

  ; Diese Procedure gibt gedrehten Text aus 
  
  GetObject_(fontid,SizeOf(LOGFONT),NewFont.LOGFONT) 

  NewFont\lfEscapement = angle * 10 
  NewFont\lfHeight = fontsize 
  NewFont\lfWeight = quality*100 
  hFont = CreateFontIndirect_(NewFont) 
  
  oldFont = SelectObject_(dc,hFont) 
  
  *r\bottom + 5  ; diesen Wert bei Wörtern erhöhen
     
  SetTextAlign_(dc, #TA_RIGHT) 
  DrawText_(dc, txt$, -1, *r, 1)  ;1 = #DT_CENTER 
  
  SelectObject_(dc,oldFont) 
  DeleteObject_(hFont) 

EndProcedure