<?xml version="1.0" encoding="UTF-8"?>
<rss xmlns:content="http://purl.org/rss/1.0/modules/content/" xmlns:dc="http://purl.org/dc/elements/1.1/" xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#" xmlns:taxo="http://purl.org/rss/1.0/modules/taxonomy/" version="2.0">
  <channel>
    <title>topic Re: VBA Arrange Dimensions in Inventor Programming - iLogic, Macros, AddIns &amp; Apprentice</title>
    <link>https://forums.autodesk.com/t5/inventor-programming-ilogic/vba-arrange-dimensions/m-p/10444152#M126120</link>
    <description>&lt;LI-CODE lang="markup"&gt;Private Sub ButtonCancel_Click()
    UB_UpdateFromDrawing = ""
    UB_UpdateToDrawing = ""
    Unload Me
End Sub
Private Sub ButtonYes_Click()
    UB_UpdateFromDrawing = CB_UpdateFromDrawing.Value
    UB_UpdateToDrawing = CB_UpdateToDrawing.Value
    Unload Me
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode = vbFormControlMenu Then Cancel = True
End Sub
Private Sub UserForm_Initialize()
    For i = LBound(OpeningFileArr) To UBound(OpeningFileArr)
        CB_UpdateFromDrawing.AddItem OpeningFileArr(i)
    Next
    For i = LBound(OpeningFileArr) To UBound(OpeningFileArr)
        CB_UpdateToDrawing.AddItem OpeningFileArr(i)
    Next
    UpdateBlockV2.Caption = "(TB) Update Block From Other Drawing V2.0"
    CB_UpdateFromDrawing.Value = OpeningFileArr(0)
    CB_UpdateToDrawing.Value = OpeningFileArr(0)
End Sub&lt;/LI-CODE&gt;</description>
    <pubDate>Mon, 05 Jul 2021 12:30:23 GMT</pubDate>
    <dc:creator>buianhtuan.cdt</dc:creator>
    <dc:date>2021-07-05T12:30:23Z</dc:date>
    <item>
      <title>VBA Arrange Dimensions</title>
      <link>https://forums.autodesk.com/t5/inventor-programming-ilogic/vba-arrange-dimensions/m-p/8610874#M94742</link>
      <description>&lt;P&gt;Hello,&lt;/P&gt;
&lt;P&gt;&amp;nbsp;&lt;/P&gt;
&lt;P&gt;I need help about dimensions that i mentioned at below picture.&lt;/P&gt;
&lt;P&gt;How can i arrange dimensions as second situation with VBA? (Inventor 2019)&lt;/P&gt;
&lt;P&gt;&amp;nbsp;&lt;/P&gt;
&lt;P&gt;Thanks&lt;/P&gt;
&lt;P&gt;&amp;nbsp;&lt;/P&gt;
&lt;P&gt;&lt;span class="lia-inline-image-display-wrapper lia-image-align-inline" image-alt="arrange.jpg" style="width: 400px;"&gt;&lt;img src="https://forums.autodesk.com/t5/image/serverpage/image-id/605671i6B63620EA671C079/image-size/large?v=v2&amp;amp;px=999" role="button" title="arrange.jpg" alt="arrange.jpg" /&gt;&lt;/span&gt;&lt;/P&gt;</description>
      <pubDate>Thu, 21 Feb 2019 10:16:23 GMT</pubDate>
      <guid>https://forums.autodesk.com/t5/inventor-programming-ilogic/vba-arrange-dimensions/m-p/8610874#M94742</guid>
      <dc:creator>Anonymous</dc:creator>
      <dc:date>2019-02-21T10:16:23Z</dc:date>
    </item>
    <item>
      <title>Re: VBA Arrange Dimensions</title>
      <link>https://forums.autodesk.com/t5/inventor-programming-ilogic/vba-arrange-dimensions/m-p/8612288#M94751</link>
      <description>&lt;P&gt;Hello,&lt;/P&gt;
&lt;P&gt;&amp;nbsp;&lt;/P&gt;
&lt;P&gt;I think you can use this. This is auto arrange but only the linear dimensions.&amp;nbsp;&lt;/P&gt;
&lt;P&gt;&amp;nbsp;&lt;/P&gt;
&lt;PRE&gt;&lt;SPAN&gt;Dim&lt;/SPAN&gt; &lt;SPAN&gt;oDoc&lt;/SPAN&gt; &lt;SPAN&gt;As&lt;/SPAN&gt; &lt;SPAN&gt;DrawingDocument&lt;/SPAN&gt;
&lt;SPAN&gt;oDoc&lt;/SPAN&gt; = &lt;SPAN&gt;ThisDoc&lt;/SPAN&gt;.&lt;SPAN&gt;Document&lt;/SPAN&gt;

&lt;SPAN&gt;' Set a reference to the active sheet&lt;/SPAN&gt;
&lt;SPAN&gt;Dim&lt;/SPAN&gt; &lt;SPAN&gt;oSheet&lt;/SPAN&gt; &lt;SPAN&gt;As&lt;/SPAN&gt; &lt;SPAN&gt;Sheet&lt;/SPAN&gt;
&lt;SPAN&gt;oSheet&lt;/SPAN&gt; = &lt;SPAN&gt;oDoc&lt;/SPAN&gt;.&lt;SPAN&gt;ActiveSheet&lt;/SPAN&gt;

&lt;SPAN&gt;Dim&lt;/SPAN&gt; &lt;SPAN&gt;oDrawingDim&lt;/SPAN&gt; &lt;SPAN&gt;As&lt;/SPAN&gt; &lt;SPAN&gt;DrawingDimension&lt;/SPAN&gt;
&lt;SPAN&gt;Dim&lt;/SPAN&gt; &lt;SPAN&gt;oDrawingDims&lt;/SPAN&gt; &lt;SPAN&gt;As&lt;/SPAN&gt; &lt;SPAN&gt;DrawingDimensions&lt;/SPAN&gt;
&lt;SPAN&gt;Dim&lt;/SPAN&gt; &lt;SPAN&gt;oDimsToBeArranged&lt;/SPAN&gt; &lt;SPAN&gt;As&lt;/SPAN&gt; &lt;SPAN&gt;ObjectCollection&lt;/SPAN&gt;

