Benutzer:Rainer Lippert/Diagramm

Option Explicit

Private Const DAYS_INTERVAL = 10  'Tagesintervall
Private Const MIN_SIZE_LAST_INTERVAL = 2  'Minimale Größe des letzten Intervalls eines Monats
                                          'to prevent line at 31th before 1st, for instance
Private Const DATE_FORMAT = "dd.mm."  'Datumsformat
Private Const FONT_SIZE = 10  'Schriftgröße
Private Const AXIS_TEXT_OFFSET = -7  'Achsenbeschriftungsversatz

Private Const LINE_WEIGHT = 1.5  'Linienstärke
Private Const LINE_STYLE = msoLineDash  'Linienstil gestrichelt
'Private Const LINE_STYLE = msoLineSolid  'Linienstil normal

Public Sub EntferneLinienImAktivenDiagramm()
  
  Call ClearShapesInChart(ActiveChart)

End Sub

Public Sub ZeichneLinienImAktivenDiagramm()

  Call ClearShapesInChart(ActiveChart)
  Call DrawVerticalGridLinesInChart(ActiveChart)

End Sub

Private Sub DrawLinesInFirstEmbeddedDiagram()

  Call ClearShapesInChart(ActiveSheet.ChartObjects(1).Chart)
  Call DrawVerticalGridLinesInChart(ActiveSheet.ChartObjects(1).Chart)

End Sub


' DrawVerticalGridLinesInChart()
' ==============================

' 2009-12-28 by Geri Broser

' Draws vertical lines as grid lines in the given chart.
' The lines are drawn in the interval specified with DAYS_INTERVAL and on month's begin.

Private Sub DrawVerticalGridLinesInChart(Chart As Chart)
  
  On Error GoTo Error
  
  Dim series As series
  Set series = Chart.SeriesCollection(1)

  Dim xMin As Double, xMax As Double
  'Dim yMin As Double, yMax As Double
  Dim xLeft As Double, xWidth As Double
  Dim yTop As Double, yBottom As Double  ', yHeight As Double
      
  xLeft = Chart.PlotArea.InsideLeft
  xWidth = Chart.PlotArea.InsideWidth
  yTop = Chart.PlotArea.InsideTop
  'yHeight = Chart.PlotArea.InsideHeight
  yBottom = yTop + Chart.PlotArea.InsideHeight
  xMin = Chart.Axes(1).MinimumScale
  xMax = Chart.Axes(1).MaximumScale
  'yMin = Chart.Axes(2).MinimumScale
  'yMax = Chart.Axes(2).MaximumScale
  
  Dim monthEnds(12) As Long
  monthEnds(0) = 1
  monthEnds(1) = 31
  monthEnds(2) = IIf(Year(series.XValues(1)) Mod 4 = 0, 29, 28)  'ok for next 90 years
  monthEnds(3) = 31
  monthEnds(4) = 30
  monthEnds(5) = 31
  monthEnds(6) = 30
  monthEnds(7) = 31
  monthEnds(8) = 31
  monthEnds(9) = 30
  monthEnds(10) = 31
  monthEnds(11) = 30
  monthEnds(12) = 31
  
  Dim monthIdx As Long
  Dim nextMonthEnd As Long
  Dim dayCounter As Long
  
  monthIdx = 0
  nextMonthEnd = monthEnds(monthIdx)
  dayCounter = 0
  
  Dim seriesIdx As Long
  Dim xNode As Double, yNode As Double
  Dim line As shape
  Dim text As shape
  
  Application.ScreenUpdating = False
  
  For seriesIdx = 1 To series.Points.Count
    
    If seriesIdx = nextMonthEnd Or _
       (dayCounter = DAYS_INTERVAL And seriesIdx <= nextMonthEnd - MIN_SIZE_LAST_INTERVAL) Then
      xNode = xLeft + (series.XValues(seriesIdx) - xMin) * xWidth / (xMax - xMin)
      'yNode = yTop + (yMax - series.Values(seriesIdx)) * yHeight / (yMax - yMin)
      Set line = Chart.Shapes.AddLine(xNode, yTop, xNode, yBottom)
      Set text = Chart.Shapes.AddTextbox(msoTextOrientationUpward, _
                 xNode + AXIS_TEXT_OFFSET, yBottom, xNode, yBottom)
      text.TextFrame.AutoSize = True
      text.TextFrame.Characters.text = Format(series.XValues(seriesIdx), DATE_FORMAT)
      text.TextFrame.Characters.Font.Size = FONT_SIZE
    End If
    
    'line at month's begin
    If seriesIdx = nextMonthEnd Then
      line.line.Weight = LINE_WEIGHT
      monthIdx = monthIdx + 1
      nextMonthEnd = nextMonthEnd + monthEnds(monthIdx)
      dayCounter = 0
    End If
    
    'line at days interval
    If dayCounter = DAYS_INTERVAL And seriesIdx <= nextMonthEnd - MIN_SIZE_LAST_INTERVAL Then
      line.line.DashStyle = LINE_STYLE
      dayCounter = 0
    End If

    dayCounter = dayCounter + 1
  Next seriesIdx

  Application.ScreenUpdating = True
  
Exit Sub

Error:
  MsgBox "Error " & Err.Number & ": " & Err.Description, vbExclamation, "DrawLinesInChart"

End Sub

Private Sub ClearShapesInChart(Chart As Chart)
  
  Dim shape As shape
  
  For Each shape In Chart.Shapes
    shape.Delete
  Next shape

End Sub