Auto Flowchart With Excel
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
