jonastiger
Member
Hi
I am building a gantt template in VBA and I have issues in arrow connectors for dependencies.
The result I want is what you see in images below:
I have this code, which works fine if the tasks are not aligned in the time line. when they are, the result is the third example in each picture. Wht are the changes I must do in the code to get the result in the correct examples?
Thank uou all in advance
I am building a gantt template in VBA and I have issues in arrow connectors for dependencies.
The result I want is what you see in images below:
I have this code, which works fine if the tasks are not aligned in the time line. when they are, the result is the third example in each picture. Wht are the changes I must do in the code to get the result in the correct examples?
Code:
Dim RgID As Range
Dim RgPredec As Range
Dim RgRelType As Range
Dim RgItem As Range
Dim LgItem As Long
Const DEPENDENCY_PREFIX As String = "connector"
Const PREFIX As String = "Task"
' Clear existing connectors
For LgItem = ActiveSheet.Shapes.Count To 1 Step -1
If Left(ActiveSheet.Shapes(LgItem).Name, Len(DEPENDENCY_PREFIX)) = DEPENDENCY_PREFIX Then
ActiveSheet.Shapes(LgItem).Delete
End If
Next
' Set ranges
With ActiveSheet
Set RgID = .Range("A11:A600") 'IDTASK
Set RgPredec = .Range("L11:L600")'DEPENDENCY/PREDECESSOR
Set RgRelType = .Range("N11:N600") ' RELATIONSHIP (FS, SS, SF, FF)
End With
' Create connectors based on relationship types
For Each RgItem In RgPredec.Cells
LgItem = RgItem.Row - 10 ' Adjust row offset as needed
If RgItem.Value <> "" Then
Select Case RgRelType.Cells(LgItem).Value
Case "FS"
BuildDependencyArrow ActiveSheet.Shapes(PREFIX & RgItem.Value), _
ActiveSheet.Shapes(PREFIX & RgID.Cells(LgItem).Value), _
DEPENDENCY_PREFIX & CStr(LgItem), "FS"
Case "SS"
BuildDependencyArrow ActiveSheet.Shapes(PREFIX & RgItem.Value), _
ActiveSheet.Shapes(PREFIX & RgID.Cells(LgItem).Value), _
DEPENDENCY_PREFIX & CStr(LgItem), "SS"
Case "SF"
BuildDependencyArrow ActiveSheet.Shapes(PREFIX & RgItem.Value), _
ActiveSheet.Shapes(PREFIX & RgID.Cells(LgItem).Value), _
DEPENDENCY_PREFIX & CStr(LgItem), "SF"
Case "FF"
BuildDependencyArrow ActiveSheet.Shapes(PREFIX & RgItem.Value), _
ActiveSheet.Shapes(PREFIX & RgID.Cells(LgItem).Value), _
DEPENDENCY_PREFIX & CStr(LgItem), "FF"
End Select
End If
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "PROJECT PLAN UPDATED"
End Sub
Sub BuildDependencyArrow(FromShape As Shape, ToShape As Shape, Name As String, RelType As String)
Dim x1 As Single, y1 As Single, x2 As Single, y2 As Single
Select Case RelType
Case "FS"
x1 = FromShape.Left + FromShape.Width
y1 = FromShape.Top + FromShape.Height / 2
x2 = ToShape.Left
y2 = ToShape.Top + ToShape.Height / 2
Case "SS"
x1 = FromShape.Left
y1 = FromShape.Top + FromShape.Height / 2
x2 = ToShape.Left
y2 = ToShape.Top + ToShape.Height / 2
Case "SF"
x1 = FromShape.Left
y1 = FromShape.Top + FromShape.Height / 2
x2 = ToShape.Left + ToShape.Width
y2 = ToShape.Top + ToShape.Height / 2
Case "FF"
x1 = FromShape.Left + FromShape.Width
y1 = FromShape.Top + FromShape.Height / 2
x2 = ToShape.Left + ToShape.Width
y2 = ToShape.Top + ToShape.Height / 2
End Select
With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, x1, y1)
.AddNodes msoSegmentLine, msoEditingAuto, (x1 + x2) / 2, y1
.AddNodes msoSegmentLine, msoEditingAuto, (x1 + x2) / 2, y2
.AddNodes msoSegmentLine, msoEditingAuto, x2, y2
.ConvertToShape
End With
With ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
.Line.EndArrowheadStyle = msoArrowheadTriangle
.Name = Name
End With
End SubThank uou all in advance
Last edited by a moderator:
