Announcements
Attention for Customers without Multi-Factor Authentication or Single Sign-On - OTP Verification rolls out April 2025. Read all about it here.

'Setting For Update Block Version 2
    Public OpeningFileArr() As String
    Public UB_UpdateFromDrawing As String
    Public UB_UpdateToDrawing As String
Function HCF4159_Call_FilterOnlyRotatedDimInDimSelectSet(DimSS As AcadSelectionSet)
'Check Input
    If DimSS.Count = 0 Then Exit Function
'Filter
    Dim EachDim As AcadDimension
    Dim IsNotRotatedDimArr() As AcadDimension
    Dim k As Integer
    For Each EachDim In DimSS
        If EachDim.ObjectName <> "AcDbRotatedDimension" Then
            ReDim Preserve IsNotRotatedDimArr(0 To k)
            Set IsNotRotatedDimArr(k) = EachDim
            k = k + 1
        End If
    Next
    If k > 0 Then DimSS.RemoveItems (IsNotRotatedDimArr)
End Function
Function HCF4160_LimitPointOfBlockRef(BlockRef As AcadBlockReference) As Variant
'Result(MinPoint,MaxPoint)
    HCF4160_LimitPointOfBlockRef = False
'Setting
    Dim ObjLayerName As String
    Select Case ProjectName
        Case "DFK"
            ObjLayerName = DFK_NormalLayerName
        Case "KKS"
            ObjLayerName = KKS_NormalLayerName
        Case Else
            ObjLayerName = "0"
    End Select
'Creat BackupBlockRef
    Dim BKBlockRef As AcadBlockReference: Set BKBlockRef = BlockRef.Copy
    Dim AfterExplodeArr As Variant
    AfterExplodeArr = BKBlockRef.Explode
    BKBlockRef.Delete
'Define MinPoint, MaxPoint of AfterExplodeArr
    Dim GetMinMaxPoint As Variant
    GetMinMaxPoint = HCF4161_MinPointMaxPointOfObjArr(AfterExplodeArr, ObjLayerName, True)
    If VarType(GetMinMaxPoint) = vbBoolean Then
        Exit Function
    Else
        HCF4160_LimitPointOfBlockRef = GetMinMaxPoint
    End If
End Function
Function HCF4161_MinPointMaxPointOfObjArr(ObjArr As Variant, ObjLayerName As String, DeleteMode As Boolean) As Variant
'Result(MinPoint,MaxPoint) or Result=False
    HCF4161_MinPointMaxPointOfObjArr = False
'Check Input
    If Func70IsEmptyArray(ObjArr) = True Then Exit Function
'Define MinX,MaxX,MinY,MaxY
    Dim MinPoint As Variant
    Dim MaxPoint As Variant
    Dim MinX As Double
    Dim MaxX As Double
    Dim MinY As Double
    Dim MaxY  As Double
'Set gia tri ban dau cho MinX,MaxX,MinY,MaxY
    Dim EachEntity As AcadEntity
    For i = LBound(ObjArr) To UBound(ObjArr)
        Set EachEntity = ObjArr(i)
        If EachEntity.Layer = ObjLayerName Or EachEntity.Layer = "0" Then
            EachEntity.GetBoundingBox MinPoint, MaxPoint
            MinX = MinPoint(0)
            MinY = MinPoint(1)
            MaxX = MaxPoint(0)
            MaxY = MaxPoint(1)
            GoTo GoToNextStep
        End If
    Next
GoToNextStep:
'Define MinX,MaxX,MinY,MaxY
    For i = LBound(ObjArr) To UBound(ObjArr)
        Set EachEntity = ObjArr(i)
        If EachEntity.Layer = ObjLayerName Or EachEntity.Layer = "0" Then
            EachEntity.GetBoundingBox MinPoint, MaxPoint
            If MinX > MinPoint(0) Then MinX = MinPoint(0)
            If MinY > MinPoint(1) Then MinY = MinPoint(1)
            If MaxX < MaxPoint(0) Then MaxX = MaxPoint(0)
            If MaxY < MaxPoint(1) Then MaxY = MaxPoint(1)
        End If
    Next
'Define SSMinPoint,SSMaxPoint,SSCenterPoint
    Dim Result(0 To 1) As Variant
    Dim SSMinPoint(0 To 2) As Double
    Dim SSMaxPoint(0 To 2) As Double
    SSMinPoint(0) = MinX
    SSMinPoint(1) = MinY
    SSMaxPoint(0) = MaxX
    SSMaxPoint(1) = MaxY
    Result(0) = SSMinPoint
    Result(1) = SSMaxPoint
    HCF4161_MinPointMaxPointOfObjArr = Result
'DeleteMode
    If DeleteMode = True Then
        For i = LBound(ObjArr) To UBound(ObjArr)
            Set EachEntity = ObjArr(i)
            EachEntity.Delete
        Next
    End If
End Function

