;(VBA AutoCad)Creat Centerline, shorcutkey [CCL]
(defun C:CCL()
(command "-vbarun" "TBR11CreatCenterLine")
)

;(VBA AutoCad)Creat Phantom Line Throught 2 Point, shorcutkey [PL2P]
(defun C:PL2P()
(command "-vbarun" "TBR10PhantomLine2Point")
)

;(VBA AutoCad)Increase, Decrease Length of Line, shorcutkey [LENDE]
(defun C:LENDE()
(command "-vbarun" "TBR09LengthDelta")
)

;(VBA AutoCad)Convert Text to MText and BringToFront, shorcutkey [T2MT]
(defun C:T2MT()
(command "-vbarun" "TBR08ConvertText2MTextBringToFront")
)

;(VBA AutoCad)Duplicate Obj, shorcutkey [DUP]
(defun C:DUP()
(command "-vbarun" "TBR07DuplicateObj")
)

;(VBA AutoCad)Only select dimension, shorcutkey [SD]
(defun C:SD()
(command "-vbarun" "TBR03SelectDimension")
)

;(VBA AutoCad)Only select Text and MText, shorcutkey [ST]
(defun C:ST()
(command "-vbarun" "TBR04SelectTextMText")
)

;(VBA AutoCad)Only select Block, shorcutkey [SB]
(defun C:SB()
(command "-vbarun" "TBR05SelectBlock")
)

;(VBA AutoCad)Select Obj By Layer, shorcutkey [SBL]
(defun C:SBL()
(command "-vbarun" "TBR06SelectByLayer")
)

;(VBA AutoCad) Noi tam cac duong tron thang hang
(defun C:C2C()
(command "-vbarun" "TBR02ConnectCenter2Center")
)

;(VBA AutoCad)(Dimension),shorcutkey "DN"
(defun C:DN()
(command "-vbarun" "TBR01EditDimensionDongMoNgoac")
)

;(VBA AutoCad)Quick Print to PDF
(defun C:QPRINT()
(command "-vbarun" "TH0202AutomaticPrint")
)

;(VBA AutoCad)Creat Pitch Dimension (P***x***=****)
(defun C:CPD()
(command "-vbarun" "TH0201CreatPitchDimension")
)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Sub TH0201CreatPitchDimension()
'Creat Pitch Dimension (P***x***=****), shortcut key [CPD]
Thisdrawing.Utility.Prompt (vbCrLf & "Creat Pitch Dimension")


'Get Pitch and sum
Dim ObjPitchDim As AcadDimension
Dim ObjSumDim As AcadDimension
Dim Pitch As Double
Dim Sum As Double
Dim TmpQty As Double
Dim Qty As Integer
Dim TextOverride As String
Dim ObjArr As AcadDimension
Dim TmpObjArr As Variant
Thisdrawing.Utility.Prompt (vbCrLf & "Select Picth and Sum Dimension")
TmpObjArr = Func68SelectOnScreenByType("DIMENSION", "", "", "", "", 2)
If VarType(TmpObjArr) = vbEmpty Then
Exit Sub
Else
Set ObjPitchDim = TmpObjArr(0)
Set ObjSumDim = TmpObjArr(1)
Pitch = Func67GetDimensionMeasurement(ObjPitchDim)
Sum = Func67GetDimensionMeasurement(ObjSumDim)
If Pitch > Sum Then
Set ObjPitchDim = TmpObjArr(1)
Set ObjSumDim = TmpObjArr(0)
Pitch = Func67GetDimensionMeasurement(ObjPitchDim)
Sum = Func67GetDimensionMeasurement(ObjSumDim)
End If
End If

'Define Qty
TmpQty = Sum / Pitch
Qty = Int(TmpQty)
If Qty = 1 Then
MsgBox "Px1???"
Exit Sub
End If
If Qty = TmpQty Then
TextOverride = "P" & Pitch & "x" & Qty & "=" & "<>"
Call Func69ChangeDimensionProperty(ObjSumDim, TextOverride, "", "")
Else
MsgBox "P" & Pitch & "x" & Qty & "<>" & Sum
End If

End Sub
Sub TBR01EditDimensionDongMoNgoac()
'Dong mo ngoac doi tuong kich thuoc, neu kich thuoc da dong mo ngoac thi xoa
'Shorcut "DN", dong ngoac