&lt;SPAN&gt;' Iterate over all dimensions in the drawing and&lt;/SPAN&gt;
&lt;SPAN&gt;' center them if they are linear or angular.&lt;/SPAN&gt;
&lt;SPAN&gt;' Add them to the ObjectCollection to be arranged&lt;/SPAN&gt;

&lt;SPAN&gt;oDrawingDimensions&lt;/SPAN&gt; = &lt;SPAN&gt;oSheet&lt;/SPAN&gt;.&lt;SPAN&gt;DrawingDimensions&lt;/SPAN&gt;

&lt;SPAN&gt;oDimsToBeArranged&lt;/SPAN&gt; = &lt;SPAN&gt;ThisApplication&lt;/SPAN&gt;.&lt;SPAN&gt;TransientObjects&lt;/SPAN&gt;.&lt;SPAN&gt;CreateObjectCollection&lt;/SPAN&gt;

&lt;SPAN&gt;For&lt;/SPAN&gt; &lt;SPAN&gt;Each&lt;/SPAN&gt; &lt;SPAN&gt;oDrawingDim&lt;/SPAN&gt; &lt;SPAN&gt;In&lt;/SPAN&gt; &lt;SPAN&gt;oDrawingDimensions&lt;/SPAN&gt;
    &lt;SPAN&gt;If&lt;/SPAN&gt; &lt;SPAN&gt;TypeOf&lt;/SPAN&gt; &lt;SPAN&gt;oDrawingDim&lt;/SPAN&gt; &lt;SPAN&gt;Is&lt;/SPAN&gt; &lt;SPAN&gt;LinearGeneralDimension&lt;/SPAN&gt; &lt;SPAN&gt;Then&lt;/SPAN&gt;
       &lt;SPAN&gt;oDrawingDim&lt;/SPAN&gt;.&lt;SPAN&gt;CenterText&lt;/SPAN&gt;
       &lt;SPAN&gt;oDimsToBeArranged&lt;/SPAN&gt;.&lt;SPAN&gt;Add&lt;/SPAN&gt;(&lt;SPAN&gt;oDrawingDim&lt;/SPAN&gt;)
    &lt;SPAN&gt;End&lt;/SPAN&gt; &lt;SPAN&gt;If&lt;/SPAN&gt;
&lt;SPAN&gt;Next&lt;/SPAN&gt;

&lt;SPAN&gt;If&lt;/SPAN&gt; &lt;SPAN&gt;oDimsToBeArranged&lt;/SPAN&gt;.&lt;SPAN&gt;Count&lt;/SPAN&gt; &amp;gt; 0 &lt;SPAN&gt;Then&lt;/SPAN&gt;		
	&lt;SPAN&gt;oDrawingDimensions&lt;/SPAN&gt;.&lt;SPAN&gt;Arrange&lt;/SPAN&gt;(&lt;SPAN&gt;oDimsToBeArranged&lt;/SPAN&gt;)
&lt;SPAN&gt;End&lt;/SPAN&gt; &lt;SPAN&gt;If&lt;/SPAN&gt; &lt;/PRE&gt;</description>
      <pubDate>Thu, 21 Feb 2019 18:47:56 GMT</pubDate>
      <guid>https://forums.autodesk.com/t5/inventor-programming-ilogic/vba-arrange-dimensions/m-p/8612288#M94751</guid>
      <dc:creator>Charlies_3D_T</dc:creator>
      <dc:date>2019-02-21T18:47:56Z</dc:date>
    </item>
    <item>
      <title>Re: VBA Arrange Dimensions</title>
      <link>https://forums.autodesk.com/t5/inventor-programming-ilogic/vba-arrange-dimensions/m-p/10405453#M125651</link>
      <description>&lt;LI-CODE lang="c"&gt;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 &amp;lt;&amp;gt; 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) &amp;lt;= 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) &amp;lt;= 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 &amp;amp; "Select Dimensions(Class1):" &amp;amp; vbCr)
    Dim Class1 As AcadSelectionSet
    Set Class1 = Thisdrawing.SelectionSets.Add("Class1" &amp;amp; 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 &amp;amp; "Select Dimensions(Class2):" &amp;amp; vbCr)
    Dim Class2 As AcadSelectionSet
    Set Class2 = Thisdrawing.SelectionSets.Add("Class2" &amp;amp; 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" &amp;amp; Now)
    Dim FT(0) As Integer
    Dim FD(0) As Variant
    FT(0) = 0:  FD(0) = "DIMENSION"
    Thisdrawing.Utility.Prompt (vbCrLf &amp;amp; "Select Dimensions to Arrangement:" &amp;amp; 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) &amp;lt;&amp;gt; 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) &amp;lt;&amp;gt; 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" &amp;amp; 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" &amp;amp; vbCr &amp;amp; "P" &amp;amp; vbCr &amp;amp; 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")
)
&lt;/LI-CODE&gt;</description>
      <pubDate>Sun, 20 Jun 2021 13:00:09 GMT</pubDate>
      <guid>https://forums.autodesk.com/t5/inventor-programming-ilogic/vba-arrange-dimensions/m-p/10405453#M125651</guid>
      <dc:creator>buianhtuan.cdt</dc:creator>
      <dc:date>2021-06-20T13:00:09Z</dc:date>
    </item>
    <item>
      <title>Re: VBA Arrange Dimensions</title>
      <link>https://forums.autodesk.com/t5/inventor-programming-ilogic/vba-arrange-dimensions/m-p/10405515#M125652</link>
      <description>&lt;P&gt;There is also this one I found I don't know where.. :&lt;/P&gt;&lt;P&gt;&amp;nbsp;&lt;/P&gt;&lt;PRE&gt;&lt;SPAN style="color: #ff0000;"&gt;Dim&lt;/SPAN&gt; &lt;SPAN style="color: #800000;"&gt;oDimensions&lt;/SPAN&gt; &lt;SPAN style="color: #ff0000;"&gt;As&lt;/SPAN&gt; &lt;SPAN style="color: #800000;"&gt;DrawingDimensions&lt;/SPAN&gt; = &lt;SPAN style="color: #800080;"&gt;ActiveSheet&lt;/SPAN&gt;.&lt;SPAN style="color: #800080;"&gt;Sheet&lt;/SPAN&gt;.&lt;SPAN style="color: #800000;"&gt;DrawingDimensions&lt;/SPAN&gt;