Function HCF4162_Get2PointWithOSMODE(MsgPoint1 As String, MsgPoint2 As String, OsmodePoint1 As Integer, OsmodePoint2 As Integer, LinePoint12Mode As Boolean) As Variant
'Result(Point1,Point2) or Result=False
    HCF4162_Get2PointWithOSMODE = False
    Dim Result(0 To 1) As Variant
    Dim Point1 As Variant
    Dim Point2 As Variant
'Backup OSMODE
    Dim BackupOsnap As Variant: BackupOsnap = HCF4113_SettingOsnap("Backup", "")
'Get Point1
    Call HCF4113_SettingOsnap("Restore", OsmodePoint1)
    Point1 = HCF4045_GetPoint(Thisdrawing, MsgPoint1)
    If Func70IsEmptyArray(Point1) = True Then GoTo GoToExitFunc
'Select Point2 to DefineDirection
    Call HCF4113_SettingOsnap("Restore", OsmodePoint2)
    If LinePoint12Mode = True Then
        'Set ucs is world
        Call HCF4163_Call_SetUCSIsWorld
        Point2 = HCF4106_GetSecondPoint(Thisdrawing, Point1, MsgPoint2)
    Else
        Point2 = HCF4045_GetPoint(Thisdrawing, MsgPoint2)
    End If
    If Func70IsEmptyArray(Point2) = True Then GoTo GoToExitFunc
'Result
    Result(0) = Point1
    Result(1) = Point2
    HCF4162_Get2PointWithOSMODE = Result
GoToExitFunc:
    Call HCF4113_SettingOsnap("Restore", BackupOsnap)
End Function

Function HCF4163_Call_SetUCSIsWorld()
    Thisdrawing.SendCommand "UCS" & vbCr & "W" & vbCr
End Function
Function HCF4164_Call_MinPointMaxPointFrom2Point(MinPoint As Variant, MaxPoint As Variant)
    Dim MinX As Double
    Dim MaxX As Double
    Dim MinY As Double
    Dim MaxY As Double
    Dim TmpDouble As Double
    MinX = MinPoint(0)
    MinY = MinPoint(1)
    MaxX = MaxPoint(0)
    MaxY = MaxPoint(1)
    If MaxX < MinX Then
        TmpDouble = MaxX
        MaxX = MinX
        MinX = TmpDouble
    End If
    If MaxY < MinY Then
        TmpDouble = MaxY
        MaxY = MinY
        MinY = TmpDouble
    End If
'Result
    MinPoint(0) = MinX
    MinPoint(1) = MinY
    MaxPoint(0) = MaxX
    MaxPoint(1) = MaxY
End Function
Function HCF4165_DimPositionWithMinMaxPoint(ObjDim As AcadDimension, MinPoint As Variant, MaxPoint As Variant) As String
'Function xac nhan vi tri cua Ordinate Dim so voi MinPoint va MaxPoint
Dim DimDirection As String
'Define MinMaxXY
    Dim MinX As Double
    Dim MaxX As Double
    Dim MinY As Double
    Dim MaxY As Double
    MinX = MinPoint(0)
    MaxX = MaxPoint(0)
    MinY = MinPoint(1)
    MaxY = MaxPoint(1)
'TextPosition
    Dim TextPoint As Variant
    Dim TextPointX As Double
    Dim TextPointY As Double
    TextPoint = ObjDim.TextPosition
    TextPointX = TextPoint(0)
    TextPointY = TextPoint(1)
'DeltaMinMax
    Dim DeltaMinX As Double
    Dim DeltaMaxX As Double
    Dim DeltaMinY As Double
    Dim DeltaMaxY As Double
    DeltaMinX = TextPointX - MinX
    DeltaMaxX = TextPointX - MaxX
    DeltaMinY = TextPointY - MinY
    DeltaMaxY = TextPointY - MaxY
'IN
    If DeltaMinX >= 0 And DeltaMaxX <= 0 And DeltaMinY >= 0 And DeltaMaxY <= 0 Then
        HCF4165_DimPositionWithMinMaxPoint = "IN"
        Exit Function
    End If
'LEFT
    If DeltaMinX < 0 And DeltaMinY > 0 And DeltaMaxY < 0 Then
        HCF4165_DimPositionWithMinMaxPoint = "LEFT"
        Exit Function
    End If
'RIGHT
    If DeltaMaxX > 0 And DeltaMinY > 0 And DeltaMaxY < 0 Then
        HCF4165_DimPositionWithMinMaxPoint = "RIGHT"
        Exit Function
    End If
'UP
    If DeltaMaxY > 0 And DeltaMinX > 0 And DeltaMaxX < 0 Then
        HCF4165_DimPositionWithMinMaxPoint = "UP"
        Exit Function
    End If
'DOWN
    If DeltaMinY < 0 And DeltaMinX > 0 And DeltaMaxX < 0 Then
        HCF4165_DimPositionWithMinMaxPoint = "DOWN"
        Exit Function
    End If
    HCF4165_DimPositionWithMinMaxPoint = "N/A"
