Announcements
Attention for Customers without Multi-Factor Authentication or Single Sign-On - OTP Verification rolls out April 2025. Read all about it here.
buianhtuan.cdt
in reply to: Anonymous

Function HCF4156_DistanceFromPoint2ToPoint1WithAngle(Point1 As Variant, Point2 As Variant, DblAngle As Double, RoundNumber As Integer) As Double
    Dim Pi As Double: Pi = 4 * Atn(1)
'Xac dinh goc vuong goc voi DblAngle
    Dim AngleXPoint1 As Double: AngleXPoint1 = DblAngle + Pi / 2
'Angle And Distance From Point1 to Point2
    Dim AnglePoint12 As Double
    Dim DistancePoint12 As Double
    AnglePoint12 = Func23AngleOfLineThrough2Point(Point1, Point2)
    DistancePoint12 = Func20LengthLineThrough2Point(Point1, Point2)
'Define Distance From Point2 to Point1 With Angle
    Dim SinAngle As Double
    Dim DistancePoint2ToPoint1WithAngle As Double
    SinAngle = AnglePoint12 - AngleXPoint1
    DistancePoint2ToPoint1WithAngle = Abs(DistancePoint12 * Sin(SinAngle))
    If RoundNumber <> 100 Then
        DistancePoint2ToPoint1WithAngle = Round(DistancePoint2ToPoint1WithAngle, RoundNumber)
    End If
    HCF4156_DistanceFromPoint2ToPoint1WithAngle = DistancePoint2ToPoint1WithAngle
End Function
Function HCF4157_IsInArr1ChieuWithDelta_Number(ListArr As Variant, NeedCheckValue As Double, Delta As Double) As Boolean
    Dim CompareValue As Variant
    For i = LBound(ListArr) To UBound(ListArr)
        CompareValue = ListArr(i)
        CompareValue = CDbl(CompareValue)
        If Abs(CompareValue - NeedCheckValue) <= Delta Then
            HCF4157_IsInArr1ChieuWithDelta_Number = True
            Exit Function
        End If
    Next
End Function
Function HCF4158_DefinePositionInArr1ChieuWithDelta_Number(ListArr As Variant, NeedCheckValue As Double, Delta As Double) As Variant
'Defaut Value
    HCF4158_DefinePositionInArr1ChieuWithDelta_Number = False
'Process
    Dim CompareValue As Variant
    For i = LBound(ListArr) To UBound(ListArr)
        CompareValue = ListArr(i)
        CompareValue = CDbl(CompareValue)
        If Abs(CompareValue - NeedCheckValue) <= Delta Then
            HCF4158_DefinePositionInArr1ChieuWithDelta_Number = i
            Exit Function
        End If
    Next
End Function
Sub HCS3122_HoanDoiViTri2LopKichThuoc()
'(TB VBABoss) Hoan Doi Vi Tri 2Lop Kich Thuoc,[D12]
'Chon Lop Kich Thuoc 1
    Thisdrawing.Utility.Prompt (vbCrLf & "Select Dimensions(Class1):" & vbCr)
    Dim Class1 As AcadSelectionSet
    Set Class1 = Thisdrawing.SelectionSets.Add("Class1" & Now)
    Dim FT(0) As Integer
    Dim FD(0) As Variant
    FT(0) = 0:  FD(0) = "DIMENSION"
    Class1.SelectOnScreen FT, FD
    Call HCF4151_Call_FilterOnlyLinearDimInDimSelectSet(Class1)
    If Class1.Count = 0 Then
        Class1.Delete
        Exit Sub
    End If
'Chon Lop Kich Thuoc 2
    Thisdrawing.Utility.Prompt (vbCrLf & "Select Dimensions(Class2):" & vbCr)
    Dim Class2 As AcadSelectionSet
    Set Class2 = Thisdrawing.SelectionSets.Add("Class2" & Now)
    Class2.SelectOnScreen FT, FD
    Call HCF4151_Call_FilterOnlyLinearDimInDimSelectSet(Class2)
    If Class2.Count = 0 Then
        GoTo GoToExitSub
    End If
'Reset HomeText All Dim In SelectSet
    Call HCF4146_Call_ResetHomeTextOfDimSelectSet(Class1)
    Call HCF4146_Call_ResetHomeTextOfDimSelectSet(Class2)
'Xac dinh kich thuoc lon nhat
    Dim LargestDim1 As AcadDimension
    Dim LargestDim2 As AcadDimension
    Set LargestDim1 = HCF4141_DefineLargestDimInDimSelectSet(Class1)
    Set LargestDim2 = HCF4141_DefineLargestDimInDimSelectSet(Class2)