&lt;SPAN style="color: #ff0000;"&gt;Dim&lt;/SPAN&gt; &lt;SPAN style="color: #800000;"&gt;oCol&lt;/SPAN&gt; &lt;SPAN style="color: #ff0000;"&gt;As&lt;/SPAN&gt; &lt;SPAN style="color: #800000;"&gt;ObjectCollection&lt;/SPAN&gt; = &lt;SPAN style="color: #800080;"&gt;ThisApplication&lt;/SPAN&gt;.&lt;SPAN style="color: #800000;"&gt;TransientObjects&lt;/SPAN&gt;.&lt;SPAN style="color: #800000;"&gt;CreateObjectCollection&lt;/SPAN&gt;
&lt;SPAN style="color: #ff0000;"&gt;For&lt;/SPAN&gt; &lt;SPAN style="color: #ff0000;"&gt;Each&lt;/SPAN&gt; &lt;SPAN style="color: #800000;"&gt;oDim&lt;/SPAN&gt; &lt;SPAN style="color: #ff0000;"&gt;As&lt;/SPAN&gt; &lt;SPAN style="color: #800000;"&gt;DrawingDimension&lt;/SPAN&gt; &lt;SPAN style="color: #ff0000;"&gt;In&lt;/SPAN&gt; &lt;SPAN style="color: #800000;"&gt;oDimensions&lt;/SPAN&gt;
	&lt;SPAN style="color: #800000;"&gt;oCol&lt;/SPAN&gt;.&lt;SPAN style="color: #800000;"&gt;Add&lt;/SPAN&gt;(&lt;SPAN style="color: #800000;"&gt;oDim&lt;/SPAN&gt;)
&lt;SPAN style="color: #ff0000;"&gt;Next&lt;/SPAN&gt;
&lt;SPAN style="color: #800000;"&gt;oDimensions&lt;/SPAN&gt;.&lt;SPAN style="color: #800000;"&gt;Arrange&lt;/SPAN&gt;(&lt;SPAN style="color: #800000;"&gt;oCol&lt;/SPAN&gt;)
&lt;SPAN style="color: #ff0000;"&gt;For&lt;/SPAN&gt; &lt;SPAN style="color: #ff0000;"&gt;Each&lt;/SPAN&gt; &lt;SPAN style="color: #800000;"&gt;oDim&lt;/SPAN&gt; &lt;SPAN style="color: #ff0000;"&gt;As&lt;/SPAN&gt; &lt;SPAN style="color: #800000;"&gt;DrawingDimension&lt;/SPAN&gt; &lt;SPAN style="color: #ff0000;"&gt;In&lt;/SPAN&gt; &lt;SPAN style="color: #800000;"&gt;oCol&lt;/SPAN&gt;
	&lt;SPAN style="color: #ff0000;"&gt;On&lt;/SPAN&gt; &lt;SPAN style="color: #ff0000;"&gt;Error&lt;/SPAN&gt; &lt;SPAN style="color: #ff0000;"&gt;Resume&lt;/SPAN&gt; &lt;SPAN style="color: #ff0000;"&gt;Next&lt;/SPAN&gt;
	&lt;SPAN style="color: #800000;"&gt;oDim&lt;/SPAN&gt;.&lt;SPAN style="color: #800000;"&gt;CenterText&lt;/SPAN&gt;
&lt;SPAN style="color: #ff0000;"&gt;Next&lt;/SPAN&gt;&lt;/PRE&gt;&lt;P&gt;&amp;nbsp;Regards,&lt;/P&gt;&lt;P&gt;FINET L.&lt;/P&gt;</description>
      <pubDate>Sun, 20 Jun 2021 13:50:08 GMT</pubDate>
      <guid>https://forums.autodesk.com/t5/inventor-programming-ilogic/vba-arrange-dimensions/m-p/10405515#M125652</guid>
      <dc:creator>FINET_Laurent</dc:creator>
      <dc:date>2021-06-20T13:50:08Z</dc:date>
    </item>
    <item>
      <title>Re: VBA Arrange Dimensions</title>
      <link>https://forums.autodesk.com/t5/inventor-programming-ilogic/vba-arrange-dimensions/m-p/10408573#M125665</link>
      <description>&lt;P&gt;You said you wanted the solution to be in VBA instead of iLogic right.&amp;nbsp; Well here's the VBA macro I sometimes use for arranging dimensions and re-centering dimension text.&amp;nbsp; I hope you can get some use out of it too.&lt;/P&gt;
&lt;LI-CODE lang="general"&gt;Sub Center_ArrangeAllDims()
    If ThisApplication.ActiveDocumentType &amp;lt;&amp;gt; DocumentTypeEnum.kDrawingDocumentObject Then
        Call MsgBox("This rule only works for Drawing Documents.", vbOKOnly, "WRONG DOCUMENT TYPE")
        Exit Sub
    End If
    Dim oDDoc As DrawingDocument
    Set oDDoc = ThisApplication.ActiveDocument
    Dim oSheet As Inventor.Sheet
    Set oSheet = oDDoc.ActiveSheet
    Dim oDDims As DrawingDimensions
    Set oDDims = oSheet.DrawingDimensions
    Dim oDDim As DrawingDimension
    For Each oDDim In oDDims
        If TypeOf oDDim Is LinearGeneralDimension Or _
            TypeOf oDDim Is AngularGeneralDimension Then
            Call oDDim.CenterText
        End If
    Next
    Dim oBaselineDimSet As BaselineDimensionSet
    For Each oBaselineDimSet In oDDims.BaselineDimensionSets
        Call oBaselineDimSet.ArrangeText
    Next
    Dim oChainDimSet As ChainDimensionSet
    For Each oChainDimSet In oDDims.ChainDimensionSets
        Call oChainDimSet.Arrange(oChainDimSet.Members.Item(1))
    Next
    Dim oCollection As ObjectCollection
    Set oCollection = ThisApplication.TransientObjects.CreateObjectCollection
    'Dim oLinGenDim As LinearGeneralDimension
    Dim oGenDim As GeneralDimension
    For Each oGenDim In oDDims.GeneralDimensions
        If TypeOf oGenDim Is LinearGeneralDimension Then
            Call oCollection.Add(oGenDim)
        End If
    Next
    If oCollection.Count &amp;gt; 1 Then
        Call oDDims.Arrange(oCollection)
    End If