End Function


Function HCF4166X_ArrangeDimArr(ObjDimArr() As AcadDimension, LeftRightUpDown As String, MinPoint As Variant, MaxPoint As Variant, DeltaDimSpace As Double, DimSpace0 As Integer, DimSpace1 As Integer)
'Define Angle From Point1 to Point2 and MainPoint
    Dim Pi As Double: Pi = 4 * Atn(1)
    Dim Point12Angle As Double
    Dim MainPoint As Variant
    Select Case LeftRightUpDown
        Case "LEFT"
            Point12Angle = Pi
            MainPoint = MinPoint
        Case "RIGHT"
            Point12Angle = 0
            MainPoint = MaxPoint
        Case "UP"
            Point12Angle = Pi / 2
            MainPoint = MaxPoint
        Case "DOWN"
            Point12Angle = 3 * Pi / 2
            MainPoint = MinPoint
        Case Else
            Exit Function
    End Select
'Define Distance From DimTextPoint to Point1 With Angle
    Dim DistanceDimTextPoint() As Double
    Dim EachDim As AcadDimension
    Dim EachDimTextPosition As Variant
    Dim EachDistance As Double
    Dim IsInList As Boolean
    For i = LBound(ObjDimArr) To UBound(ObjDimArr)
        Set EachDim = ObjDimArr(i)
        IsInList = False
        EachDimTextPosition = EachDim.TextPosition
        EachDistance = HCF4156_DistanceFromPoint2ToPoint1WithAngle(MainPoint, EachDimTextPosition, Point12Angle, 0)
        If k = 0 Then
            ReDim Preserve DistanceDimTextPoint(0 To k)
            DistanceDimTextPoint(k) = EachDistance
            k = k + 1
        Else
            IsInList = HCF4157_IsInArr1ChieuWithDelta_Number(DistanceDimTextPoint, EachDistance, DeltaDimSpace)
            If IsInList = False Then
                ReDim Preserve DistanceDimTextPoint(0 To k)
                DistanceDimTextPoint(k) = EachDistance
                k = k + 1
            End If
        End If
    Next
'Sort DistanceDimTextPoint() A to Z
    DistanceDimTextPoint = HCF4057_SortArrAtoZ_NumberType(DistanceDimTextPoint)
'Arrange Dim
    Dim GetEachClassNo As Variant
    Dim EachClassNo As Integer
    Dim EachMoveSpace As Double
    Dim NewTextPositon As Variant
    For i = LBound(ObjDimArr) To UBound(ObjDimArr)
        Set EachDim = ObjDimArr(i)
        EachDimTextPosition = EachDim.TextPosition
        EachDistance = HCF4156_DistanceFromPoint2ToPoint1WithAngle(MainPoint, EachDimTextPosition, Point12Angle, 0)
        GetEachClassNo = HCF4158_DefinePositionInArr1ChieuWithDelta_Number(DistanceDimTextPoint, EachDistance, DeltaDimSpace)
        If VarType(GetEachClassNo) <> vbBoolean Then
            EachClassNo = GetEachClassNo
            EachMoveSpace = DimSpace0 + EachClassNo * DimSpace1
            NewTextPositon = Thisdrawing.Utility.PolarPoint(MainPoint, Point12Angle, EachMoveSpace)
            EachDim.TextPosition = NewTextPositon
            EachDim.Update
        End If
    Next
End Function
Function HCF4167_Call_QuickCreatBlock_ModelSpace(MyDrawing As AcadDocument, ModelSpaceBlock As AcadBlock)
'Creat Array of obj
    Dim EntityCount As Integer: EntityCount = MyDrawing.ModelSpace.Count
    If EntityCount = 0 Then Exit Function
    Dim ObjArr() As Object
    Dim k As Integer
    Dim EachEntity As AcadEntity
    For Each EachEntity In MyDrawing.ModelSpace
        ReDim Preserve ObjArr(0 To k)
        Set ObjArr(k) = EachEntity
        k = k + 1
    Next
'Automatic Creat Blockname
    Dim Blockname As String
    Blockname = HCF4046_AutomaticCreatBlockname()
'Creat Block
    Dim InsertPoint(0 To 2) As Double
    Set ModelSpaceBlock = MyDrawing.Blocks.Add(InsertPoint, Blockname)
    MyDrawing.CopyObjects ObjArr, ModelSpaceBlock
'Delete Old Entity
    For Each EachEntity In MyDrawing.ModelSpace
        EachEntity.Delete
    Next
End Function




Sub HCS3083_QuickCreatBlockRef()
'(VBA AutoCad) Quick Creat Block,[QCB]
'Select Obj by SelectSet
    Dim EntitySelect As AcadSelectionSet
    Dim EachEntity As AcadEntity
    Set EntitySelect = Thisdrawing.SelectionSets.Add("EntitySelect" & Now)
    Thisdrawing.Utility.Prompt (vbCr & "Select objects to make block")
    EntitySelect.SelectOnScreen
    If EntitySelect.Count = 0 Then
        EntitySelect.Delete
        Exit Sub
    End If