Dim DimTextOverride As String
Dim DimPrefix As String: DimPrefix = "("
Dim DimSuffix As String: DimSuffix = ")"
Dim OldPrefix As String
Dim OldTextOverride As String

'Chon doi tuong bang select on screen
Dim ObjDim As AcadDimension
Dim ObjDimName As String
Dim objSelectOnScreen As AcadSelectionSet
Dim EachobjSelectOnScreen As AcadDimension
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
Dim FT(2) As Integer
Dim FD(2) As Variant
FT(0) = -4: FD(0) = "<OR"
FT(1) = 0: FD(1) = "DIMENSION"
FT(2) = -4: FD(2) = "OR>"
Thisdrawing.Utility.Prompt vbCrLf & "Select Dimension to Edit:"
objSelectOnScreen.SelectOnScreen FT, FD
If objSelectOnScreen.count = 0 Then
MsgBox "Please select dimension"
objSelectOnScreen.Delete
Exit Sub
End If
For Each EachobjSelectOnScreen In objSelectOnScreen
Set ObjDim = EachobjSelectOnScreen
OldTextOverride = ObjDim.TextOverride
OldPrefix = ObjDim.TextPrefix
Select Case ObjDim.ObjectName
Case "AcDbRadialDimension", "AcDbDiametricDimension"
If InStr(OldTextOverride, "(") <> 0 Then
DimTextOverride = ""
Else
DimTextOverride = "(<>)"
End If
ObjDim.TextOverride = DimTextOverride
Case Else
If InStr(OldPrefix, "(") <> 0 Then
ObjDim.TextPrefix = ""
ObjDim.TextSuffix = ""
Else
ObjDim.TextPrefix = DimPrefix
ObjDim.TextSuffix = DimSuffix
End If
End Select
ObjDim.Update
Next

objSelectOnScreen.Delete

End Sub
Sub TBR02ConnectCenter2Center()
'Connent Circle to circle by centerline

'Select Circle by select on screen
Dim objSelectOnScreen As AcadSelectionSet
Dim EachobjSelectOnScreen As AcadCircle
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 0: FD(0) = "CIRCLE"
Thisdrawing.Utility.Prompt vbCrLf & "Select Circle:"
objSelectOnScreen.SelectOnScreen FT, FD
If objSelectOnScreen.count = 0 Then
MsgBox "No Obj"
objSelectOnScreen.Delete
Exit Sub
End If
Dim PointArr() As Variant
Dim CenterPoint As Variant
Dim CenterPointX As Double
Dim CenterPointY As Double
Dim TmpPoint As Variant
Dim TmpPointX As Double
Dim TmpPointY As Double
Dim k As Integer
Dim CheckHave As Boolean
ReDim PointArr(0)
For Each EachobjSelectOnScreen In objSelectOnScreen
CheckHave = False
CenterPoint = EachobjSelectOnScreen.Center
CenterPointX = CenterPoint(0)
CenterPointY = CenterPoint(1)
For i = LBound(PointArr) To UBound(PointArr)
TmpPoint = PointArr(i)
If VarType(TmpPoint) <> vbEmpty Then
TmpPointX = TmpPoint(0)
TmpPointY = TmpPoint(1)
If CenterPointX = TmpPointX And CenterPointY = TmpPointY Then CheckHave = True
End If
Next
If CheckHave = False Then
ReDim Preserve PointArr(O To k)
PointArr(k) = CenterPoint
k = k + 1
End If
Next

'Creat XYArray From PointArr
Dim XYArr As Variant
ReDim XYArr(0 To UBound(PointArr), 0 To 1)
For i = LBound(PointArr) To UBound(PointArr)
TmpPoint = PointArr(i)
XYArr(i, 0) = Round(TmpPoint(0), 2)
XYArr(i, 1) = Round(TmpPoint(1), 2)
Next

'Creat XArr(XValue,Ymin,Ymax)
Dim TmpXArr() As Variant
Dim XArr() As Variant
Dim MinY As Double
Dim MaxY As Double
Dim TmpDouble As Double
TmpXArr = Func71CreatListFromArr(XYArr, 0)
ReDim XArr(0 To UBound(TmpXArr), 0 To 2)
For i = LBound(XArr) To UBound(XArr)
TmpDouble = TmpXArr(i)
MinY = Func72FindMinMaxFromXYArr(XYArr, TmpDouble, "YMIN")
MaxY = Func72FindMinMaxFromXYArr(XYArr, TmpDouble, "YMAX")
XArr(i, 0) = TmpDouble
XArr(i, 1) = MinY
XArr(i, 2) = MaxY
Call Func73DrawLineThrough2Point(TmpDouble, MinY, TmpDouble, MaxY, CenterLayerName)
Next