End Sub&lt;/LI-CODE&gt;
&lt;P&gt;&amp;nbsp;&lt;/P&gt;
&lt;P&gt;If this solved your problem, or answered your question, please click &lt;SPAN style="background-color: green; color: white;"&gt;&lt;STRONG&gt;ACCEPT SOLUTION&lt;/STRONG&gt;&lt;/SPAN&gt;.&lt;BR /&gt;Or, if this helped you, please click (LIKE or KUDOS) &lt;SPAN&gt;&lt;img class="lia-deferred-image lia-image-emoji" src="https://forums.autodesk.com/html/@7401B55A0A518861312A0F851CD29320/emoticons/1f44d.png" alt=":thumbs_up:" title=":thumbs_up:" /&gt;&lt;/SPAN&gt;.&lt;/P&gt;
&lt;P&gt;If you want and have time, I would appreciate your Vote(s) for &lt;A href="https://forums.autodesk.com/t5/forums/recentpostspage/post-type/message/interaction-style/idea/user-id/7812054/" target="_blank"&gt;My IDEAS &lt;SPAN&gt;&lt;img class="lia-deferred-image lia-image-emoji" src="https://forums.autodesk.com/html/@B166FEBB95D67CFA84899D32D8E17FC1/emoticons/1f4a1.png" alt=":light_bulb:" title=":light_bulb:" /&gt;&lt;/SPAN&gt;&lt;/A&gt;or you can Explore &lt;A href="https://knowledge.autodesk.com/profile/LTSUSR7HXMSAE/articles" target="_blank"&gt;My CONTRIBUTIONS &lt;/A&gt;&lt;/P&gt;</description>
      <pubDate>Mon, 21 Jun 2021 16:55:20 GMT</pubDate>
      <guid>https://forums.autodesk.com/t5/inventor-programming-ilogic/vba-arrange-dimensions/m-p/10408573#M125665</guid>
      <dc:creator>WCrihfield</dc:creator>
      <dc:date>2021-06-21T16:55:20Z</dc:date>
    </item>
    <item>
      <title>Re: VBA Arrange Dimensions</title>
      <link>https://forums.autodesk.com/t5/inventor-programming-ilogic/vba-arrange-dimensions/m-p/10433850#M126027</link>
      <description>&lt;LI-CODE lang="general"&gt;'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 &amp;lt;&amp;gt; "AcDbRotatedDimension" Then
            ReDim Preserve IsNotRotatedDimArr(0 To k)
            Set IsNotRotatedDimArr(k) = EachDim
            k = k + 1
        End If
    Next
    If k &amp;gt; 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 &amp;gt; MinPoint(0) Then MinX = MinPoint(0)
            If MinY &amp;gt; MinPoint(1) Then MinY = MinPoint(1)
            If MaxX &amp;lt; MaxPoint(0) Then MaxX = MaxPoint(0)
            If MaxY &amp;lt; 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" &amp;amp; vbCr &amp;amp; "W" &amp;amp; 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 &amp;lt; MinX Then
        TmpDouble = MaxX
        MaxX = MinX
        MinX = TmpDouble
    End If
    If MaxY &amp;lt; 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 &amp;gt;= 0 And DeltaMaxX &amp;lt;= 0 And DeltaMinY &amp;gt;= 0 And DeltaMaxY &amp;lt;= 0 Then
        HCF4165_DimPositionWithMinMaxPoint = "IN"
        Exit Function
    End If
'LEFT
    If DeltaMinX &amp;lt; 0 And DeltaMinY &amp;gt; 0 And DeltaMaxY &amp;lt; 0 Then
        HCF4165_DimPositionWithMinMaxPoint = "LEFT"
        Exit Function
    End If
'RIGHT
    If DeltaMaxX &amp;gt; 0 And DeltaMinY &amp;gt; 0 And DeltaMaxY &amp;lt; 0 Then
        HCF4165_DimPositionWithMinMaxPoint = "RIGHT"
        Exit Function
    End If
'UP
    If DeltaMaxY &amp;gt; 0 And DeltaMinX &amp;gt; 0 And DeltaMaxX &amp;lt; 0 Then
        HCF4165_DimPositionWithMinMaxPoint = "UP"
        Exit Function
    End If
'DOWN
    If DeltaMinY &amp;lt; 0 And DeltaMinX &amp;gt; 0 And DeltaMaxX &amp;lt; 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) &amp;lt;&amp;gt; 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" &amp;amp; Now)
    Thisdrawing.Utility.Prompt (vbCr &amp;amp; "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 &amp;amp; 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" &amp;amp; Now)
    Dim FT(0) As Integer
    Dim FD(0) As Variant
    FT(0) = 0:  FD(0) = "DIMENSION"
    Thisdrawing.Utility.Prompt (vbCrLf &amp;amp; "Select Dimensions to Arrangement:" &amp;amp; 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 &amp;gt; 0 Then Call HCF4166X_ArrangeDimArr(LeftArr, "LEFT", MinPoint, MaxPoint, DeltaDimSpace, DimSpace0, DimSpace1)
    If j &amp;gt; 0 Then Call HCF4166X_ArrangeDimArr(RightArr, "RIGHT", MinPoint, MaxPoint, DeltaDimSpace, DimSpace0, DimSpace1)
    If k &amp;gt; 0 Then Call HCF4166X_ArrangeDimArr(UpArr, "UP", MinPoint, MaxPoint, DeltaDimSpace, DimSpace0, DimSpace1)
    If f &amp;gt; 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" &amp;amp; Now)
    Thisdrawing.Utility.Prompt vbCrLf &amp;amp; "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" &amp;amp; Now)
    Dim FT(0) As Integer
    Dim FD(0) As Variant
    FT(0) = 0:  FD(0) = "INSERT"
    Thisdrawing.Utility.Prompt vbCrLf &amp;amp; "Select Block Reference:"
    BlockRefSS.SelectOnScreen FT, FD
    If BlockRefSS.Count &amp;lt;&amp;gt; 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 &amp;lt;&amp;gt; 1 Then
        MsgBox "Err:Selected Block Reference Scale &amp;lt;&amp;gt;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 &amp;gt; 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" &amp;amp; Now)
    Dim FT(0) As Integer
    Dim FD(0) As Variant
    FT(0) = 0:  FD(0) = "INSERT"
    Thisdrawing.Utility.Prompt vbCrLf &amp;amp; "Select ReplaceBlockFrom:"
    BlockRefSS.SelectOnScreen FT, FD
    If BlockRefSS.Count &amp;lt;&amp;gt; 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 &amp;lt;&amp;gt; 1 Then
        MsgBox "Err:Selected Block Reference Scale &amp;lt;&amp;gt;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 &amp;amp; "Select ReplaceBlockTo:"
    BlockRefSS.SelectOnScreen FT, FD
    If BlockRefSS.Count &amp;lt;&amp;gt; 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 &amp;lt;&amp;gt; 1 Then
        MsgBox "Err:Selected Block Reference Scale &amp;lt;&amp;gt;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