'Select InsertPoint
    Dim InsertPoint As Variant
    Dim Point00(0 To 2) As Double
    InsertPoint = HCF4045_GetPoint(Thisdrawing, "Pick Insertion Point: ")
    If Func70IsEmptyArray(InsertPoint) = True Then
        EntitySelect.Delete
        Exit Sub
    End If
'Creat Array of obj
    ReDim ObjArr(0 To EntitySelect.Count - 1) As Object
    For Each EachEntity In EntitySelect
       EachEntity.Move InsertPoint, Point00
       Set ObjArr(i) = EachEntity
       i = i + 1
    Next
'Automatic Creat Blockname
    Dim Blockname As String
    Blockname = HCF4046_AutomaticCreatBlockname()
'Creat Block
    Dim ObjBlock As AcadBlock
    Set ObjBlock = Thisdrawing.Blocks.Add(Point00, Blockname)
    Thisdrawing.CopyObjects ObjArr, ObjBlock
'Insert New Block
    Dim ObjBlockRef As AcadBlockReference
    Set ObjBlockRef = Thisdrawing.ModelSpace.InsertBlock(InsertPoint, Blockname, 1, 1, 1, 0)

'Delete Old Entity
    For Each EachEntity In EntitySelect
        EachEntity.Delete
    Next
    EntitySelect.Delete
End Sub
Sub HCS3124_QuickCreatSpline()
'(TB VBABoss) Quick Creat Spline,[QCSP]
'AddSpline(PointsArray, StartTangent, EndTangent) As AcadSpline

'Setting Spline Layer
    Dim SplineLayername As String
    Select Case ProjectName
        Case "DFK"
            SplineLayername = DFK_PhantomLayerName
        Case "KKS"
            SplineLayername = KKS_SlimLayerName
        Case Else
            SplineLayername = "0"
    End Select
'Othor On
    Thisdrawing.SetVariable "ORTHOMODE", 1
'Backup OSMODE
    Dim BackupOsnap As Variant: BackupOsnap = HCF4113_SettingOsnap("Backup", "")
'Setting be rong Spline
    Dim DimScale As Variant: DimScale = Thisdrawing.GetVariable("DIMSCALE")
    Dim SplineWide As Double: SplineWide = 5 * DimScale
'Get Point1 of Spline, Z=0
    Dim Point1 As Variant
    Call HCF4113_SettingOsnap("Restore", 513)    'EndPoint or Nearest
    Point1 = HCF4045_GetPoint(Thisdrawing, "Select Start Point of Spline:")
    If Func70IsEmptyArray(Point1) = True Then
        GoTo GoToExitSub
    Else
        Point1(2) = 0
    End If
'Get Point2 of Spline
    Dim Point2 As Variant
    Call HCF4113_SettingOsnap("Restore", 129)    'EndPoint or Perpendicular
    Point2 = HCF4106_GetSecondPoint(Thisdrawing, Point1, "Select End Point of Spline:")
    If Func70IsEmptyArray(Point2) = True Then
        GoTo GoToExitSub
    Else
        Point2(2) = 0
    End If
'Define Angle From Point 1 to Point 2
    Dim Point12Angle As Double: Point12Angle = Func23AngleOfLineThrough2Point(Point1, Point2)
    Dim Pi As Double: Pi = 4 * Atn(1)
'Define Point3 is center of Point1 and Point2
    Dim Point3 As Variant
    Point3 = HCF4102_Middle2Point(Point1, Point2)
'Define Point4 is center of Point1 & Point3 With SplineWide
    Dim Point4 As Variant
    Point4 = HCF4102_Middle2Point(Point1, Point3)
    Point4 = Thisdrawing.Utility.PolarPoint(Point4, Point12Angle + Pi / 2, SplineWide)
'Define Point5 is center of Point2 and Point3 with SplineWide
    Dim Point5 As Variant
    Point5 = HCF4102_Middle2Point(Point2, Point3)
    Point5 = Thisdrawing.Utility.PolarPoint(Point5, Point12Angle + Pi / 2, -SplineWide)
'Creat PointsArray of Spline
    Dim PointsArray(0 To 11) As Double
    PointsArray(0) = Point1(0):     PointsArray(1) = Point1(1):     PointsArray(2) = 0
    PointsArray(3) = Point4(0):     PointsArray(4) = Point4(1):     PointsArray(5) = 0
    PointsArray(6) = Point5(0):     PointsArray(7) = Point5(1):    PointsArray(8) = 0
    PointsArray(9) = Point2(0):    PointsArray(10) = Point2(1):    PointsArray(11) = 0
'Set StartTangent, EndTangent
    Dim startTan(0 To 2) As Double
    Dim endTan(0 To 2) As Double