'Creat YArr(YValue,Xmin,Xmax)
Dim TmpYArr() As Variant
Dim YArr() As Variant
Dim MinX As Double
Dim MaxX As Double
TmpYArr = Func71CreatListFromArr(XYArr, 1)
ReDim YArr(0 To UBound(TmpYArr), 0 To 2)
For i = LBound(YArr) To UBound(YArr)
TmpDouble = TmpYArr(i)
MinX = Func72FindMinMaxFromXYArr(XYArr, TmpDouble, "XMIN")
MaxX = Func72FindMinMaxFromXYArr(XYArr, TmpDouble, "XMAX")
YArr(i, 0) = TmpDouble
YArr(i, 1) = MinX
YArr(i, 2) = MaxX
Call Func73DrawLineThrough2Point(MinX, TmpDouble, MaxX, TmpDouble, CenterLayerName)
Next
objSelectOnScreen.Delete

End Sub

Sub TBR03SelectDimension()
'(VBA AutoCad)Only select dimension, shorcutkey [SD]
Dim objSelectOnScreen As AcadSelectionSet
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 0: FD(0) = "DIMENSION"
'FT(0) = -4: FD(0) = "<OR"
'FT(1) = 0: FD(1) = ObjType1
'FT(2) = 0: FD(2) = ObjType2
'FT(3) = -4: FD(3) = "OR>"
objSelectOnScreen.SelectOnScreen FT, FD
Thisdrawing.SendCommand "select" & vbCr & "P" & vbCr & vbCr
objSelectOnScreen.Delete

End Sub

Sub TBR04SelectTextMText()
'(VBA AutoCad)Only select Text and MText, shorcutkey [ST]
Dim objSelectOnScreen As AcadSelectionSet
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
Dim FT(3) As Integer
Dim FD(3) As Variant

FT(0) = -4: FD(0) = "<OR"
FT(1) = 0: FD(1) = "TEXT"
FT(2) = 0: FD(2) = "MTEXT"
FT(3) = -4: FD(3) = "OR>"
objSelectOnScreen.SelectOnScreen FT, FD
Thisdrawing.SendCommand "select" & vbCr & "P" & vbCr & vbCr
objSelectOnScreen.Delete

End Sub

Sub TBR05SelectBlock()
'(VBA AutoCad)Only select Block, shorcutkey [SB]
Dim objSelectOnScreen As AcadSelectionSet
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 0: FD(0) = "INSERT"
objSelectOnScreen.SelectOnScreen FT, FD
Thisdrawing.SendCommand "select" & vbCr & "P" & vbCr & vbCr
objSelectOnScreen.Delete

End Sub

Sub TBR06SelectByLayer()
'(VBA AutoCad)Select Obj By Layer, shorcutkey [SBL]

'Define layername from GetEntity
Dim LayerName As String
Dim varPick As Variant
Dim Msg As String: Msg = "Select Layer by Object:"
Dim objSelect As AcadEntity
Dim CountLoop As Integer
On Error Resume Next
Do While objSelect Is Nothing
If CountLoop = 3 Then Exit Sub
Thisdrawing.Utility.GetEntity objSelect, varPick, Msg
CountLoop = CountLoop + 1
Loop
LayerName = objSelect.layer
objSelect.Highlight True

Dim objSelectOnScreen As AcadSelectionSet
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 8: FD(0) = LayerName
objSelectOnScreen.SelectOnScreen FT, FD
objSelect.Highlight False
Thisdrawing.SendCommand "select" & vbCr & "P" & vbCr & vbCr
objSelectOnScreen.Delete

End Sub

Sub TBR07DuplicateObj()
'(VBA AutoCad)Duplicate Obj, shorcutkey [DUP]

'Select any entity select on screen
Dim EntitySelect As AcadSelectionSet
Dim EachEntity As AcadEntity
Dim CopyEachEntity As AcadEntity
Set EntitySelect = Thisdrawing.SelectionSets.Add("EntitySelect" & Now)
EntitySelect.SelectOnScreen
If EntitySelect.count = 0 Then
EntitySelect.Delete
Exit Sub
End If
For Each EachEntity In EntitySelect
Set CopyEachEntity = EachEntity.Copy
Next
EntitySelect.Delete