&lt;/LI-CODE&gt;</description>
      <pubDate>Wed, 30 Jun 2021 22:11:36 GMT</pubDate>
      <guid>https://forums.autodesk.com/t5/inventor-programming-ilogic/vba-arrange-dimensions/m-p/10433850#M126027</guid>
      <dc:creator>buianhtuan.cdt</dc:creator>
      <dc:date>2021-06-30T22:11:36Z</dc:date>
    </item>
    <item>
      <title>Re: VBA Arrange Dimensions</title>
      <link>https://forums.autodesk.com/t5/inventor-programming-ilogic/vba-arrange-dimensions/m-p/10433851#M126028</link>
      <description>&lt;P&gt;;(TB VBABoss) Replace Block By Block,[RBBB]&lt;BR /&gt;(defun C:RBBB()&lt;BR /&gt;(command "-vbarun" "HCS3128_ReplaceBlockByBlock")&lt;BR /&gt;)&lt;/P&gt;&lt;P&gt;;(TB VBABoss) Add Entity Into BlockRef,[AE2B]&lt;BR /&gt;(defun C:AE2B()&lt;BR /&gt;(command "-vbarun" "HCS3127_AddEntityIntoBlockRef")&lt;BR /&gt;)&lt;/P&gt;&lt;P&gt;;(VBA AutoCad) Update Selected Block From Other Drawing,[UB2]&lt;BR /&gt;(defun C:UB2()&lt;BR /&gt;(command "-vbarun" "HCS3126_UpdateSelectedBlockFromOtherDrawing_Version2")&lt;BR /&gt;)&lt;/P&gt;&lt;P&gt;;(TB VBABoss) Dim Arrange 4 Direction Type,[DD4]&lt;BR /&gt;(defun C:DD4()&lt;BR /&gt;(command "-vbarun" "HCS3125_DimArrange4Direction")&lt;BR /&gt;)&lt;/P&gt;&lt;P&gt;;(TB VBABoss) Quick Creat Spline,[QCSP]&lt;BR /&gt;(defun C:QCSP()&lt;BR /&gt;(command "-vbarun" "HCS3124_QuickCreatSpline")&lt;BR /&gt;)&lt;/P&gt;</description>
      <pubDate>Wed, 30 Jun 2021 22:12:48 GMT</pubDate>
      <guid>https://forums.autodesk.com/t5/inventor-programming-ilogic/vba-arrange-dimensions/m-p/10433851#M126028</guid>
      <dc:creator>buianhtuan.cdt</dc:creator>
      <dc:date>2021-06-30T22:12:48Z</dc:date>
    </item>
    <item>
      <title>Re: VBA Arrange Dimensions</title>
      <link>https://forums.autodesk.com/t5/inventor-programming-ilogic/vba-arrange-dimensions/m-p/10442180#M126103</link>
      <description>&lt;LI-CODE lang="cpp"&gt;'Setting Sheetname
    Public Const DBSheetname As String = "ƒf&amp;#129;[ƒ^ƒx&amp;#129;[ƒX"
    Public Const StaffManagerSheetname As String = "&amp;#144;lˆõŠÇ—&amp;#157;"
    Public Const ProjectSheetname As String = "ˆÄŒ&amp;#143;ŠÇ—&amp;#157;"
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Function HCF4079_DefineRowEndNo(WS As Worksheet, EndRow As Integer, ColumnNo As Integer)
    EndRow = WS.Cells(Rows.Count, ColumnNo).End(xlUp).Row
End Function
Function Func29ConvertColumnLetterToNumber(ColumnLetter As String) As Integer
' Function chuyen ma so cot tu letter sang number
    'Convert To Column Number
    Dim ColumnNumber As Long
    ColumnNumber = Range(ColumnLetter &amp;amp; 1).Column
    Func29ConvertColumnLetterToNumber = ColumnNumber
End Function
Function HCF4086_IsInArr2Chieu_NumberOrString(ListArr As Variant, ListColumnNo As Integer, NeedCheckValue As Variant) As Boolean
    Dim CompareValue As Variant
    For i = LBound(ListArr) To UBound(ListArr)
        CompareValue = ListArr(i, ListColumnNo)
        If CompareValue = NeedCheckValue Then
            HCF4086_IsInArr2Chieu_NumberOrString = True
            Exit Function
        End If
    Next
End Function
Function HCF4060_GetStringMiddle2Delimited(Str As String, Delimited1 As String, Delimited2 As String) As String
    Dim Result As String
    Dim Delimited1Position As Integer
    Dim Delimited2Position As Integer
    Delimited1Position = InStr(Str, Delimited1)
    Delimited2Position = InStr(Str, Delimited2)
    If Delimited1Position * Delimited2Position = 0 Then Exit Function
    Result = Mid(Str, Delimited1Position + 1, Delimited2Position - Delimited1Position - 1)
    HCF4060_GetStringMiddle2Delimited = Result