'    startTan(0) = 0.5:  startTan(1) = 0.5:  startTan(2) = 0
'    endTan(0) = 0.5:    endTan(1) = 0.5:    endTan(2) = 0
'Add Spline
    Dim ObjSpline As AcadSpline
    Set ObjSpline = Thisdrawing.ModelSpace.AddSpline(PointsArray, startTan, endTan)
    ObjSpline.Layer = SplineLayername
    Thisdrawing.Regen acActiveViewport
GoToExitSub:
    Call HCF4113_SettingOsnap("Restore", BackupOsnap)
End Sub
Sub HCS3125_DimArrange4Direction()
'(TB VBABoss) Dim Arrange 4 Direction Type,[DD4]
'System Setting
    'Get DimScale
        Dim DimScale As Variant: DimScale = Thisdrawing.GetVariable("DIMSCALE")
    'DeltaDimSpace
        Dim DeltaDimSpace As Double: DeltaDimSpace = 2 * DimScale
'Define DimSpace1,DimSpace2
    Dim DimSpace0 As Integer: DimSpace0 = SettingDimSpace0
    Dim DimSpace1 As Integer: DimSpace1 = SettingDimSpace1
    DimSpace0 = DimScale * DimSpace0
    DimSpace1 = DimScale * DimSpace1
'Select DimSelectSet
    Dim DimSelectSet As AcadSelectionSet
    Set DimSelectSet = Thisdrawing.SelectionSets.Add("DimSelectSet" & Now)
    Dim FT(0) As Integer
    Dim FD(0) As Variant
    FT(0) = 0:  FD(0) = "DIMENSION"
    Thisdrawing.Utility.Prompt (vbCrLf & "Select Dimensions to Arrangement:" & vbCr)
    DimSelectSet.SelectOnScreen FT, FD
'Filter Only RotatedDim
    Call HCF4159_Call_FilterOnlyRotatedDimInDimSelectSet(DimSelectSet)
    If DimSelectSet.Count = 0 Then GoTo GoToExitSub
'Define MinPoint,MaxPoint From Selected ObjBlockRef
    Dim GetObj() As Variant
    Dim Obj As AcadEntity
    Dim ObjBlockRef As AcadBlockReference
    Dim GetMinMaxPoint As Variant
    Dim MinPoint As Variant
    Dim MaxPoint As Variant
    GetObj = HCF4059_GetObj(Thisdrawing, "Select Obj to define MinPoint and MaxPoint For Arrange Dimension:")
    If GetObj(0) = False Then
        GoTo GoToSelect2Point
    Else
        Set Obj = GetObj(1)
        If Obj.ObjectName = "AcDbBlockReference" Then
            Set ObjBlockRef = Obj
            GetMinMaxPoint = HCF4160_LimitPointOfBlockRef(ObjBlockRef)
            If VarType(GetMinMaxPoint) = vbBoolean Then
               GoTo GoToSelect2Point
            Else
                MinPoint = GetMinMaxPoint(0)
                MaxPoint = GetMinMaxPoint(1)
                GoTo GoToAfterSelect2Point
            End If
        Else
            GoTo GoToSelect2Point
        End If
    End If
'''==============================='''
GoToSelect2Point:
    Dim Get2Point As Variant
    Dim MsgPoint1 As String: MsgPoint1 = "Select MinPoint for Arrange Dimension:"
    Dim MsgPoint2 As String: MsgPoint2 = "Select MaxPoint for Arrange Dimension:"
    Dim OsmodePoint1 As Integer: OsmodePoint1 = 97
    Dim OsmodePoint2 As Integer: OsmodePoint2 = 97
    Get2Point = HCF4162_Get2PointWithOSMODE(MsgPoint1, MsgPoint2, OsmodePoint1, OsmodePoint2, True)
    If VarType(Get2Point) = vbBoolean Then
        GoTo GoToExitSub
    Else
        MinPoint = Get2Point(0)
        MaxPoint = Get2Point(1)
    End If
GoToAfterSelect2Point:
'Confirm MinPoint, MaxPoint
    Call HCF4164_Call_MinPointMaxPointFrom2Point(MinPoint, MaxPoint)
'Reset HomeText All Dim In SelectSet
    Call HCF4146_Call_ResetHomeTextOfDimSelectSet(DimSelectSet)
