VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "GanttChartClass"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
 ' This program is free software; you can redistribute it and/or modify
 ' it under the terms of the GNU General Public License as published by
 ' the Free Software Foundation; either version 2 of the License, or
 ' (at your option) any later version.
 '
 ' This program is distributed in the hope that it will be useful,
 ' but WITHOUT ANY WARRANTY; without even the implied warranty of
 ' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ' GNU General Public License for more details.
 '
 ' You should have received a copy of the GNU General Public License
 ' along with this program; if not, write to the Free Software
 ' Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

Option Explicit

Public Destination As Range
Public ProjectStart As Date
Public ProjectEnd As Date
Public TaskStart As Date
Public TaskEnd As Date
Public TaskColor As String
Public TaskCompl As Double
Public ComplLabel As Boolean
Public Today As Date
Public TodayColor As String
Public Deadline1 As Date
Public Deadline1Color As String
Public Deadline2 As Date
Public Deadline2Color As String
Public Deadline3 As Date
Public Deadline3Color As String
Public HitDate As Date
Public HitSymbol As Integer
Public HitColor As String
Public TaskHlink As String
Public TaskTooltip As String
Public ComplColor As Long
Public LabelSize As Single

Public Function getKey() As String
    getKey = "Sprk" & Destination.Worksheet.Name & "'!" & Destination(1, 1).Address(, , xlR1C1)
End Function

Sub DrawGanttChart()

Dim rng As Range
Dim ProjectDays As Single
Dim TaskDays As Single
Dim DaysToStartTask As Single
Dim CompletionSpan, PlotTaskCompl, TodayDays, HitDays, Deadline1Days, Deadline2Days, Deadline3Days As Single
Dim PlotLeft, PlotTop, PlotWidth, PlotHeight, PlotTaskStart, PlotTaskDuration, TodayLine As Single
Dim shp As Shape
Dim Arr() As Variant
Dim j As Integer
Dim Message
Dim rngTop, rngLeft, rngWidth, rngHeight

Const Margin = 1.5

If Destination.MergeCells Then
    Set rng = Destination.MergeArea
Else
    Set rng = Destination
End If
rngTop = rng.Top
rngLeft = rng.Left
rngWidth = rng.Width
rngHeight = rng.Height
'--------------------------------------------------------------------------------
Utility.ShapeDelete rng
'--------------------------------------------------------------------------------
If TaskStart = TaskEnd Then HitDate = TaskStart

TodayDays = DateDiff("d", ProjectStart, Today) '+ 1
HitDays = DateDiff("d", ProjectStart, HitDate)
Deadline1Days = DateDiff("d", ProjectStart, Deadline1) ' + 1
Deadline2Days = DateDiff("d", ProjectStart, Deadline2) '+ 1
Deadline3Days = DateDiff("d", ProjectStart, Deadline3) ' + 1
ProjectDays = DateDiff("d", ProjectStart, ProjectEnd) ' + 1
TaskDays = DateDiff("d", TaskStart, TaskEnd) ' + 1
DaysToStartTask = DateDiff("d", ProjectStart, TaskStart) ' + 1
CompletionSpan = TaskDays * TaskCompl


PlotLeft = rngLeft - Margin
PlotTop = rngTop + rngHeight / 2
PlotWidth = rngWidth ' - 2 * Margin
PlotHeight = rngHeight / 2 - Margin



'- Plotting Task ---------------------------
PlotTaskStart = PlotLeft + PlotWidth * (DaysToStartTask / ProjectDays)
PlotTaskDuration = PlotWidth * (TaskDays / ProjectDays)

If TaskStart >= ProjectStart And TaskStart <= ProjectEnd And TaskEnd >= ProjectStart And TaskEnd <= ProjectEnd And ProjectDays >= 0 And TaskDays >= 0 Then

Set shp = rng.Worksheet.Shapes.AddShape(msoShapeRectangle, PlotTaskStart, PlotTop, PlotTaskDuration, PlotHeight)

With shp
        .Line.visible = msoFalse 'msoTrue
        .ZOrder msoBringToFront
        
        If TaskColor = "" Or Not IsNumeric(TaskColor) Then
            TaskColor = RGB(200, 200, 200)
            Else
            TaskColor = CLng(TaskColor)
        End If
        
        .Fill.ForeColor.RGB = TaskColor
        
        If TaskStart = TaskEnd Then
            .Fill.Transparency = 1
            HitDate = TaskEnd
        End If
End With

        On Error Resume Next
        j = 1: j = UBound(Arr) + 1
        On Error GoTo 0
        ReDim Preserve Arr(j)
        Arr(j) = shp.Name
        
        
'Add tooltip and Hyperlink ------------
    If TaskTooltip <> "" And TaskHlink <> "" Then
            ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Shapes(shp.Name), Address:=TaskHlink, ScreenTip:=CStr(TaskTooltip)
        ElseIf TaskTooltip <> "" Then
            ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Shapes(shp.Name), Address:="", ScreenTip:=CStr(TaskTooltip)
        ElseIf TaskHlink <> "" Then
            ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Shapes(shp.Name), Address:=TaskHlink, ScreenTip:=""
            Else
            'nada, move forward
    End If