End Sub

Sub TBR08ConvertText2MTextBringToFront()
'(VBA AutoCad)Convert Text to MText and BringToFront, shorcutkey [T2MT]

'Select any entity select on screen
Dim EntitySelect As AcadSelectionSet
Dim EachEntity As AcadText
Dim EachMText As AcadMText
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 0: FD(0) = "TEXT"
Set EntitySelect = Thisdrawing.SelectionSets.Add("EntitySelect" & Now)
EntitySelect.SelectOnScreen FT, FD
If EntitySelect.count = 0 Then
EntitySelect.Delete
Exit Sub
End If
For Each EachEntity In EntitySelect
Set EachMText = Func74ConvertText2MText(EachEntity)
' EachMText.BackgroundFill = True
Call Func75DrawOrder(EachMText, "Front")
Next
EntitySelect.Delete

End Sub

Sub TBR09LengthDelta()
'(VBA AutoCad)Increase, Decrease Length of Line, shorcutkey [LENDE]

'Select any entity select on screen
Dim objSelectOnScreen As AcadSelectionSet
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 0: FD(0) = "LINE"
objSelectOnScreen.SelectOnScreen FT, FD
If objSelectOnScreen.count = 0 Then
objSelectOnScreen.Delete
Exit Sub
End If

'Get Delta
Dim Delta As Double
On Error GoTo ResumeNext
Delta = Thisdrawing.Utility.GetReal("Delta=")
ResumeNext:
If Delta = 0 Then
objSelectOnScreen.Delete
Exit Sub
End If

Dim OldLine As AcadLine
Dim OldStartPoint As Variant
Dim OldEndPoint As Variant
Dim Angle As Double
Dim NewLine As AcadLine
Dim NewStartPoint As Variant
Dim NewEndPoint As Variant
For Each OldLine In objSelectOnScreen
OldStartPoint = OldLine.StartPoint
OldEndPoint = OldLine.EndPoint
Angle = OldLine.Angle
'Creat Newline
NewStartPoint = Thisdrawing.Utility.PolarPoint(OldStartPoint, Angle, -Delta)
NewEndPoint = Thisdrawing.Utility.PolarPoint(OldEndPoint, Angle, Delta)
Set NewLine = Thisdrawing.ModelSpace.AddLine(NewStartPoint, NewEndPoint)
Call Func76MatchObj(OldLine, NewLine)
OldLine.Delete
Next
objSelectOnScreen.Delete

End Sub
Sub TBR10PhantomLine2Point()
'(VBA AutoCad)Creat Phantom Line Throught 2 Point, shorcutkey [PL2P]

'Set UCS is world
Thisdrawing.SendCommand "UCS" & vbCr & "W" & vbCr

'Get StartPoint and EndPoint
Dim OldStartPoint As Variant
Dim OldEndPoint As Variant
Dim Angle As Double
On Error GoTo ExitSub
OldStartPoint = Thisdrawing.Utility.GetPoint(, "Start Point select")
OldEndPoint = Thisdrawing.Utility.GetPoint(OldStartPoint, "End Point select")
Angle = Func23AngleOfLineThrough2Point(OldStartPoint, OldEndPoint)

'Define Delta
Dim Delta As Double: Delta = -1

'Creat Newline
Dim NewLine As AcadLine
Dim NewStartPoint As Variant
Dim NewEndPoint As Variant
NewStartPoint = Thisdrawing.Utility.PolarPoint(OldStartPoint, Angle, -Delta)
NewEndPoint = Thisdrawing.Utility.PolarPoint(OldEndPoint, Angle, Delta)
Set NewLine = Thisdrawing.ModelSpace.AddLine(NewStartPoint, NewEndPoint)

'Set layer for NewLine
NewLine.layer = PhantomLayerName
Call Func43SetBylayer(NewLine)

ExitSub:
End Sub
Sub TBR11CreatCenterLine()
'(VBA AutoCad)Creat Centerline, shorcutkey [CCL]