'Define LeftArr,RightArr,UpArr,DownArr
    Dim LeftArr() As AcadDimension
    Dim RightArr() As AcadDimension
    Dim UpArr() As AcadDimension
    Dim DownArr() As AcadDimension
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim f As Integer
    Dim EachDimDirection As String
    Dim EachDim As AcadDimension
    Dim GetProperty As Variant
    For Each EachDim In DimSelectSet
        EachDimDirection = HCF4165_DimPositionWithMinMaxPoint(EachDim, MinPoint, MaxPoint)
        If EachDimDirection = "N/A" Then
            GetProperty = HCF4143_GetProperty_RotatedDim_AlignedDim(EachDim, "")
            EachDimDirection = GetProperty(7)
        End If
        Select Case EachDimDirection
            Case "LEFT"
                ReDim Preserve LeftArr(0 To i)
                Set LeftArr(i) = EachDim
                i = i + 1
            Case "RIGHT"
                ReDim Preserve RightArr(0 To j)
                Set RightArr(j) = EachDim
                j = j + 1
            Case "UP"
                ReDim Preserve UpArr(0 To k)
                Set UpArr(k) = EachDim
                k = k + 1
            Case "DOWN"
                ReDim Preserve DownArr(0 To f)
                Set DownArr(f) = EachDim
                f = f + 1
        End Select
    Next
'Arrange Dim
    If i > 0 Then Call HCF4166X_ArrangeDimArr(LeftArr, "LEFT", MinPoint, MaxPoint, DeltaDimSpace, DimSpace0, DimSpace1)
    If j > 0 Then Call HCF4166X_ArrangeDimArr(RightArr, "RIGHT", MinPoint, MaxPoint, DeltaDimSpace, DimSpace0, DimSpace1)
    If k > 0 Then Call HCF4166X_ArrangeDimArr(UpArr, "UP", MinPoint, MaxPoint, DeltaDimSpace, DimSpace0, DimSpace1)
    If f > 0 Then Call HCF4166X_ArrangeDimArr(DownArr, "DOWN", MinPoint, MaxPoint, DeltaDimSpace, DimSpace0, DimSpace1)
'Reset TextDimPosition
    Call HCF4146_Call_ResetHomeTextOfDimSelectSet(DimSelectSet)
GoToExitSub:
    DimSelectSet.Delete
    Call HCF4153_Call_ResetCommandLine("DD4")
End Sub
Sub HCS3126_UpdateSelectedBlockFromOtherDrawing_Version2()
'(VBA AutoCad) Update Selected Block From Other Drawing,[UB2]
'Creat Opening File List
    If AcadApplication.Documents.Count = 1 Then Exit Sub
    Dim EachDocument As AcadDocument
    For Each EachDocument In AcadApplication.Documents
        ReDim Preserve OpeningFileArr(0 To k)
        OpeningFileArr(k) = EachDocument.Name
        k = k + 1
    Next
'Select UpdateFrom, UpdateTo By Userform
    UpdateBlockV2.show
    If UB_UpdateFromDrawing = "" Or UB_UpdateToDrawing = "" Then
        Exit Sub
    Else
        If UB_UpdateFromDrawing = UB_UpdateToDrawing Then
            MsgBox "Err: CopyFromDrawing = CopyToDrawing"
            Exit Sub
        End If
    End If
    Dim UpdateFrom As AcadDocument
    Dim UpdateTo As AcadDocument
    For Each EachDocument In AcadApplication.Documents
        Select Case EachDocument.Name
            Case UB_UpdateFromDrawing
                Set UpdateFrom = EachDocument
            Case UB_UpdateToDrawing
                Set UpdateTo = EachDocument
        End Select
    Next
'Creat BlockModelSpace of UpdateToDrawing
    Dim UBTModelSpaceBlock As AcadBlock
    Call HCF4167_Call_QuickCreatBlock_ModelSpace(UpdateTo, UBTModelSpaceBlock)
    If UBTModelSpaceBlock Is Nothing Then Exit Sub
    Dim UBTBlockname As String
    UBTBlockname = UBTModelSpaceBlock.Name
'Purge UpdateFrom
    Call HCF4040_PurgeMydrawing(UpdateFrom)
'Copy UBTModelSpaceBlock to UpdateFrom
    Dim ObjArr(0) As Object
    Set ObjArr(0) = UBTModelSpaceBlock
    UpdateTo.CopyObjects ObjArr, UpdateFrom.ModelSpace
'Purge UpdateTo
    Call HCF4040_PurgeMydrawing(UpdateTo)
'Copy ModelBlock From UpdateFrom To UpdateTo
    Dim EachBlock As AcadBlock
    For Each EachBlock In UpdateFrom.Blocks
        If EachBlock.Name = UBTBlockname Then
            Set ObjArr(0) = EachBlock
        End If
    Next
    UpdateFrom.CopyObjects ObjArr, UpdateTo.ModelSpace
'Insert UBTModelSpaceBlock
    Dim ObjBlockRef As AcadBlockReference
    Dim InsertPoint(0 To 2) As Double
    Set ObjBlockRef = UpdateTo.ModelSpace.InsertBlock(InsertPoint, UBTBlockname, 1, 1, 1, 0)
    ObjBlockRef.Explode
    ObjBlockRef.Delete
'Purge
    Call HCF4040_PurgeMydrawing(UpdateTo)
    Call HCF4040_PurgeMydrawing(UpdateFrom)