'--------------------------------
If TaskStart = TaskEnd Then
Else

Set shp = Destination.Worksheet.Shapes.AddLine(PlotTaskStart + PlotTaskDuration, PlotTop, PlotTaskStart + PlotTaskDuration, rngTop + rngHeight)
    
    With shp
            .ZOrder msoBringToFront
            .Line.DashStyle = msoLineSolid
            .Line.Weight = 0.25
            .Line.ForeColor.RGB = TaskColor

    End With

        On Error Resume Next
        j = 1: j = UBound(Arr) + 1
        On Error GoTo 0
        ReDim Preserve Arr(j)
        Arr(j) = shp.Name
        
Set shp = Destination.Worksheet.Shapes.AddLine(PlotTaskStart, rngTop, PlotTaskStart, rngTop + PlotHeight)
    
    With shp
            .ZOrder msoBringToFront
            .Line.DashStyle = msoLineSolid
            .Line.Weight = 0.25
            .Line.ForeColor.RGB = TaskColor
    End With

        On Error Resume Next
        j = 1: j = UBound(Arr) + 1
        On Error GoTo 0
        ReDim Preserve Arr(j)
        Arr(j) = shp.Name
End If
'- Plotting Completion bar ---------------------------
PlotTaskCompl = PlotWidth * (CompletionSpan / ProjectDays)

Set shp = rng.Worksheet.Shapes.AddShape(msoShapeRectangle, PlotTaskStart, PlotTop + 0.375 * PlotHeight, PlotTaskCompl, 0.25 * PlotHeight)

With shp
        .Line.visible = msoFalse 'msoTrue
        .ZOrder msoBringToFront
        .Fill.ForeColor.RGB = ComplColor
End With

        On Error Resume Next
        j = 1: j = UBound(Arr) + 1
        On Error GoTo 0
        ReDim Preserve Arr(j)
        Arr(j) = shp.Name
        
'- Plotting Label ---------------------------

If ComplLabel = True Then

Set shp = rng.Worksheet.Shapes.AddShape(msoShapeRectangle, PlotTaskStart + PlotTaskDuration, rngTop, 1, rngHeight)
    With shp
            .Line.visible = msoFalse 'msoTrue
            .ZOrder msoBringToFront
            .Fill.Transparency = 1
            .ZOrder msoBringToFront
            .TextFrame.Characters.Text = "    " & WorksheetFunction.Round(TaskCompl, 2) * 100 & " %"
            .TextFrame.Characters.Font.Size = LabelSize
            .TextFrame.Characters.Font.Color = RGB(0, 0, 0)
            .TextFrame.AutoSize = True
            .TextFrame.Orientation = msoTextOrientationHorizontal
            .TextFrame.VerticalAlignment = xlVAlignCenter
            .TextFrame.Characters.Font.Name = "Calibri"
            .TextFrame.HorizontalAlignment = xlHAlignLeft
            .TextFrame.MarginBottom = 0
            .TextFrame.MarginTop = 0
            .TextFrame.MarginRight = 0
            .TextFrame.MarginLeft = 0
        
        On Error Resume Next
        j = 1: j = UBound(Arr) + 1
        On Error GoTo 0
        ReDim Preserve Arr(j)
        Arr(j) = shp.Name
    End With
    
    Else 'do nothing

End If
'- Plotting Today Line ---------------------------

If TodayDays > ProjectDays Or TodayDays < 0 Then
'Do nothing
Else
    TodayLine = PlotLeft + PlotWidth * (TodayDays / ProjectDays)
    
    Set shp = Destination.Worksheet.Shapes.AddLine(TodayLine, rngTop, TodayLine, rngTop + rngHeight)
    
    With shp
            .ZOrder msoBringToFront
            .Line.DashStyle = msoLineSolid
            .Line.Weight = 0.25
            If TodayColor = "" Or Not IsNumeric(TodayColor) Then
                TodayColor = RGB(150, 150, 150)
                Else
                TodayColor = CLng(TodayColor)
            End If
            .Line.ForeColor.RGB = TodayColor
    End With
    
        On Error Resume Next
        j = 1: j = UBound(Arr) + 1
        On Error GoTo 0
        ReDim Preserve Arr(j)
        Arr(j) = shp.Name
End If
'- Plotting Deadline1 line ---------------------------