Thisdrawing.Utility.Prompt (vbCrLf & "Creat Centerline")
'Define pi
Dim pi As Double
pi = 4 * Atn(1)
'Define Delta=DIMSCALE*1.5
Dim Delta As Double
Dim Dimscale As Double
Dimscale = Thisdrawing.GetVariable("DIMSCALE")
Delta = 1.5 * Dimscale

'Get 2 lines
Thisdrawing.Utility.Prompt (vbCrLf & "Select 2 Lines")
Dim objSelectOnScreen As AcadSelectionSet
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
Dim FTL(0) As Integer
Dim FDL(0) As Variant
FTL(0) = 0: FDL(0) = "LINE"
objSelectOnScreen.SelectOnScreen FTL, FDL
If objSelectOnScreen.count <> 2 Then
objSelectOnScreen.Delete
Exit Sub
End If
Dim EachobjSelectOnScreen As AcadEntity
Dim LineArr(0 To 1) As AcadLine
Dim ObjLine0 As AcadLine
Dim Objline1 As AcadLine
Dim i As Integer
For Each EachobjSelectOnScreen In objSelectOnScreen
Set LineArr(i) = EachobjSelectOnScreen
i = i + 1
Next
Set ObjLine0 = LineArr(0)
Set Objline1 = LineArr(1)
objSelectOnScreen.Clear

'Select Circle or Arc
Thisdrawing.Utility.Prompt (vbCrLf & "Select Circles or Arcs")
Dim FT(3) As Integer
Dim FD(3) As Variant
FT(0) = -4: FD(0) = "<OR"
FT(1) = 0: FD(1) = "CIRCLE"
FT(2) = 0: FD(2) = "ARC"
FT(3) = -4: FD(3) = "OR>"
objSelectOnScreen.SelectOnScreen FT, FD
If objSelectOnScreen.count = 0 Then
objSelectOnScreen.Delete
Exit Sub
End If
Dim ObjCircle As AcadCircle
Dim ObjArc As AcadArc
'Creat TmpLine
Dim TmpLine As AcadLine
Dim TmpPoint1 As Variant
Dim TmpPoint2 As Variant
Dim TmpAngle As Double
TmpAngle = ObjLine0.Angle + pi / 2
'Creat centerline
Dim CenterLine As AcadLine
Dim Point1 As Variant
Dim Point2 As Variant
'Extent Centerline with delta
Dim NewPoint1 As Variant
Dim NewPoint2 As Variant
For Each EachobjSelectOnScreen In objSelectOnScreen
Select Case EachobjSelectOnScreen.ObjectName
Case "AcDbCircle"
Set ObjCircle = EachobjSelectOnScreen
TmpPoint1 = ObjCircle.Center
Case "AcDbArc"
Set ObjArc = EachobjSelectOnScreen
TmpPoint1 = ObjArc.Center
End Select
TmpPoint2 = Thisdrawing.Utility.PolarPoint(TmpPoint1, TmpAngle, 1)
Set TmpLine = Thisdrawing.ModelSpace.AddLine(TmpPoint1, TmpPoint2)
'Creat centerline
Point1 = TmpLine.IntersectWith(ObjLine0, acExtendThisEntity)
Point2 = TmpLine.IntersectWith(Objline1, acExtendThisEntity)
TmpLine.Delete
'Extent Centerline with delta
NewPoint1 = Thisdrawing.Utility.PolarPoint(Point1, TmpAngle, -Delta)
NewPoint2 = Thisdrawing.Utility.PolarPoint(Point2, TmpAngle, Delta)
Set CenterLine = Thisdrawing.ModelSpace.AddLine(NewPoint1, NewPoint2)
'Set layer
CenterLine.layer = CenterLayerName
Call Func43SetBylayer(CenterLine)
Next

objSelectOnScreen.Delete

End Sub


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Function Func67GetDimensionMeasurement(ObjDim As AcadDimension) As Double
'Get Measurement of Dimension

Dim DimMeasure As Double
Dim UnitPrecision As Integer
Dim L As Double
DimMeasure = ObjDim.Measurement
UnitPrecision = ObjDim.PrimaryUnitsPrecision
L = Round(DimMeasure, UnitPrecision)
Func67GetDimensionMeasurement = L
End Function
Function Func68SelectOnScreenByType(ObjType1 As String, ObjType2 As String, ObjType3 As String, ObjType4 As String, ObjType5 As String, Qty As Variant) As Variant

