Auto Flowchart With Excel

Link: Download
Note: You must hack its pwd!

The Code:


Rem Attribute VBA_ModuleType=VBAModule
Option VBASupport 1
Const COL_STEP = 1
Const COL_STEP_NAME = 2
Const COL_NEXT_STEP = 4
Const COL_SHAPE_TYPE = 5
Const COL_VA = 6
Const COL_PIC = 10

Const START_COL_LANE = 11
Const START_ROW = 16
Const START_SHAPE = 13

Const COPYRIGHT = "[DAY LA TAI LIEU CUA CONG TY XYZ - CAM SAO CHEP DUOI MOI HINH THUC]"
Private Sub test()
    ActiveWorkbook.unprotect PASSWORD:="[you must hack]"
End Sub

Function getColumn(pic As String) As Integer
    Dim row, col As Integer
    Dim dung As Boolean
   
    row = START_ROW - 1
    col = START_COL_LANE
    With Sheet1
        While dung = False
            getColumn = col
            If .Cells(row, col) = pic Then dung = True
            If .Cells(row, col) = "" Then dung = True
            col = col + 1
        Wend
    End With
End Function
Private Sub fillColor(color As String)
    With Selection.ShapeRange.Fill
        .Visible = msoTrue
        Select Case color
            Case "Red":
                .ForeColor.RGB = RGB(255, 0, 0)
            Case "Blue":
                .ForeColor.RGB = RGB(0, 0, 255)
            Case "Green":
                .ForeColor.RGB = RGB(0, 176, 80)
        End Select
        .Transparency = 0
        .Solid
    End With
End Sub
Public Sub addFlowChart()
    If Sheet1.Columns("D:J").EntireColumn.Hidden = False Then
        Sheet1.Columns("D:J").EntireColumn.Hidden = True
    End If
    clearAll
    addShape
    addConnector
    addValue
End Sub
Private Sub addShape()
    Dim row, tcol As Integer
    Dim shape_letter As String
    row = START_ROW
    With Sheet1
        While .Cells(row, COL_STEP) <> ""
            shape_letter = .Cells(row, COL_SHAPE_TYPE)
            'Copy Shape
            For Each cell In Range("L9:Q12")
                If (cell.Text = shape_letter) Then
                    .Cells(cell.row + 1, cell.Column).Copy
                    Exit For
                End If
            Next
            'xac dinh cot dich
            tcol = getColumn(.Cells(row, COL_PIC))
            'Chon Cell dich
            .Cells(row, tcol).Select
            'Paste Shape vao Cell dich
            ActiveSheet.Paste
            row = row + 1
        Wend
    End With
    Application.CutCopyMode = False
End Sub

Private Sub addConnector()
    Dim shape_count As Integer
    Dim next_shapes As Variant
    row = START_ROW
    With Sheet1
        shape_count = .Shapes.Count
        While .Cells(row, 1) <> ""
            next_shapes = VBA.Split(.Cells(row, COL_NEXT_STEP), ";")
            j = 0
            While j <= UBound(next_shapes)
                .Cells(row, getColumn(.Cells(row, COL_PIC))).Select
                'them connector dang Elbow
                .Shapes.addConnector(msoConnectorElbow, 493.6537795276, 93.0660629921, 542.8890551181, 129.1984251969).Select
                'chon connector moi them vao
                Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadOpen
                'Split ten cua shape o dong hien hanh
                shapetype = VBA.Split(.Shapes(.Cells(row, COL_STEP) + START_SHAPE).Name, " ")
                'Neu la hinh Oval hoac hinh tron
                If shapetype(0) = "Oval" Then
                    'Gan diem dau cua connector vao shape nguon
                    Selection.ShapeRange.ConnectorFormat.BeginConnect .Shapes(.Cells(row, COL_STEP) + START_SHAPE), 5
                'Neu la hinh khac
                Else
                    'Gan diem dau cua connector vao shape nguon
                    Selection.ShapeRange.ConnectorFormat.BeginConnect .Shapes(.Cells(row, COL_STEP) + START_SHAPE), 2 + j
                End If
                'Gan dau cuoi cua connector vao shape dich
                If VBA.Val(.Cells(row, COL_STEP)) < VBA.Val(VBA.Trim(next_shapes(j))) Then
                    Selection.ShapeRange.ConnectorFormat.EndConnect .Shapes(VBA.Val(VBA.Trim(START_SHAPE + next_shapes(j)))), 1
                Else
                    Selection.ShapeRange.ConnectorFormat.EndConnect .Shapes(VBA.Val(VBA.Trim(START_SHAPE + next_shapes(j)))), 4
                End If
                'chuyen den shape dich tiep theo
                .Cells(VBA.Val(VBA.Trim(START_SHAPE + next_shapes(j))), getColumn(.Cells(row, COL_PIC))).Select
                Application.Wait Now + 1 / (24 * 60 * 60# * 2)
                j = j + 1
            Wend
            row = row + 1
        Wend
    End With
End Sub

Public Sub addValue()
    Dim row As Integer
    row = START_ROW
    With Sheet1
        While .Cells(row, COL_STEP) <> ""
            If (.Cells(row, COL_VA) <> "") Then
                .Shapes(.Cells(row, COL_STEP) + START_SHAPE).Select
                Select Case .Cells(row, COL_VA)
                    Case "RVA":
                        fillColor ("Blue")
                    Case "BVA":
                        fillColor ("Green")
                    Case "NVA":
                        fillColor ("Red")
                End Select
            End If
            Application.Wait Now + 1 / (24 * 60 * 60# * 2)
            row = row + 1
        Wend
    End With
End Sub

Private Sub clearAll()
    Dim i As Integer
    With Sheet1
        i = .Shapes.Count
        While i > START_SHAPE
            .Shapes(i).Delete
            i = i - 1
        Wend
    End With
End Sub
Public Sub reset()
    Dim i As Integer
    Dim ans As String
    Dim shape_name
    ans = InputBox("Input:" + VBA.Chr(13) + " 1 : clear all," + VBA.Chr(13) + " 0 : clear color")
    With Sheet1
        i = .Shapes.Count
        While i > START_SHAPE
            Select Case ans
                Case "1":
                    .Shapes(i).Delete
                Case "0":
                    .Shapes(i).Select
                    shape_name = VBA.Split(Selection.Name, " ")
                    If shape_name(0) <> "Elbow" Then
                        With Selection.ShapeRange.Fill
                            .Visible = msoTrue
                            .ForeColor.RGB = RGB(255, 255, 255)
                            .Transparency = 0
                            .Solid
                        End With
                    End If
            End Select
            i = i - 1
        Wend
    End With
End Sub
Public Sub setCopyRight()
    Sheet1.Range("C13") = COPYRIGHT
End Sub