End Function
Function HCF4117_VlookupInArr2Dimension_NumberOrString(ListArr As Variant, CheckColumnNo As Integer, ResultColumnNo As Integer, CheckValue As Variant) As Variant
    Dim CompareValue As Variant
    Dim StrCheckValue As String: StrCheckValue = CStr(CheckValue)
    Dim Result As Variant
    If HCF4116_IsTwoDimensionalArray(ListArr) = False Then
        HCF4117_VlookupInArr2Dimension_NumberOrString = False
        Exit Function
    End If
    For i = LBound(ListArr) To UBound(ListArr)
        CompareValue = ListArr(i, CheckColumnNo)
        CompareValue = CStr(CompareValue)
        If CompareValue = StrCheckValue Then
            Result = ListArr(i, ResultColumnNo)
        End If
    Next
    If VarType(Result) = vbEmpty Then Result = False
    HCF4117_VlookupInArr2Dimension_NumberOrString = Result
End Function
Function HCF4047_Convert2Integer(InputValue As Variant) As Variant
    Dim OutputValue As Variant
    On Error Resume Next
    OutputValue = CInt(InputValue)
    If Err Then
        OutputValue = False
    Else
        OutputValue = CInt(InputValue)
        If OutputValue - InputValue &amp;lt;&amp;gt; 0 Then OutputValue = False
    End If
    HCF4047_Convert2Integer = OutputValue
End Function
Function HCF4048_Convert2Double(InputValue As Variant) As Variant
    Dim OutputValue As Variant
    On Error Resume Next
    OutputValue = CDbl(InputValue)
    If Err Then
        OutputValue = False
    Else
        OutputValue = CDbl(InputValue)
    End If
    HCF4048_Convert2Double = OutputValue
End Function
Function HCF4116_IsTwoDimensionalArray(Arr As Variant) As Boolean
    Dim i As Integer
    On Error GoTo ExitFunction
    i = UBound(Arr, 2)
    HCF4116_IsTwoDimensionalArray = True
ExitFunction:
End Function
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Function TBFH100_GetFilePath(FileFilter As String, Title As String, MultiSelectMode As Boolean) As Variant
    Dim fnameList As Variant
    fnameList = Application.GetOpenFilename(FileFilter, , Title, , MultiSelectMode)
    If (vbBoolean = VarType(fnameList)) Then
        MsgBox "No files selected"
        TBFH100_GetFilePath = False
    Else
        TBFH100_GetFilePath = fnameList
    End If
End Function
Function TBFH102_CrearArrFromRange(WS As Worksheet, MainColumnLetter As String, ColumnFromLetter As String, ColumnToLetter As String, RowFrom As Integer) As Variant
' Tao mang 2 chieu tu Range
    Dim Arr() As Variant
'Define Column no
    Dim ColumnFromNo As Integer
    Dim ColumnToNo As Integer
    Dim MainColumnNo As Integer
    ColumnFromNo = Func29ConvertColumnLetterToNumber(ColumnFromLetter)
    ColumnToNo = Func29ConvertColumnLetterToNumber(ColumnToLetter)
    MainColumnNo = Func29ConvertColumnLetterToNumber(MainColumnLetter)
'Define EndRow no, neu k co du lieu thi thoat
    Dim EndRow As Integer
    EndRow = WS.Cells(Rows.Count, MainColumnNo).End(xlUp).Row
    If EndRow &amp;lt; RowFrom Then Exit Function
'Define Arr TotalColumn va TotalRow
    Dim ArrTotalColumn As Integer
    Dim ArrTotalRow As Integer
    Dim ArrColumn As Integer
    Dim ArrRow As Integer
    Dim TmpValue As String
    ArrTotalColumn = ColumnToNo - ColumnFromNo
    ArrTotalRow = EndRow - RowFrom
    ReDim Arr(0 To ArrTotalRow, 0 To ArrTotalColumn)
    For i = RowFrom To EndRow
        ArrRow = i - RowFrom
        For k = ColumnFromNo To ColumnToNo
            ArrColumn = k - ColumnFromNo
            TmpValue = WS.Cells(i, k).Value
            Arr(ArrRow, ArrColumn) = TmpValue
        Next
    Next
TBFH102_CrearArrFromRange = Arr
End Function
Function TBFH103_Call_CreatStaffManagerArr(StaffManagerArr As Variant)
    Dim StaffWS As Worksheet: Set StaffWS = ThisWorkbook.Sheets(StaffManagerSheetname)
    StaffManagerArr = TBFH102_CrearArrFromRange(StaffWS, "C", "A", "G", 2)
End Function

Function TBFH104_DefineMonthFromExcelFilePath(ExcelFilePath As String) As String
    Dim MonthValue As String
    Dim Delimited1 As String: Delimited1 = "."
    Dim Delimited2 As String: Delimited2 = "ŒŽ"
    MonthValue = HCF4060_GetStringMiddle2Delimited(ExcelFilePath, Delimited1, Delimited2)
    TBFH104_DefineMonthFromExcelFilePath = MonthValue
End Function

Function TBFH105_GetStaffInformationFromPCNo_StaffID_StaffName(LookupValue As String, FromPC_FromID_FromName_Mode As String, PC_ID_SName_GName_GNo_TeamName_TeamNo_Mode As String) As String
'Creat StaffManagerArr
    Dim StaffManagerArr As Variant
    Call TBFH103_Call_CreatStaffManagerArr(StaffManagerArr)
'Define CheckColumnNo
    Dim CheckColumnNo As Integer
    Select Case FromPC_FromID_FromName_Mode
        Case "FromPC"
            CheckColumnNo = 0
        Case "FromID"
            CheckColumnNo = 1
        Case "FromName"
            CheckColumnNo = 2
    End Select
'Define ResultColumnNo
    Dim ResultColumnNo As Integer
    Select Case PC_ID_SName_GName_GNo_TeamName_TeamNo_Mode
        Case "PC"
            ResultColumnNo = 0
        Case "ID"
            ResultColumnNo = 1
        Case "SName"
            ResultColumnNo = 2
        Case "GName"
            ResultColumnNo = 3
        Case "GNo"
            ResultColumnNo = 4
        Case "TeamName"
            ResultColumnNo = 5
        Case "TeamNo"
            ResultColumnNo = 6
        Case Else
            Exit Function
    End Select
'Result
    Dim Result As Variant
    Result = HCF4117_VlookupInArr2Dimension_NumberOrString(StaffManagerArr, CheckColumnNo, ResultColumnNo, LookupValue)
    If VarType(Result) &amp;lt;&amp;gt; vbBoolean Then
        TBFH105_GetStaffInformationFromPCNo_StaffID_StaffName = Result
    End If
