Option Explicit
Sub MarkingAllWord()
Dim rngListStartCell As Range, Cll As Range
If Not IsSetTableWordOK Then Exit Sub
Application.ScreenUpdating = False
Call DeleteAllShapeMarking
Set rngListStartCell = Sheet3.Range("K2:K" & Sheet3.Cells(Sheet3.Rows.Count, "K").End(xlUp).Row)
Sheet1.Unprotect Password:=myPass
Sheet1.Select
For Each Cll In rngListStartCell
If Cll.Value <> "" And Cll.Value <> "CANNOT PLACE" Then
Call DrawMarking(Cll.Value, Cll.Offset(, 3).Value, Cll.Offset(, 2).Value, Cll.Offset(, 1).Value, vbBlue, True)
End If
Next Cll
Call CountMarking
Sheet1.Protect Password:=myPass
Application.ScreenUpdating = True
Set rngListStartCell = Nothing
MsgBoxVN "Hoa2n ta61t d9a1nh da61u Ta61t ca3 ca1c tu73 trong ba3ng chu74... ", vbOKOnly + vbInformation, "---:: Tho6ng Ba1o ::---", "VNI"
End Sub
Sub ManualDrawMarking()
Dim iTotalCharOfWord As Integer
Dim strDirectionIn As String, strStartCell As String, strEndCell As String
Dim arrSelectCell
If Not IsSetTableWordOK Then GoTo ExitSub
If Not IsSelectedCellOK(arrSelectCell) Then GoTo ExitSub
iTotalCharOfWord = UBound(arrSelectCell) - LBound(arrSelectCell) + 1
strStartCell = arrSelectCell(LBound(arrSelectCell))
strEndCell = arrSelectCell(UBound(arrSelectCell))
strDirectionIn = GetDirectionOfSelectedCell(strStartCell, strEndCell)
If Not IsMarkingAlready(strStartCell, strEndCell) Then
If IsSelectedWordCorrect(arrSelectCell) Then
Call DrawMarking(strStartCell, strEndCell, iTotalCharOfWord, strDirectionIn, vbBlue, True)
Else
Call DrawMarking(strStartCell, strEndCell, iTotalCharOfWord, strDirectionIn, vbRed, True)
End If
Call CountMarking
Else
MsgBoxVN "D9a4 d9a1nh da61u cho5n na2y ro62i ....", vbOKOnly + vbInformation, "---:: Tho6ng Ba1o ::---", "VNI"
GoTo ExitSub
End If
ExitSub:
Application.OnKey "{RETURN}"
End Sub
Sub UndoDrawShape()
Dim shp As Object
Dim strNameUndo As String
Dim iLR As Integer
iLR = Sheet3.Cells(Sheet3.Rows.Count, "AA").End(xlUp).Row
If iLR >= 2 Then
strNameUndo = Sheet3.Range("AA" & iLR).Value
If strNameUndo <> "" Then
For Each shp In ActiveSheet.Shapes
If shp.Name = strNameUndo Then
Sheet1.Unprotect Password:=myPass
shp.Delete
Sheet1.Protect Password:=myPass
Call CountMarking
Sheet3.Range("AA" & iLR & ":AC" & iLR).ClearContents
Exit Sub
End If
Next shp
End If
End If
MsgBoxVN "Kho6ng co2n d9a1nh d9a61u TU72 na2o nu74a d9e63 Undo !", vbOKOnly + vbInformation, "---:: Tho6ng Ba1o ::---", "VNI"
End Sub
Sub CheckingResult()
Dim rng, rngListStartCell As Range, Cll As Range
Dim iLR As Integer
If Not IsSetTableWordOK Then Exit Sub
iLR = Sheet3.Cells(Sheet3.Rows.Count, Sheet3.Range("B2").Offset(0, iColOffset + 1).Column).End(xlUp).Row
Set rngListStartCell = Sheet3.Range("B2").Offset(0, iColOffset + 1).Resize(iLR - 1)
Application.ScreenUpdating = False
Sheet1.Unprotect Password:=myPass
Sheet1.Select
For Each Cll In rngListStartCell
If Cll.Value <> "" And Cll.Value <> "CANNOT PLACE" Then
If Not IsMarkingAlready(Cll.Value, Cll.Offset(, 3).Value) Then
Call DrawMarking(Cll.Value, Cll.Offset(, 3).Value, Cll.Offset(, 2).Value, Cll.Offset(, 1).Value, vbMagenta, True)
End If
End If
Next Cll
Call CountMarking
Sheet1.Protect Password:=myPass
Application.ScreenUpdating = True
Set rngListStartCell = Nothing
MsgBoxVN "Hoa2n ta61t vie65c kie63m tra d9a1nh da61u ta61t ca3 ca1c TU72 d9u7o75c d9a85t va2o trong ba3ng chu74 ...", vbOKOnly + vbInformation, "---:: Tho6ng Ba1o ::---", "VNI"
End Sub
'******************************************************************************************************************************
Sub CountMarking()
Dim shp As Object
Dim iRed As Integer, iBlue As Integer, iMagenta As Integer
For Each shp In ActiveSheet.Shapes
If shp.Name Like "*Rectangle*" Then
If shp.Line.ForeColor.RGB = vbRed Then iRed = iRed + 1
If shp.Line.ForeColor.RGB = vbBlue Then iBlue = iBlue + 1
If shp.Line.ForeColor.RGB = vbMagenta Then iMagenta = iMagenta + 1
End If
Next shp
Sheet1.Unprotect Password:=myPass
Sheet1.Range("U2:W2").ClearContents
Sheet1.Range("U2").Value = iRed
Sheet1.Range("V2").Value = iBlue
Sheet1.Range("W2").Value = iMagenta
Sheet1.Protect Password:=myPass
End Sub
Sub DeleteAllShapeMarking()
Dim shp As Shape, iLR As Integer
Sheet1.Unprotect Password:=myPass
Sheet1.Range("U2:W2").ClearContents
For Each shp In Sheet1.Shapes
If shp.Name Like "*Rectangle*" Then shp.Delete
Next shp
Sheet1.Protect Password:=myPass
'Delete Undo List Shape
iLR = Sheet3.Cells(Sheet3.Rows.Count, "AA").End(xlUp).Row
If iLR >= 2 Then Sheet3.Range("AA2:AC" & iLR).ClearContents
End Sub
'##############################################################################################################
Sub DrawMarking(ByVal strStartCell As String, ByVal strEndCell As String, ByVal iTotalCharOfWord As Integer, _
ByVal strDirectionIn As String, ByVal vColor, Optional blSave As Boolean = False)
Dim dbLeft As Double, dbTop As Double
Dim iLR As Integer
Dim SpecShape
SpecShape = GetSpecShapeMark(Sheet1.Range(strStartCell), iTotalCharOfWord, strDirectionIn)
Sheet1.Unprotect Password:=myPass
'.AddShape (Type, Left, Top, Width, Height)
With ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, SpecShape(1), SpecShape(2), SpecShape(5), SpecShape(6))
.Fill.Visible = msoFalse
.Line.Visible = msoTrue
.Line.ForeColor.RGB = vColor
.Line.Weight = 2.25
.IncrementRotation SpecShape(7)
If blSave Then
iLR = Sheet3.Cells(Sheet3.Rows.Count, "AA").End(xlUp).Row
Sheet3.Range("AA" & iLR + 1).Value = .Name
Sheet3.Range("AB" & iLR + 1).Value = strStartCell
Sheet3.Range("AC" & iLR + 1).Value = strEndCell
End If
End With
Sheet1.Protect Password:=myPass
End Sub
Function GetSpecShapeMark(ByVal rngStartCell As Range, ByVal iTotalCharOfWord As Integer, ByVal strDirection As String)
Dim i As Integer, iSurplus As Integer, iNoBaseCell As Integer
Dim dbLeft As Double, dbTop As Double, dbCenterX As Double, dbCenterY As Double
Dim dbWidth As Double, dbHeight As Double, dbRotateDegree As Double
Dim rngBaseCell As Range
Dim SpecShape(1 To 7) As Double
Dim oDirRC As Object
Set oDirRC = GetDirRCFactor(strDirection)
'Find Rotation degree
dbRotateDegree = oDirRC("rota") * 45
'Find WIDTH and HEIGHT
dbWidth = rngStartCell.Width
dbHeight = rngStartCell.Height
For i = 2 To iTotalCharOfWord
dbWidth = dbWidth + Abs(oDirRC("dirC")) * rngStartCell.Offset(, oDirRC("dirC") * (i - 1)).Width
dbHeight = dbHeight + Abs(oDirRC("dirR")) * rngStartCell.Offset(oDirRC("dirR") * (i - 1)).Height
Next i
If Left(strDirection, 2) <> "dU" And Left(strDirection, 2) <> "dD" Then 'only STRAIGHT order
dbWidth = dbWidth - 2 * dbFromLeft
dbHeight = dbHeight - 2 * dbFromTop
Else
dbWidth = Sqr(dbWidth ^ 2 + dbHeight ^ 2) - 2 * dbFromLeft
dbHeight = rngStartCell.Height - 2 * dbFromTop
End If
'Find TOP and LEFT and CENTER
If Left(strDirection, 2) <> "dU" And Left(strDirection, 2) <> "dD" Then 'only STRAIGHT order
iNoBaseCell = iTotalCharOfWord - 1
Select Case strDirection
Case "down", "right"
Set rngBaseCell = rngStartCell
Case "up", "left"
Set rngBaseCell = rngStartCell.Offset(oDirRC("dirR") * iNoBaseCell, oDirRC("dirC") * iNoBaseCell)
End Select
dbTop = rngBaseCell.Top + dbFromTop
dbLeft = rngBaseCell.Left + dbFromLeft
dbCenterX = dbLeft + (dbWidth / 2)
dbCenterY = dbTop + (dbHeight / 2)
Else
iSurplus = iTotalCharOfWord Mod 2 ' chia lay so du
If iSurplus = 0 Then
iNoBaseCell = iTotalCharOfWord / 2 - 1
Set rngBaseCell = rngStartCell.Offset(oDirRC("dirR") * iNoBaseCell, oDirRC("dirC") * iNoBaseCell)
Select Case strDirection
Case Is = "dUL" '(top, left)
dbCenterX = rngBaseCell.Left
dbCenterY = rngBaseCell.Top
Case Is = "dUR"
dbCenterX = rngBaseCell.Left + rngBaseCell.Width
dbCenterY = rngBaseCell.Top
Case Is = "dDL"
dbCenterX = rngBaseCell.Left
dbCenterY = rngBaseCell.Top + rngBaseCell.Height
Case Is = "dDR"
dbCenterX = rngBaseCell.Left + rngBaseCell.Width
dbCenterY = rngBaseCell.Top + rngBaseCell.Height
End Select
Else
iNoBaseCell = Application.WorksheetFunction.Quotient(iTotalCharOfWord, 2)
Set rngBaseCell = rngStartCell.Offset(oDirRC("dirR") * iNoBaseCell, oDirRC("dirC") * iNoBaseCell)
dbCenterX = rngBaseCell.Left + (rngBaseCell.Width / 2)
dbCenterY = rngBaseCell.Top + (rngBaseCell.Height / 2)
End If
dbLeft = dbCenterX - (dbWidth / 2)
dbTop = dbCenterY - (dbHeight / 2)
End If
SpecShape(1) = dbLeft
SpecShape(2) = dbTop
SpecShape(3) = dbCenterX
SpecShape(4) = dbCenterY
SpecShape(5) = dbWidth
SpecShape(6) = dbHeight
SpecShape(7) = dbRotateDegree
GetSpecShapeMark = SpecShape
End Function
Function IsMarkingAlready(ByVal strStartCell As String, ByVal strEndCell As String) As Boolean
Dim i As Integer, iLR As Integer
iLR = Sheet3.Cells(Sheet3.Rows.Count, "AA").End(xlUp).Row
If iLR >= 2 Then
For i = 2 To iLR
If (strStartCell = Sheet3.Range("AB" & i).Value And strEndCell = Sheet3.Range("AC" & i).Value) Or _
(strStartCell = Sheet3.Range("AC" & i).Value And strEndCell = Sheet3.Range("AB" & i).Value) Then
IsMarkingAlready = True
Exit Function
End If
Next i
Else
IsMarkingAlready = False
Exit Function
End If
IsMarkingAlready = False
End Function
Function IsSelectedWordCorrect(ByVal arrSelectCell) As Boolean
Dim strStartCell As String, strEndCell As String
Dim rngListStartCell As Range, Cll As Range
Dim iLR As Integer
strStartCell = arrSelectCell(LBound(arrSelectCell))
strEndCell = arrSelectCell(UBound(arrSelectCell))
iLR = Sheet3.Cells(Sheet3.Rows.Count, Sheet3.Range("B2").Offset(0, iColOffset + 1).Column).End(xlUp).Row
Set rngListStartCell = Sheet3.Range("B2").Offset(0, iColOffset + 1).Resize(iLR - 1)
For Each Cll In rngListStartCell
If (strStartCell = Cll.Value And strEndCell = Cll.Offset(, 3).Value) Or _
(strEndCell = Cll.Value And strStartCell = Cll.Offset(, 3).Value) Then
IsSelectedWordCorrect = True
GoTo ExitFunction
End If
Next Cll
IsSelectedWordCorrect = False
ExitFunction:
Set rngListStartCell = Nothing
End Function
Function IsSelectedCellOK(ByRef arrSelectCell, Optional blDisplayAlarm As Boolean = True) As Boolean
Dim iSizeTable As Integer
Dim rngSelection As Range, rngTableWord As Range, rngIntersect As Range
iSizeTable = SizeTable(Sheet1.Range(strCellSelectSizeTable).Value)
Set rngTableWord = Sheet1.Range(strStartCellTable).Resize(iSizeTable, iSizeTable)
If Selection.Count > iSizeTable * iSizeTable Then
If blDisplayAlarm Then
MsgBoxVN "D9a4 cho5n QUA1 nhie62u O6! => ... Ha4y cho5n lai5... ", vbOKOnly + vbExclamation, "---:: Tho6ng Ba1o ::---", "VNI"
End If
IsSelectedCellOK = False
GoTo ExitFunction
End If
'Tong cell chon phai >=2
arrSelectCell = GetArrayUniqueSelectCell(Selection)
Set rngSelection = Sheet1.Range(Join(arrSelectCell, ","))
If rngSelection.Count < 2 Then
If blDisplayAlarm Then
MsgBoxVN "Pha3i cho5n i1t nha61t 2 O6 trong ba3ng chu74!" & vbNewLine & "=> ... Ha4y cho5n lai5... ", vbOKOnly + vbExclamation, "---:: Tho6ng Ba1o ::---", "VNI"
End If
IsSelectedCellOK = False
GoTo ExitFunction
End If
'Check selection co1 trong table khong
Set rngIntersect = Intersect(rngSelection, rngTableWord)
If rngIntersect Is Nothing Then
If blDisplayAlarm Then
MsgBoxVN "Pha3i cho5n o6 NA82M TRONG BA3NG CHU74!" & vbNewLine & _
"=> ... Ha4y cho5n lai5... ", vbOKOnly + vbExclamation, "---:: Tho6ng Ba1o ::---", "VNI"
End If
IsSelectedCellOK = False
GoTo ExitFunction
Else
If rngIntersect.Count <> rngSelection.Count Then
If blDisplayAlarm Then
MsgBoxVN "Pha3i cho5n o6 NA82M TRONG BA3NG CHU74!" & vbNewLine & _
"=> ... Ha4y cho5n lai5... ", vbOKOnly + vbExclamation, "---:: Tho6ng Ba1o ::---", "VNI"
End If
IsSelectedCellOK = False
GoTo ExitFunction
End If
End If
'Check chon Cell lien tuc khong?
If Not IsSelectCellContinuous(arrSelectCell) Then
If blDisplayAlarm Then
MsgBoxVN "Cho5n o6 so61 SAI! Chu1 y1 ra82ng CHI3 D9U7O75C:" & vbNewLine & _
" - Cho5n o6 so61 lie6n tu5c cho phu7o7ng d9u71ng hoa85c ngang" & vbNewLine & _
" - hoa85c Cho5n o6 so61 no61i d9uo6i nhau cho phu7o7ng che1o" & vbNewLine & _
"=> Vui lo2ng cho5n lai5 ...", vbOKOnly + vbExclamation, "---:: Tho6ng Ba1o ::---", "VNI"
End If
IsSelectedCellOK = False
GoTo ExitFunction
End If
IsSelectedCellOK = True
ExitFunction:
Set rngTableWord = Nothing
Set rngSelection = Nothing
Set rngIntersect = Nothing
End Function
Function IsSelectCellContinuous(ByVal arrSelectCell) As Boolean
Dim i As Integer, iUB As Integer, iLB As Integer
Dim iRowDiff_Base As Integer, iColDiff_Base As Integer
Dim iRowDiff_WithStart As Integer, iColDiff_WithStart As Integer
Dim iRowDiff As Integer, iColDiff As Integer
Dim rngStart As Range, rngEnd As Range
iUB = UBound(arrSelectCell): iLB = LBound(arrSelectCell)
iRowDiff_Base = Abs(Range(arrSelectCell(iLB)).Row - Range(arrSelectCell(iLB + 1)).Row)
iColDiff_Base = Abs(Range(arrSelectCell(iLB)).Column - Range(arrSelectCell(iLB + 1)).Column)
Set rngStart = Range(arrSelectCell(iLB))
Set rngEnd = Range(arrSelectCell(iUB))
If iRowDiff_Base = 0 Then ' truong hop NGANG
For i = iLB To iUB - 1
iRowDiff = Abs(Range(arrSelectCell(i)).Row - Range(arrSelectCell(i + 1)).Row)
iColDiff = Abs(Range(arrSelectCell(i)).Column - Range(arrSelectCell(i + 1)).Column)
If Not (iRowDiff = 0 And iColDiff = 1) Then
IsSelectCellContinuous = False
GoTo ExitFunction
End If
Next i
Else
If iColDiff_Base = 0 Then ' truong hop DUNG
For i = iLB To iUB - 1
iRowDiff = Abs(Range(arrSelectCell(i)).Row - Range(arrSelectCell(i + 1)).Row)
iColDiff = Abs(Range(arrSelectCell(i)).Column - Range(arrSelectCell(i + 1)).Column)
If Not (iRowDiff = 1 And iColDiff = 0) Then
IsSelectCellContinuous = False
GoTo ExitFunction
End If
Next i
Else
If iRowDiff_Base = 1 And iColDiff_Base = 1 Then ' truong hop CHEO
For i = iLB To iUB
'Xet co tren duong cheo khong?
iRowDiff_WithStart = Abs(rngStart.Row - Range(arrSelectCell(i)).Row)
iColDiff_WithStart = Abs(rngStart.Column - Range(arrSelectCell(i)).Column)
If iRowDiff_WithStart <> iColDiff_WithStart Then
IsSelectCellContinuous = False
GoTo ExitFunction
End If
'Xet co lien tuc noi duoi nhau khong?
If i <> iUB Then
iRowDiff = Abs(Range(arrSelectCell(i)).Row - Range(arrSelectCell(i + 1)).Row)
iColDiff = Abs(Range(arrSelectCell(i)).Column - Range(arrSelectCell(i + 1)).Column)
If Not (iRowDiff = 1 And iColDiff = 1) Then
IsSelectCellContinuous = False
GoTo ExitFunction
End If
End If
Next i
Else 'Khong roi vao truong hop nao het => Chon SAI!
IsSelectCellContinuous = False
GoTo ExitFunction
End If
End If
End If
IsSelectCellContinuous = True
ExitFunction:
Set rngStart = Nothing
Set rngEnd = Nothing
End Function
Function GetArrayUniqueSelectCell(ByVal rngSelection As Range)
Dim Dic As Object
Dim i As Integer, j As Integer, k As Integer, iStep As Integer
Dim strTemp As String
Dim Cll As Range
Dim arrSelectCell
Set Dic = CreateObject("Scripting.Dictionary")
For Each Cll In rngSelection
If Not Dic.Exists(Cll.Address) Then Dic.Add Cll.Address, ""
Next Cll
arrSelectCell = Dic.Keys
'Sap xep các cell chon có row tu nho toi lon
If LBound(arrSelectCell) = UBound(arrSelectCell) Then GoTo ExitFunction
i = LBound(arrSelectCell)
Do
If Range(arrSelectCell(i)).Row = Range(arrSelectCell(i + 1)).Row Then
'Tim cac range co Row bang nhau va xep chung theo Col tu nho toi lon
iStep = 1
For j = i To UBound(arrSelectCell) - 1
For k = j + 1 To UBound(arrSelectCell)
If Range(arrSelectCell(j)).Row = Range(arrSelectCell(k)).Row And _
Range(arrSelectCell(j)).Column > Range(arrSelectCell(k)).Column Then
strTemp = arrSelectCell(j)
arrSelectCell(j) = arrSelectCell(k)
arrSelectCell(k) = strTemp
iStep = iStep + 1
End If
Next k
Next j
i = i + iStep
Else
'Tim cac range co Row bang nhau va xep chung theo Col tu nho toi lon
iStep = 1
If Range(arrSelectCell(i)).Column = Range(arrSelectCell(i + 1)).Column Then
For j = i To UBound(arrSelectCell)
For k = j + 1 To UBound(arrSelectCell)
If Range(arrSelectCell(j)).Column = Range(arrSelectCell(k)).Column And _
Range(arrSelectCell(j)).Row > Range(arrSelectCell(k)).Row Then
strTemp = arrSelectCell(j)
arrSelectCell(j) = arrSelectCell(k)
arrSelectCell(k) = strTemp
iStep = iStep + 1
End If
Next k
Next j
i = i + iStep
Else
'Tim cac range co Row khac nhau va xep chung theo Row tu nho toi lon
iStep = 1
If Range(arrSelectCell(i)).Row <> Range(arrSelectCell(i + 1)).Row Then
For j = i To UBound(arrSelectCell)
For k = j + 1 To UBound(arrSelectCell)
If Range(arrSelectCell(j)).Row > Range(arrSelectCell(k)).Row Then
strTemp = arrSelectCell(j)
arrSelectCell(j) = arrSelectCell(k)
arrSelectCell(k) = strTemp
iStep = iStep + 1
End If
Next k
Next j
i = i + iStep
End If
End If
End If
Loop Until i >= UBound(arrSelectCell) - 1
ExitFunction:
GetArrayUniqueSelectCell = arrSelectCell
Set Dic = Nothing
End Function
Function GetDirectionOfSelectedCell(ByVal strStartCell As String, ByVal strEndCell As String) As String
Dim rngStart As Range, rngEnd As Range
Set rngStart = Range(strStartCell)
Set rngEnd = Range(strEndCell)
'chon cell theo duong NGANG
If rngStart.Row = rngEnd.Row Then
If rngStart.Column > rngEnd.Column Then GetDirectionOfSelectedCell = "left"
If rngStart.Column < rngEnd.Column Then GetDirectionOfSelectedCell = "right"
End If
'Chon Cell theo duong DUNG
If rngStart.Column = rngEnd.Column Then
If rngStart.Row > rngEnd.Row Then GetDirectionOfSelectedCell = "up"
If rngStart.Row < rngEnd.Row Then GetDirectionOfSelectedCell = "down"
End If
'Chon Cell theo duong CHEO
If rngStart.Row <> rngEnd.Row And rngStart.Column <> rngEnd.Column Then
If rngStart.Row > rngEnd.Row And rngStart.Column > rngEnd.Column Then GetDirectionOfSelectedCell = "dUL"
If rngStart.Row > rngEnd.Row And rngStart.Column < rngEnd.Column Then GetDirectionOfSelectedCell = "dUR"
If rngStart.Row < rngEnd.Row And rngStart.Column > rngEnd.Column Then GetDirectionOfSelectedCell = "dDL"
If rngStart.Row < rngEnd.Row And rngStart.Column < rngEnd.Column Then GetDirectionOfSelectedCell = "dDR"
End If
Set rngStart = Nothing
Set rngEnd = Nothing
End Function
Sub OffEventReturnKey()
Application.OnKey "{RETURN}"
End Sub