'Define OldDimPosition of Class1 and Class2
    Dim GetDimLinePosition As Variant
    Dim OldDimLinePosition1 As Variant
    Dim OldDimLinePosition2 As Variant
    GetDimLinePosition = HCF4154_GetProperty_LinearDim_ByExplode(LargestDim1)
    If VarType(GetDimLinePosition) = vbBoolean Then
        GoTo GoToExitSub
    Else
        OldDimLinePosition1 = GetDimLinePosition(0)
    End If
    GetDimLinePosition = HCF4154_GetProperty_LinearDim_ByExplode(LargestDim2)
    If VarType(GetDimLinePosition) = vbBoolean Then
        GoTo GoToExitSub
    Else
        OldDimLinePosition2 = GetDimLinePosition(0)
    End If
'MoveDimText
    Dim EachDim As AcadDimension
    For Each EachDim In Class1
        EachDim.TextPosition = OldDimLinePosition2
        EachDim.Update
    Next
    For Each EachDim In Class2
        EachDim.TextPosition = OldDimLinePosition1
        EachDim.Update
    Next
'Reset HomeText All Dim In SelectSet
    Call HCF4146_Call_ResetHomeTextOfDimSelectSet(Class1)
    Call HCF4146_Call_ResetHomeTextOfDimSelectSet(Class2)
GoToExitSub:
    Class1.Delete
    Class2.Delete
'Reset CommandLine
    Call HCF4153_Call_ResetCommandLine("D12")
End Sub
Sub HCS3123_DimArrange1Direction()
'(TB VBABoss) Dim Arrange One Direction Type,[DA1]
'System Setting
    'Get DimScale
        Dim DimScale As Variant: DimScale = Thisdrawing.GetVariable("DIMSCALE")
    'DeltaDimSpace
        Dim DeltaDimSpace As Double: DeltaDimSpace = 2 * DimScale
    'Othor On
        Thisdrawing.SetVariable "ORTHOMODE", 1
    'Backup OSMODE
        Dim BackupOsnap As Variant: BackupOsnap = HCF4113_SettingOsnap("Backup", "")
    
'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 LinearDim
    Call HCF4151_Call_FilterOnlyLinearDimInDimSelectSet(DimSelectSet)
    If DimSelectSet.Count = 0 Then GoTo GoToExitSub
'Reset HomeText All Dim In SelectSet
    Call HCF4146_Call_ResetHomeTextOfDimSelectSet(DimSelectSet)
'Select BasicObj
    Dim GetObj() As Variant
    Dim Obj As AcadEntity
    GetObj = HCF4059_GetObj(Thisdrawing, "Select Obj to define DimSpace:")
    If GetObj(0) = False Then
        GoTo GoToExitSub
    Else
        Set Obj = GetObj(1)
    End If
'Get Point1
    Dim Point1 As Variant
    Call HCF4113_SettingOsnap("Nearest", "")
    Point1 = HCF4045_GetPoint(Thisdrawing, "Select Point1 to Arrange Dimension:")
    If Func70IsEmptyArray(Point1) = True Then GoTo GoToExitSub
'Define DimSpace1,DimSpace2
    Dim DimSpace0 As Integer
    Dim DimSpace1 As Integer: DimSpace1 = SettingDimSpace1
    If HCF4021_IsDimension(Obj) = True Then
        DimSpace0 = SettingDimSpace1
    Else
        DimSpace0 = SettingDimSpace0
    End If
    DimSpace0 = DimScale * DimSpace0
    DimSpace1 = DimScale * DimSpace1
'Select Point2 to DefineDirection
    Dim Point2 As Variant
    Call HCF4113_SettingOsnap("Perpendicular", "")
    Point2 = HCF4106_GetSecondPoint(Thisdrawing, Point1, "Select Point2 to Define Direction Arrange Dimension:")
    If Func70IsEmptyArray(Point2) = True Then GoTo GoToExitSub
'Get DimSpace
    Dim GetInteger As Variant
    GetInteger = HCF4061_GetInteger(Thisdrawing, "DimSpace of First Class(*DimScale):")
    If VarType(GetInteger) <> vbBoolean Then
        DimSpace0 = DimScale * GetInteger
    End If
'Define Angle From Point1 to Point2
    Dim Point12Angle As Double
    Point12Angle = Func23AngleOfLineThrough2Point(Point1, Point2)