Dim objSelectOnScreen As AcadSelectionSet
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
Dim FT(6) As Integer
Dim FD(6) As Variant
FT(0) = -4: FD(0) = "<OR"
FT(1) = 0: FD(1) = ObjType1
FT(2) = 0: FD(2) = ObjType2
FT(3) = 0: FD(3) = ObjType3
FT(4) = 0: FD(4) = ObjType4
FT(5) = 0: FD(5) = ObjType5
FT(6) = -4: FD(6) = "OR>"
objSelectOnScreen.SelectOnScreen FT, FD
If objSelectOnScreen.count = 0 Then
MsgBox "No Select"
objSelectOnScreen.Delete
Exit Function
End If
If VarType(Qty) = vbInteger Then
If objSelectOnScreen.count <> Qty Then
MsgBox "Obj Qty <> " & Qty
objSelectOnScreen.Delete
Exit Function
End If
End If
Dim EachObj As AcadEntity
Dim ObjArr() As Variant
Dim i As Integer
For Each EachObj In objSelectOnScreen
ReDim Preserve ObjArr(0 To i)
Set ObjArr(i) = EachObj
i = i + 1
Next
objSelectOnScreen.Delete
Func68SelectOnScreenByType = ObjArr
End Function
Function Func69ChangeDimensionProperty(DimObj As AcadDimension, TextOverride As String, DimPrefix As String, DimSuffix As String)
If TextOverride <> "" Then DimObj.TextOverride = TextOverride
If DimPrefix <> "" Then DimObj.TextPrefix = DimPrefix
If DimSuffix <> "" Then DimObj.TextSuffix = DimSuffix
DimObj.Update
End Function
Function Func70IsEmptyArray(anArray As Variant)

Dim i As Integer

On Error Resume Next
i = UBound(anArray, 1)
If Err.Number = 0 Then
Func70IsEmptyArray = False
Else
Func70IsEmptyArray = True
End If

End Function
Function Func71CreatListFromArr(Arr As Variant, ColumnNumber As Integer) As Variant
'Function dung tao list cac doi tuong k trung nhau
If Func70IsEmptyArray(Arr) = True Then Exit Function

Dim TmpArr() As Variant
Dim TmpValue As Variant
Dim CheckHave As Boolean
Dim k As Integer
Dim j As Integer
ReDim TmpArr(0)
For i = LBound(Arr) To UBound(Arr)
TmpValue = Arr(i, ColumnNumber)
CheckHave = False
For k = LBound(TmpArr) To UBound(TmpArr)
If TmpValue = TmpArr(k) Then
CheckHave = True
End If
Next
If CheckHave = False Then
ReDim Preserve TmpArr(0 To j)
TmpArr(j) = TmpValue
j = j + 1
End If
Next
Func71CreatListFromArr = TmpArr
End Function
Function Func72FindMinMaxFromXYArr(XYArr As Variant, XYValue As Double, ValueType As String) As Double

If Func70IsEmptyArray(XYArr) = True Then Exit Function

'Define ValueColumn, MinMaxColumn
Dim MinMaxColumn As Integer
Dim ValueColumn As Integer
Select Case ValueType
Case "XMAX"
MinMaxColumn = 0
ValueColumn = 1
Case "XMIN"
MinMaxColumn = 0
ValueColumn = 1
Case "YMAX"
MinMaxColumn = 1
ValueColumn = 0
Case "YMIN"
MinMaxColumn = 1
ValueColumn = 0
End Select

Dim TmpValue As Double
Dim TmpMinMaxValue As Double
Dim MinValue As Double
Dim MaxValue As Double
'Define MinValue,MaxValue
For i = LBound(XYArr) To UBound(XYArr)
TmpValue = XYArr(i, ValueColumn)
TmpMinMaxValue = XYArr(i, MinMaxColumn)
If TmpValue = XYValue Then
MaxValue = TmpMinMaxValue
MinValue = TmpMinMaxValue
End If
Next


For i = LBound(XYArr) To UBound(XYArr)
TmpValue = XYArr(i, ValueColumn)
TmpMinMaxValue = XYArr(i, MinMaxColumn)
If TmpValue = XYValue Then
If TmpMinMaxValue >= MaxValue Then MaxValue = TmpMinMaxValue
If TmpMinMaxValue <= MinValue Then MinValue = TmpMinMaxValue
End If
Next
Select Case ValueType
Case "XMAX"
Func72FindMinMaxFromXYArr = MaxValue
Case "YMAX"
Func72FindMinMaxFromXYArr = MaxValue
Case "XMIN"
Func72FindMinMaxFromXYArr = MinValue
Case "YMIN"
Func72FindMinMaxFromXYArr = MinValue
End Select
End Function
Function Func73DrawLineThrough2Point(Point1X As Double, Point1Y As Double, Point2X As Double, Point2Y As Double, LayerName As String)