End Sub
Sub HCS3127_AddEntityIntoBlockRef()
'(TB VBABoss) Add Entity Into BlockRef,[AE2B]
'Select Entity
    Dim EntitySS As AcadSelectionSet
    Set EntitySS = Thisdrawing.SelectionSets.Add("EntitySS" & Now)
    Thisdrawing.Utility.Prompt vbCrLf & "Select Entity for Add to Block Reference:"
    EntitySS.SelectOnScreen
    If EntitySS.Count = 0 Then
        EntitySS.Delete
        Exit Sub
    End If
'Select BlockRef
    Dim BlockRefSS As AcadSelectionSet
    Set BlockRefSS = Thisdrawing.SelectionSets.Add("BlockRefSS" & Now)
    Dim FT(0) As Integer
    Dim FD(0) As Variant
    FT(0) = 0:  FD(0) = "INSERT"
    Thisdrawing.Utility.Prompt vbCrLf & "Select Block Reference:"
    BlockRefSS.SelectOnScreen FT, FD
    If BlockRefSS.Count <> 1 Then GoTo GoToExitSub
'Define ObjBlock, ObjBlockRef
    Dim ObjBlockRef As AcadBlockReference
    Dim ObjBlock As AcadBlock
    Dim BlockInsertPoint As Variant
    Dim BlockRefScale As Double
    Set ObjBlockRef = BlockRefSS.Item(0)
    BlockRefScale = ObjBlockRef.XScaleFactor
'Check Condition of ObjBlockRef
    If Func64IsNormalBlock(ObjBlockRef) = False Then
        MsgBox "Err:Selected Block Reference Isn't Normal Block Reference."
        GoTo GoToExitSub
    End If
    If BlockRefScale <> 1 Then
        MsgBox "Err:Selected Block Reference Scale <>1."
        GoTo GoToExitSub
    End If
    Set ObjBlock = Thisdrawing.Blocks(ObjBlockRef.Name)
    BlockInsertPoint = ObjBlockRef.InsertionPoint
'Remove ObjBlockRef In EntitySS
    Dim RemoveArr() As AcadEntity
    Dim EachEntity As AcadEntity
    Dim m As Integer
    For Each EachEntity In EntitySS
        If EachEntity.Handle = ObjBlockRef.Handle Then
            ReDim Preserve RemoveArr(0 To m)
            Set RemoveArr(m) = EachEntity
            m = m + 1
        End If
    Next
    If m > 0 Then
        EntitySS.RemoveItems RemoveArr
    End If
    If EntitySS.Count = 0 Then
        MsgBox "Err: Can not add block 2 block."
        GoTo GoToExitSub
    End If
'Get CopyFromPoint, CopyToPoint
    Dim Get2Point As Variant
    Dim MsgPoint1 As String: MsgPoint1 = "Select Copy From Point:"
    Dim MsgPoint2 As String: MsgPoint2 = "Select Copy To Point:"
    Dim OsmodePoint1 As Integer: OsmodePoint1 = 16383
    Dim OsmodePoint2 As Integer: OsmodePoint2 = 16383
    Get2Point = HCF4162_Get2PointWithOSMODE(MsgPoint1, MsgPoint2, OsmodePoint1, OsmodePoint2, True)
    Dim CopyFromPoint As Variant
    Dim CopyToPoint As Variant
    If VarType(Get2Point) = vbBoolean Then
        GoTo GoToExitSub
    Else
        CopyFromPoint = Get2Point(0)
        CopyToPoint = Get2Point(1)
    End If
'Creat CopyObjArr
    Dim CopyObjArr() As Object
    Dim EachEntityCopy As AcadEntity
    Dim Point00(0 To 2) As Double
    For Each EachEntity In EntitySS
        Set EachEntityCopy = EachEntity.Copy
        EachEntityCopy.Move BlockInsertPoint, Point00
        EachEntityCopy.Move CopyFromPoint, CopyToPoint
        ReDim Preserve CopyObjArr(0 To k)
        Set CopyObjArr(k) = EachEntityCopy
        k = k + 1
    Next
'Copy CopyObjArr to ObjBlock
    Thisdrawing.CopyObjects CopyObjArr, ObjBlock
    ObjBlockRef.Update
'Delect CopyObjArr
    For i = LBound(CopyObjArr) To UBound(CopyObjArr)
        Set EachEntity = CopyObjArr(i)
        EachEntity.Delete
    Next
GoToExitSub:
    EntitySS.Delete
    BlockRefSS.Delete