End Function
Function TBFH106_GetProjectInformationFromProjectName(ProjectName As String, ProjectCode_CustomerName_GNo_TNo_1to12_Mode) As String
'Creat ProjectManagerArr
    Dim ProjectManagerArr As Variant
    Call TBFH107_Call_CreatProjectManagerArr(ProjectManagerArr)
'Define CheckColumnNo
    Dim CheckColumnNo As Integer: CheckColumnNo = 2
'Define ResultColumnNo
    Dim ResultColumnNo As Integer
    Dim Convert2Integer As Variant
    Select Case ProjectCode_CustomerName_GNo_TNo_1to12_Mode
        Case "ProjectCode"
            ResultColumnNo = 0
        Case "CustomerName"
            ResultColumnNo = 1
        Case "GNo"
            ResultColumnNo = 3
        Case "TNo"
            ResultColumnNo = 4
        Case Else
            Convert2Integer = HCF4047_Convert2Integer(ProjectCode_CustomerName_GNo_TNo_1to12_Mode)
            If VarType(Convert2Integer) = vbBoolean Then
                Exit Function
            Else
                If Convert2Integer &amp;lt; 1 Or Convert2Integer &amp;gt; 12 Then
                    Exit Function
                Else
                    ResultColumnNo = Convert2Integer + 4
                End If
            End If
    End Select
'Result
    Dim Result As Variant
    Result = HCF4117_VlookupInArr2Dimension_NumberOrString(ProjectManagerArr, CheckColumnNo, ResultColumnNo, ProjectName)
    If VarType(Result) &amp;lt;&amp;gt; vbBoolean Then
        TBFH106_GetProjectInformationFromProjectName = Result
    End If
End Function
Function TBFH107_Call_CreatProjectManagerArr(ProjectManagerArr As Variant)
    Dim ProjectWS As Worksheet: Set ProjectWS = ThisWorkbook.Sheets(ProjectSheetname)
    ProjectManagerArr = TBFH102_CrearArrFromRange(ProjectWS, "C", "A", "Q", 2)
End Function
Function TBFH108_CheckRangeIsEmpty(WS As Worksheet, RowNo As Integer, ColumnFrom As Integer, ColumnTo As Integer) As Boolean
    Dim RangeValue As String
    Dim EachValue As String
    For i = ColumnFrom To ColumnTo
        EachValue = WS.Cells(RowNo, i).Value
        RangeValue = RangeValue &amp;amp; EachValue
    Next
    If RangeValue = "" Then
        TBFH108_CheckRangeIsEmpty = True
    Else
        TBFH108_CheckRangeIsEmpty = False
    End If
End Function
Function TBFH109_Call_LockUnLockRange(WS As Worksheet, RowFrom As Integer, RowTo As Integer, ColumnLetterFrom As String, ColumnLetterTo As String, LockMode As Boolean)
    Dim LockRange As Range
    Set LockRange = WS.Range(ColumnLetterFrom &amp;amp; RowFrom &amp;amp; ":" &amp;amp; ColumnLetterTo &amp;amp; RowTo)
'unlock all
    WS.Unprotect
    WS.Cells.Locked = False
    LockRange.Locked = LockMode
    WS.Protect
End Function
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Sub TBS100_GetOldDataIntoDatabase()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
'Setting
    Dim ToWB As Workbook: Set ToWB = ThisWorkbook
    Dim ToWS As Worksheet: Set ToWS = ToWB.Sheets(DBSheetname)
    Dim StaffWS As Worksheet: Set StaffWS = ToWB.Sheets(StaffManagerSheetname)
'Creat StaffManagerArr
    Dim StaffManagerArr As Variant
    Call TBFH103_Call_CreatStaffManagerArr(StaffManagerArr)
'Get Files
    Dim GetFiles As Variant
    Dim FileFilter As String: FileFilter = "Excel Files (*.xls),*.xls"
    Dim Title As String: Title = "Choose Excel files"
    Dim MultiSelectMode As Boolean: MultiSelectMode = True
    GetFiles = TBFH100_GetFilePath(FileFilter, Title, True)
    If VarType(GetFiles) = vbBoolean Then GoTo GotoExitSub
    
    Dim FromWSData() As Variant
    Dim FromWSDataRowNo As Integer