If Deadline1Days > ProjectDays Or Deadline1Days < 0 Then
Else
    TodayLine = PlotLeft + PlotWidth * (Deadline1Days / ProjectDays)
    
    Set shp = Destination.Worksheet.Shapes.AddLine(TodayLine, rngTop, TodayLine, rngTop + rngHeight)
    With shp
            .ZOrder msoBringToFront
            .Line.Weight = 0.5
            .Line.DashStyle = msoLineDash
            On Error Resume Next
            If Not IsNumeric(Deadline1Color) Or CLng(Deadline1Color) < 0 Or CLng(Deadline1Color) > 16777215 Then
                .Line.ForeColor.RGB = 2898927 'Red
                Else
                .Line.ForeColor.RGB = Deadline1Color
            End If
    End With

Deadline1Color = ""

        On Error Resume Next
        j = 1: j = UBound(Arr) + 1
        On Error GoTo 0
        ReDim Preserve Arr(j)
        Arr(j) = shp.Name
End If

'- Plotting Deadline2 line ---------------------------

If Deadline2Days > ProjectDays Or Deadline2Days < 0 Then
Else
    TodayLine = PlotLeft + PlotWidth * (Deadline2Days / ProjectDays)
    
    Set shp = Destination.Worksheet.Shapes.AddLine(TodayLine, rngTop, TodayLine, rngTop + rngHeight)
    With shp
            .ZOrder msoBringToFront
            .Line.Weight = 0.5
            .Line.DashStyle = msoLineDash
            On Error Resume Next
            If CLng(Deadline2Color) < 0 Or CLng(Deadline2Color) > 16777215 Then
                .Line.ForeColor.RGB = 12487723 'Blue
                Else
                .Line.ForeColor.RGB = Deadline2Color
            End If
    End With

Deadline2Color = ""

        On Error Resume Next
        j = 1: j = UBound(Arr) + 1
        On Error GoTo 0
        ReDim Preserve Arr(j)
        Arr(j) = shp.Name
 End If
 
'- Plotting Deadline3 line ---------------------------

If Deadline3Days > ProjectDays Or Deadline3Days < 0 Then
Else
    TodayLine = PlotLeft + PlotWidth * (Deadline3Days / ProjectDays)
    
    Set shp = Destination.Worksheet.Shapes.AddLine(TodayLine, rngTop, TodayLine, rngTop + rngHeight)
    With shp
            .ZOrder msoBringToFront
            .Line.Weight = 0.5
            .Line.DashStyle = msoLineDash
            On Error Resume Next
            If Not IsNumeric(Deadline3Color) Or CLng(Deadline3Color) < 0 Or CLng(Deadline3Color) > 16777215 Then
                .Line.ForeColor.RGB = 2200141 'Green
                Else
                .Line.ForeColor.RGB = Deadline3Color
            End If
    End With
    
    Deadline3Color = ""
    
        On Error Resume Next
        j = 1: j = UBound(Arr) + 1
        On Error GoTo 0
        ReDim Preserve Arr(j)
        Arr(j) = shp.Name
        
End If


        
'- Plotting Hit symbol ---------------------------

If HitDate > ProjectEnd Or HitDate < ProjectStart Then
Else
    TodayLine = PlotLeft + PlotWidth * (HitDays / ProjectDays)
    
    Set shp = Destination.Worksheet.Shapes.AddLine(TodayLine - 0.25, rngTop + rngHeight / 2 - 0.25, TodayLine - 0.25, rngTop + rngHeight / 2)
    With shp
            .ZOrder msoBringToFront
            .Line.Weight = 0.5
            .Line.DashStyle = msoLineRoundDot
            On Error Resume Next
            
            If Not IsNumeric(CLng(HitColor)) Or CLng(HitColor) < 0 Or CLng(HitColor) > 16777215 Then
                HitColor = 203 'red
                Else
                HitColor = CLng(HitColor)
            End If
            
                Select Case HitSymbol
                    Case 1
                        .Line.EndArrowheadStyle = msoArrowheadOval
                    Case 2
                        .Line.EndArrowheadStyle = msoArrowheadTriangle
                    Case 3
                        .Line.EndArrowheadStyle = msoArrowheadStealth
                    Case Else
                        .Line.EndArrowheadStyle = msoArrowheadDiamond
                End Select
                    
            .Line.ForeColor.RGB = HitColor

    End With
    
        On Error Resume Next
        j = 1: j = UBound(Arr) + 1
        On Error GoTo 0
        ReDim Preserve Arr(j)
        Arr(j) = shp.Name
End If


'group all shapes ---------------
                    
    With rng.Worksheet.Shapes.Range(Arr)
        .Group
        .Name = "Sprk" & rng.Address(, , xlR1C1) & "Shape"
    End With
     
 'Rename with Sparklines syntax
    rng.Worksheet.Names.Add Name:="Sprk" & rng.Address(, , xlR1C1), RefersToR1C1:="='" & rng.Worksheet.Name & "'!" & rng.Address(, , xlR1C1)

    Set rng = Nothing
    Set shp = Nothing
    
    Else
    Message = MsgBox("For GanttChart() in " & rng.Address & " Please check yout dates... something is not correct", vbOKOnly)
End If

End Sub