End Sub
Sub HCS3128_ReplaceBlockByBlock()
'(TB VBABoss) Replace Block By Block,[RBBB]
'Select ReplaceBlockFrom
    Dim BlockRefSS As AcadSelectionSet
    Set BlockRefSS = Thisdrawing.SelectionSets.Add("BlockRefSS" & Now)
    Dim FT(0) As Integer
    Dim FD(0) As Variant
    FT(0) = 0:  FD(0) = "INSERT"
    Thisdrawing.Utility.Prompt vbCrLf & "Select ReplaceBlockFrom:"
    BlockRefSS.SelectOnScreen FT, FD
    If BlockRefSS.Count <> 1 Then GoTo GoToExitSub
    Dim ReplaceBlockFromRef As AcadBlockReference
    Set ReplaceBlockFromRef = BlockRefSS.Item(0)
    If Func64IsNormalBlock(ReplaceBlockFromRef) = False Then
        MsgBox "Err:Selected Block Reference Isn't Normal Block Reference."
        GoTo GoToExitSub
    End If
    Dim ReplaceBlockFrom_Scale As Double:           ReplaceBlockFrom_Scale = ReplaceBlockFromRef.XScaleFactor
    If ReplaceBlockFrom_Scale <> 1 Then
        MsgBox "Err:Selected Block Reference Scale <>1."
        GoTo GoToExitSub
    End If
    Dim ReplaceBlockFrom As AcadBlock:              Set ReplaceBlockFrom = Thisdrawing.Blocks(ReplaceBlockFromRef.Name)
    Dim ReplaceBlockFrom_InsertPoint As Variant:    ReplaceBlockFrom_InsertPoint = ReplaceBlockFromRef.InsertionPoint
'Select ReplaceBlockTo
    BlockRefSS.Clear
    Thisdrawing.Utility.Prompt vbCrLf & "Select ReplaceBlockTo:"
    BlockRefSS.SelectOnScreen FT, FD
    If BlockRefSS.Count <> 1 Then GoTo GoToExitSub
    Dim ReplaceBlockToRef As AcadBlockReference:    Set ReplaceBlockToRef = BlockRefSS.Item(0)
    If Func64IsNormalBlock(ReplaceBlockToRef) = False Then
        MsgBox "Err:Selected Block Reference Isn't Normal Block Reference."
        GoTo GoToExitSub
    End If
    Dim ReplaceBlockTo_Scale As Double:     ReplaceBlockTo_Scale = ReplaceBlockToRef.XScaleFactor
    If ReplaceBlockTo_Scale <> 1 Then
        MsgBox "Err:Selected Block Reference Scale <>1."
        GoTo GoToExitSub
    End If
    Dim ReplaceBlockTo As AcadBlock:              Set ReplaceBlockTo = Thisdrawing.Blocks(ReplaceBlockToRef.Name)
    Dim ReplaceBlockTo_InsertPoint As Variant:    ReplaceBlockTo_InsertPoint = ReplaceBlockToRef.InsertionPoint
'Check ReplaceBlockFromRef=ReplaceBlockToRef
    If ReplaceBlockFromRef.Name = ReplaceBlockTo.Name Then
        MsgBox "Err: ReplaceBlockFromRef.Name = ReplaceBlockTo.Name"
        GoTo GoToExitSub
    End If
'Get ReplaceFromPoint, ReplaceToPoint
    Dim Get2Point As Variant
    Dim MsgPoint1 As String: MsgPoint1 = "Select Replace From Point:"
    Dim MsgPoint2 As String: MsgPoint2 = "Select Replace To Point:"
    Dim OsmodePoint1 As Integer: OsmodePoint1 = 16383
    Dim OsmodePoint2 As Integer: OsmodePoint2 = 16383
    Get2Point = HCF4162_Get2PointWithOSMODE(MsgPoint1, MsgPoint2, OsmodePoint1, OsmodePoint2, True)
    Dim ReplaceFromPoint As Variant
    Dim ReplaceToPoint As Variant
    If VarType(Get2Point) = vbBoolean Then
        GoTo GoToExitSub
    Else
        ReplaceFromPoint = Get2Point(0)
        ReplaceToPoint = Get2Point(1)
    End If
'Delete All Entity in ReplaceToBlock
    Dim EachEntity As AcadEntity
    For Each EachEntity In ReplaceBlockTo
        EachEntity.Delete
    Next
'Explode ReplaceBlockFromRef
    Dim ExplodeArr As Variant
    ExplodeArr = ReplaceBlockFromRef.Explode
    
'Creat CopyObjArr
    Dim CopyObjArr() As Object
    Dim Point00(0 To 2) As Double
    For i = LBound(ExplodeArr) To UBound(ExplodeArr)
        Set EachEntity = ExplodeArr(i)
        EachEntity.Move ReplaceBlockTo_InsertPoint, Point00
        EachEntity.Move ReplaceFromPoint, ReplaceToPoint
        ReDim Preserve CopyObjArr(0 To k)
        Set CopyObjArr(k) = EachEntity
        k = k + 1
    Next
'Copy CopyObjArr to ReplaceBlockFrom
    Thisdrawing.CopyObjects CopyObjArr, ReplaceBlockTo
    ReplaceBlockToRef.Update
'Delect CopyObjArr,ExplodeArr
    For i = LBound(CopyObjArr) To UBound(CopyObjArr)
        Set EachEntity = CopyObjArr(i)
        EachEntity.Delete
    Next
GoToExitSub:
    BlockRefSS.Delete
End Sub