For i = LBound(GetFiles) To UBound(GetFiles)
'Open File
    Dim FromWSEachRowData(1 To 40) As String
    Dim FromWBPath As String: FromWBPath = GetFiles(i)
    Dim FromWB As Workbook: Set FromWB = Workbooks.Open(FromWBPath, , True)
    Dim FromWS As Worksheet
    Dim FromSheetname As String
    Dim FromEndRow As Integer
    Dim IsStaffName As Boolean
    Dim MonthValue As String: MonthValue = TBFH104_DefineMonthFromExcelFilePath(FromWBPath): FromWSEachRowData(1) = MonthValue
    Dim GroupValue As String
    Dim TeamValue As String
    Dim StaffID As String
    Dim StaffName As String
    Dim ProjectCode As String
    Dim CustomerName As String
    Dim ProjectName As String
    Dim FromWSEndRow As Integer
    For Each FromWS In FromWB.Sheets
            FromSheetname = FromWS.Name
        'Check FromSheetname is Staff Name
            IsStaffName = HCF4086_IsInArr2Chieu_NumberOrString(StaffManagerArr, 2, FromSheetname)
            If IsStaffName = False Then GoTo GoToExitLoop
            StaffName = FromSheetname
            GroupValue = TBFH105_GetStaffInformationFromPCNo_StaffID_StaffName(StaffName, "FromName", "GNo")
            TeamValue = TBFH105_GetStaffInformationFromPCNo_StaffID_StaffName(StaffName, "FromName", "TeamNo")
            StaffID = TBFH105_GetStaffInformationFromPCNo_StaffID_StaffName(StaffName, "FromName", "ID")
            FromWSEachRowData(2) = GroupValue
            FromWSEachRowData(3) = TeamValue
            FromWSEachRowData(4) = StaffID
            FromWSEachRowData(5) = StaffName
        'Define FromWSEndRow
            Call HCF4079_DefineRowEndNo(FromWS, FromWSEndRow, 34)
            If FromWSEndRow &amp;lt;= 3 Then GoTo GoToExitLoop
            FromWSEndRow = FromWSEndRow - 2
        'Define EachSheetData
            Dim CheckRowValue As String
            For f = 4 To FromWSEndRow
                CheckRowValue = FromWS.Cells(f, 34).Value
                If CheckRowValue &amp;lt;&amp;gt; "" Then
                    ProjectName = FromWS.Cells(f, 2).Value
                    ProjectCode = TBFH106_GetProjectInformationFromProjectName(ProjectName, "ProjectCode")
                    CustomerName = TBFH106_GetProjectInformationFromProjectName(ProjectName, "CustomerName")
                    If CustomerName = "" Then CustomerName = FromWS.Cells(f, 1).Value
                    FromWSEachRowData(6) = ProjectCode
                    FromWSEachRowData(7) = CustomerName
                    FromWSEachRowData(8) = ProjectName
                    For k = 3 To 34
                        FromWSEachRowData(k + 6) = FromWS.Cells(f, k).Value
                    Next
                    ReDim Preserve FromWSData(0 To FromWSDataRowNo)
                    FromWSData(FromWSDataRowNo) = FromWSEachRowData
                    FromWSDataRowNo = FromWSDataRowNo + 1
                End If
            Next
        'Write ChuuKiRan
            Dim ChuuKiRanIsEmpty As Boolean
            Dim ChuuKiRanRowNo As Integer: ChuuKiRanRowNo = FromWSEndRow + 4
            ChuuKiRanIsEmpty = TBFH108_CheckRangeIsEmpty(FromWS, ChuuKiRanRowNo, 3, 34)
            If ChuuKiRanIsEmpty = False Then
                FromWSEachRowData(6) = ""
                FromWSEachRowData(7) = ""
                FromWSEachRowData(8) = FromWS.Cells(ChuuKiRanRowNo, 2).Value
                For k = 3 To 34
                    FromWSEachRowData(k + 6) = FromWS.Cells(ChuuKiRanRowNo, k).Value
                Next
                ReDim Preserve FromWSData(0 To FromWSDataRowNo)
                FromWSData(FromWSDataRowNo) = FromWSEachRowData
                FromWSDataRowNo = FromWSDataRowNo + 1
            End If
        'Write KinTai
            Dim KinTaiRowNo As Integer: KinTaiRowNo = FromWSEndRow + 5
            FromWSEachRowData(6) = ""
            FromWSEachRowData(7) = ""
            FromWSEachRowData(8) = FromWS.Cells(KinTaiRowNo, 2).Value
            For k = 3 To 34
                FromWSEachRowData(k + 6) = FromWS.Cells(KinTaiRowNo, k).Value
            Next
            ReDim Preserve FromWSData(0 To FromWSDataRowNo)
            FromWSData(FromWSDataRowNo) = FromWSEachRowData
            FromWSDataRowNo = FromWSDataRowNo + 1
GoToExitLoop:
    Next
    FromWB.Close False
Next
'Write FromWSData to DataBase
    If FromWSDataRowNo = 0 Then GoTo GotoExitSub
'Define WriteRowFrom
    Dim WriteRowFrom As Integer
    Call HCF4079_DefineRowEndNo(ToWS, WriteRowFrom, 1)
    WriteRowFrom = WriteRowFrom + 1
    Dim EachRowData As Variant
    Dim EachValue As String
    For i = LBound(FromWSData) To UBound(FromWSData)
        EachRowData = FromWSData(i)
        For k = LBound(EachRowData) To UBound(EachRowData)
            EachValue = EachRowData(k)
            If EachValue &amp;lt;&amp;gt; "" Then
                ToWS.Cells(WriteRowFrom, k) = EachRowData(k)
            End If
        Next
        WriteRowFrom = WriteRowFrom + 1
    Next
GotoExitSub:
Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox "Finish"
End Sub


&lt;/LI-CODE&gt;</description>
      <pubDate>Sun, 04 Jul 2021 13:28:38 GMT</pubDate>
      <guid>https://forums.autodesk.com/t5/inventor-programming-ilogic/vba-arrange-dimensions/m-p/10442180#M126103</guid>
      <dc:creator>buianhtuan.cdt</dc:creator>
      <dc:date>2021-07-04T13:28:38Z</dc:date>
    </item>
    <item>
      <title>Re: VBA Arrange Dimensions</title>
      <link>https://forums.autodesk.com/t5/inventor-programming-ilogic/vba-arrange-dimensions/m-p/10444152#M126120</link>
      <description>&lt;LI-CODE lang="markup"&gt;Private Sub ButtonCancel_Click()
    UB_UpdateFromDrawing = ""
    UB_UpdateToDrawing = ""
    Unload Me
End Sub
Private Sub ButtonYes_Click()
    UB_UpdateFromDrawing = CB_UpdateFromDrawing.Value
    UB_UpdateToDrawing = CB_UpdateToDrawing.Value
    Unload Me
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode = vbFormControlMenu Then Cancel = True
End Sub
Private Sub UserForm_Initialize()
    For i = LBound(OpeningFileArr) To UBound(OpeningFileArr)
        CB_UpdateFromDrawing.AddItem OpeningFileArr(i)
    Next
    For i = LBound(OpeningFileArr) To UBound(OpeningFileArr)
        CB_UpdateToDrawing.AddItem OpeningFileArr(i)
    Next
    UpdateBlockV2.Caption = "(TB) Update Block From Other Drawing V2.0"
    CB_UpdateFromDrawing.Value = OpeningFileArr(0)
    CB_UpdateToDrawing.Value = OpeningFileArr(0)
End Sub&lt;/LI-CODE&gt;</description>
      <pubDate>Mon, 05 Jul 2021 12:30:23 GMT</pubDate>
      <guid>https://forums.autodesk.com/t5/inventor-programming-ilogic/vba-arrange-dimensions/m-p/10444152#M126120</guid>
      <dc:creator>buianhtuan.cdt</dc:creator>
      <dc:date>2021-07-05T12:30:23Z</dc:date>
    </item>
  </channel>
</rss>