Dim Point1(0 To 2) As Double
Dim Point2(0 To 2) As Double
Point1(0) = Point1X
Point1(1) = Point1Y
Point2(0) = Point2X
Point2(1) = Point2Y
Dim Line As AcadLine
If Point1X = Point2X And Point1Y = Point2Y Then
Else
Set Line = Thisdrawing.ModelSpace.AddLine(Point1, Point2)
Line.layer = LayerName
End If

End Function

Function Func74ConvertText2MText(ObjText As AcadText) As AcadMText
'Function Convert Text to MText

Dim ObjMText As AcadMText

'Get infomation from ObjText
Dim InsertPoint As Variant
Dim TextAlignment As AcAlignment
Dim TextString As String
InsertPoint = ObjText.InsertionPoint
TextString = ObjText.TextString
TextAlignment = ObjText.Alignment


'Define AttachmentPoint follow Alignment
Dim AttachmentPoint As AcAttachmentPoint
Select Case TextAlignment
Case acAlignmentBottomCenter, acAlignmentCenter
AttachmentPoint = acAttachmentPointBottomCenter
Case acAlignmentBottomLeft, acAlignmentLeft
AttachmentPoint = acAttachmentPointBottomLeft
Case acAlignmentBottomRight, acAlignmentRight
AttachmentPoint = acAttachmentPointBottomRight
Case acAlignmentMiddleCenter, acAlignmentMiddle
AttachmentPoint = acAttachmentPointMiddleCenter
Case acAlignmentMiddleLeft
AttachmentPoint = acAttachmentPointMiddleLeft
Case acAlignmentMiddleRight
AttachmentPoint = acAttachmentPointMiddleRight
Case acAlignmentTopCenter
AttachmentPoint = acAttachmentPointTopCenter
Case acAlignmentTopLeft
AttachmentPoint = acAttachmentPointTopLeft
Case acAlignmentTopRight
AttachmentPoint = acAttachmentPointTopRight
End Select

Set ObjMText = Thisdrawing.ModelSpace.AddMText(InsertPoint, 0, TextString)
ObjMText.layer = ObjText.layer
ObjMText.Height = ObjText.Height
Call Func43SetBylayer(ObjMText)
ObjMText.AttachmentPoint = AttachmentPoint
ObjMText.Rotation = ObjText.Rotation

'Move Text
Dim FromPoint As Variant
Dim ToPoint As Variant
FromPoint = Func19ObjectCenterPoint(ObjMText)
ToPoint = Func19ObjectCenterPoint(ObjText)
Call FuncMoveX(ObjMText, FromPoint, ToPoint)
Call FuncMoveY(ObjMText, FromPoint, ToPoint)

Set Func74ConvertText2MText = ObjMText
ObjText.Delete
End Function

Function Func75DrawOrder(Obj As AcadEntity, FrontBack As String)
'Bring Obj to Front, Send Obj to Back
Dim ObjHandle As String
Dim ObjHandent As String
ObjHandle = Obj.Handle
ObjHandent = "(handent " & Chr(34) & ObjHandle & Chr(34) & ")"
FrontBack = UCase(FrontBack)
Select Case FrontBack
Case "FRONT"
Thisdrawing.SendCommand "DRAWORDER" & vbCr & ObjHandent & vbCr & vbCr & "F" & vbCr
Case "BACK"
Thisdrawing.SendCommand "DRAWORDER" & vbCr & ObjHandent & vbCr & vbCr & "B" & vbCr
End Select

End Function

Function Func76MatchObj(OriginObj As AcadEntity, MatchObj As AcadEntity)
'Function Match: Color, layer, linetype, lineweight, linetypescale=1

MatchObj.Color = OriginObj.Color
MatchObj.layer = OriginObj.layer
MatchObj.Linetype = OriginObj.Linetype
MatchObj.Lineweight = acLnWtByLayer
MatchObj.LinetypeScale = 1

End Function