'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 Each EachDim In DimSelectSet
        IsInList = False
        EachDimTextPosition = EachDim.TextPosition
        EachDistance = HCF4156_DistanceFromPoint2ToPoint1WithAngle(Point1, 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 Each EachDim In DimSelectSet
        EachDimTextPosition = EachDim.TextPosition
        EachDistance = HCF4156_DistanceFromPoint2ToPoint1WithAngle(Point1, 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(Point1, Point12Angle, EachMoveSpace)
            EachDim.TextPosition = NewTextPositon
            EachDim.Update
        End If
    Next
'Reset TextDimPosition
    Call HCF4146_Call_ResetHomeTextOfDimSelectSet(DimSelectSet)
GoToExitSub:
    DimSelectSet.Delete
    Call HCF4113_SettingOsnap("Restore", BackupOsnap)
    Call HCF4153_Call_ResetCommandLine("DA1")
End Sub
Function Func19ObjectCenterPoint(Obj As AcadEntity) As Variant
    'Function Xac dinh center cua Obj
    Dim MinPointObj As Variant
    Dim MaxPointObj As Variant
    Dim lineObj As AcadLine
    Dim LineObjLen As Double
    Dim LineObjAngle As Double
    Obj.GetBoundingBox MinPointObj, MaxPointObj
    Set lineObj = Thisdrawing.ModelSpace.AddLine(MinPointObj, MaxPointObj)
    lineObj.Visible = False
    LineObjLen = lineObj.Length
    LineObjAngle = lineObj.Angle
    Func19ObjectCenterPoint = Thisdrawing.Utility.PolarPoint(MinPointObj, LineObjAngle, LineObjLen / 2)
    lineObj.Delete
End Function
Function HCF4154_GetProperty_LinearDim_ByExplode(ObjDim As AcadDimension) As Variant
'Dim Result(0_DimLinePosition)
    Dim Result(0) As Variant
'Check Is Linear Dimension
    Dim IsLinearDim As Boolean
    IsLinearDim = HCF4150_IsLinearDimension(ObjDim)
    If IsLinearDim = False Then
        HCF4154_GetProperty_LinearDim_ByExplode = False
        Exit Function
    End If
'Explode Dim
    Dim AfterExplodeSelectSet As AcadSelectionSet
    Set AfterExplodeSelectSet = Thisdrawing.SelectionSets.Add("AfterExplodeSelectSet" & Now)
    Call HCF4155_Call_CreatSelectSetAfterExplodeObj(ObjDim, AfterExplodeSelectSet)
    If AfterExplodeSelectSet.Count = 0 Then
        HCF4154_GetProperty_LinearDim_ByExplode = False
        GoTo GoToExitSub
    End If
'Define DimTextAngle
    Dim EachEntity As AcadEntity
    Dim DimText As AcadMText
    Dim DimTextAngle As Double
    Dim DimTextCount As Integer
    For Each EachEntity In AfterExplodeSelectSet
        If EachEntity.ObjectName = "AcDbMText" Then
            Set DimText = EachEntity
            DimTextCount = DimTextCount + 1
        End If
    Next
    If DimTextCount = 1 Then
        DimTextAngle = DimText.Rotation
    Else
        MsgBox "Can't Define DimTextAngle After Explode LinearDim."
        HCF4154_GetProperty_LinearDim_ByExplode = False
        GoTo GoToExitSub
    End If
'Define DimLinePosition
    Dim EachLine As AcadLine
    Dim EachLineAngle As Double
    Dim DimLine As AcadLine
    Dim DimLineCount As Integer
    Dim DimLinePosition As Variant
    Dim TextAndLineIsParallel As Boolean
    For Each EachEntity In AfterExplodeSelectSet
        If EachEntity.ObjectName = "AcDbLine" Then
            Set EachLine = EachEntity
            EachLineAngle = EachLine.Angle
            TextAndLineIsParallel = HCF4129_TwoAngleIsParallel(DimTextAngle, EachLineAngle, 2)
            If TextAndLineIsParallel = True Then
                Set DimLine = EachLine
                DimLineCount = DimLineCount + 1
            End If
        End If
    Next
    If DimLineCount = 1 Then
        DimLinePosition = Func19ObjectCenterPoint(DimLine)
        Result(0) = DimLinePosition
    Else
        MsgBox "Can't Define DimTextAngle After Explode LinearDim."
        HCF4154_GetProperty_LinearDim_ByExplode = False
        GoTo GoToExitSub
    End If
'Result
    HCF4154_GetProperty_LinearDim_ByExplode = Result
GoToExitSub:
    AfterExplodeSelectSet.Erase
    AfterExplodeSelectSet.Delete
End Function
Function HCF4155_Call_CreatSelectSetAfterExplodeObj(Obj As AcadEntity, AfterExplodeSelectSet As AcadSelectionSet)
'Creat CopyObj
    Dim CopyObj As AcadEntity
    Set CopyObj = Obj.Copy
    CopyObj.Visible = False
'Explode Obj
    Call HCF4007_ExplodeBlockReference(Thisdrawing, CopyObj)
    Thisdrawing.SendCommand "SELECT" & vbCr & "P" & vbCr & vbCr
'Select Entity After Explode
    AfterExplodeSelectSet.Select acSelectionSetPrevious
End Function
;(TB VBABoss) Dim Arrange One Direction Type,[DA1]
(defun C:DA1()
(command "-vbarun" "HCS3123_DimArrange1Direction")
)