Solved: Text in layout with vba

Anonymous · ‎02-06-2015

Hello,

I have a vba program to write text. But all the text is written in modelspace. I need to get the text in a Layoutpaper.

i need to change next code:

Set MTextObj=ThisDrawing.ModelSpace.AddMText(Corner,Width,Text)

i tried

1st fail:

Set MTextObj=ThisDrawing.Layouts.AddMText(Corner,Width,Text)

2th fail:

Set MTextObj=ThisDrawing.Layouts(Layout1).AddMText(Corner,Width,Text)

3th fail:

Set MTextObj=ThisDrawing.Layout1.AddMText(Corner,Width,Text)

So i don't know how to fix it..

Also a other question is : How to pick a textstyle like ( standard, ).

Thanks i hope somebody can help me.

norman.yuan · ‎02-06-2015

The failed 3 tries are very obvious even when you wrote the code in VBA editor: the intellisense tip does not show at all.

and this line of code should give a very obvious hint:

Set MTextObj=ThisDrawing.ModelSpace.AddMText(Corner,Width,Text)

If you want to add something on layout other than ModelSpace, you simply do:

1. set the target layout as current layout (ThisDrawing.ActiveLayout);

2. then use this code:

Set MTextObj=ThisDrawing.PaperSpace.AddMText(Corner,Width,Text)

As for question on TextStyle, you go through ThisDrawing.TextStyles to find a TestStyle, usually by its name. To make newly created Text/MText (by your code) to use particular TextStyle, you can either make a TextStyle as current (ThisDrawing.ActiveTextStyle) so that the newly created Text/MText automatically uses that style, or set Text/MText.StyleName property to a TextStyle's name.

Norman Yuan

Drive CAD With Code

Anonymous · ‎02-09-2015

hello,

When i change modelspace to paperspace it goes to 1 layout. So i get text in Layout1

But i have more layouts( Layout1, Layout 2,Layout3, Layout 4,... How can i change that?

It doesn't work for the textstyle. The textstyle i need is "Border" But i get a error.

Can you give a example please?

Thanks 🙂

kasperwuyts · ‎02-10-2015

Things like text styles, layer names, etc are case sensitive, so be careful to type them exactly as they are.

For the different layouts, you can use this:

For accessing a different layout, you can use the following:

Set MTextObj = ThisDrawing.Layouts.Item(Index).block.AddMText(Corner,Width,Text)

Explanation of what this is:

The 'layouts' object is a collection of the different layouts in your drawing. To get a specific layout, you use the item(index) method. Index is just an integer.

For example, this code should give you the name of your first layout:

msgbox ThisDrawing.Layouts.Item(0).name

To access and modify the actual geometry of a layout object, you use the 'block' property. The block object has all the same methods and properties as the modelspace object. In fact the 'modelspace' and 'paperspace' objects simply are blocks.

Not completely on topic but:

I don't like using the 'paperspace' object as suggested before. It is infact just a shortcut to modify the active layout, which is often very handy, but if you try to do something in modelspace it will use the first layout instead.

Alternatively; instead of 'paperspace', use 'activelayout.block', which works perfectly in modelspace as well.

Best regards
Kasper Wuyts
_______________________________________________________________________________
If this post solves your problem, clicking the 'accept as solution' button would be greatly appreciated.

buianhtuan.cdt · ‎09-23-2021

Function TBFH132_DefineRowNoOfValue(LookupValue As String, WS As Worksheet, ColumnNo As Integer, RowFrom As Integer, RowTo As Integer) As Variant
    Dim ResultRowNo As Integer
    Dim CompareValue As String
    For i = RowFrom To RowTo
        CompareValue = WS.Cells(i, ColumnNo).Value
        If CompareValue = LookupValue Then
            TBFH132_DefineRowNoOfValue = i
            Exit Function
        End If
    Next
    TBFH132_DefineRowNoOfValue = False
End Function
Function ECF1003_SortArr2ChieuZoA(Arr As Variant, SortRowNo As Integer, StringNumberMode As String) As Variant
' Sap xep cac phan tu cua mang theo thu tu tu A den Z

'Check input
    If SortRowNo > UBound(Arr) Then Exit Function
    If UBound(Arr) - LBound(Arr) = 0 Then Exit Function
    Dim TmpArr As Variant
    TmpArr = Arr

    Dim TmpValue As Variant
    Dim SmallValue As Variant
    Dim LargeValue As Variant
    Dim Hoandoi As Boolean
    
    For i = LBound(TmpArr, 1) To UBound(TmpArr, 1)
        For k = i + 1 To UBound(TmpArr, 1)
        Hoandoi = False
        SmallValue = TmpArr(i, SortRowNo)
            LargeValue = TmpArr(k, SortRowNo)
            Select Case StringNumberMode
                Case "String"
                    If StrComp(SmallValue, LargeValue) = -1 Then Hoandoi = True
                Case "Number"
                    If SmallValue < LargeValue Then Hoandoi = True
            End Select
            If Hoandoi = True Then
                For f = LBound(TmpArr, 2) To UBound(TmpArr, 2)
                    SmallValue = TmpArr(i, f)
                    LargeValue = TmpArr(k, f)
                    TmpValue = SmallValue
                    TmpArr(i, f) = LargeValue
                    TmpArr(k, f) = TmpValue
                Next
            End If
        Next
    Next

ECF1003_SortArr2ChieuZoA = TmpArr

End Function
Function ECF1001_Call_ReplaceTextInTextMText(OldNewList() As String, ObjText As AcadEntity, ReplaceCount As Integer)
    Dim EachOldText As String
    Dim EachNewText As String
    Dim OldValue As String
    Dim NewValue As String
    Dim NeedUpdate As Boolean
    
    OldValue = ObjText.TextString
    For i = LBound(OldNewList) To UBound(OldNewList)
        EachOldText = OldNewList(i, 0)
        EachNewText = OldNewList(i, 1)
        If InStr(OldValue, EachOldText) <> 0 Then
            NewValue = Replace(OldValue, EachOldText, EachNewText)
            OldValue = NewValue
            NeedUpdate = True
        End If
    Next
    If NeedUpdate = True Then
        ObjText.TextString = NewValue
        ReplaceCount = ReplaceCount + 1
    End If
End Function
Function ECF1002_Call_ReplaceTextInAttBlockRef(OldNewList() As String, ObjBlockRef As AcadBlockReference, ReplaceCount As Integer)
    Dim EachOldText As String
    Dim EachNewText As String
    Dim NeedUpdate As Boolean
    Dim varAttributes As Variant
    Dim OldValue As String
    Dim NewValue As String
    
    varAttributes = ObjBlockRef.GetAttributes
    For k = LBound(varAttributes) To UBound(varAttributes)
        OldValue = varAttributes(k).TextString
        NeedUpdate = False
        For i = LBound(OldNewList) To UBound(OldNewList)
            EachOldText = OldNewList(i, 0)
            EachNewText = OldNewList(i, 1)
            If InStr(OldValue, EachOldText) <> 0 Then
                NewValue = Replace(OldValue, EachOldText, EachNewText)
                OldValue = NewValue
                NeedUpdate = True
            End If
        Next
        If NeedUpdate = True Then
            varAttributes(k).TextString = NewValue
            ReplaceCount = ReplaceCount + 1
        End If
    Next
End Function
Sub ECS0001_ReplaceTextInModelAndLayout()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
'Khoi dong AutoCad
    Dim Thisdrawing As AcadDocument
    Set Thisdrawing = KhoidongAutoCad()

'Setting sheet lam viec
    Dim WS As Worksheet
    Set WS = ThisWorkbook.Sheets("21ReplaceText")
    
'Define EndRow
    Dim EndRow As Integer
    EndRow = WS.Cells(Rows.Count, 1).End(xlUp).Row
    If EndRow < 2 Then GoTo GTES
    
'Creat RNoArr
    Dim RNo As Integer
    Dim RNoArr() As Integer: Dim aa As Integer
    Dim EachOldText As String
    Dim EachNewText As String
    For RNo = 2 To EndRow
        EachOldText = WS.Cells(RNo, 1).Value
        If Trim(EachOldText) <> "" Then
            ReDim Preserve RNoArr(0 To aa)
            RNoArr(aa) = RNo
            aa = aa + 1
        End If
    Next
    If aa = 0 Then GoTo GTES
    
'Creat OldNewList
    Dim OldNewList() As String
    ReDim OldNewList(aa - 1, 0 To 1)
    For i = 0 To UBound(OldNewList)
        RNo = RNoArr(i)
        OldNewList(i, 0) = WS.Cells(RNo, 1).Value
        OldNewList(i, 1) = WS.Cells(RNo, 2).Value
    Next
    
'Select All Text,MText,Block In ModelSpace And PaperSpace
    Dim EachLayout As AcadLayout
    Dim EachLayoutName As String
    Dim AllSelect As AcadSelectionSet
    Set AllSelect = Thisdrawing.SelectionSets.ADD("AllSelect" & Now)
    Dim FT(7) As Integer:   Dim FD(7) As Variant
    FT(0) = -4:             FD(0) = "<AND"
    FT(1) = -4:             FD(1) = "<OR"
    FT(2) = 0:              FD(2) = "TEXT"
    FT(3) = 0:              FD(3) = "MTEXT"
    FT(4) = 0:              FD(4) = "INSERT"
    FT(5) = -4:             FD(5) = "OR>"
    FT(6) = 410:            FD(6) = "LayoutName"
    FT(7) = -4:             FD(7) = "AND>"
    For Each EachLayout In Thisdrawing.Layouts
        EachLayoutName = EachLayout.Name
        FD(6) = EachLayoutName
        AllSelect.Select acSelectionSetAll, , , FT, FD
    Next
    If AllSelect.Count = 0 Then
        AllSelect.Delete
        GoTo GTES
    End If

'Replace Text
    Dim EachEntity As AcadEntity
    Dim EachBlockRef As AcadBlockReference
    Dim ReplaceCount As Integer
    For Each EachEntity In AllSelect
        Select Case EachEntity.ObjectName
            Case "AcDbText", "AcDbMText"
                Call ECF1001_Call_ReplaceTextInTextMText(OldNewList, EachEntity, ReplaceCount)
            Case "AcDbBlockReference"
                Set EachBlockRef = EachEntity
                If EachBlockRef.HasAttributes = True Then
                    Call ECF1002_Call_ReplaceTextInAttBlockRef(OldNewList, EachBlockRef, ReplaceCount)
                End If
        End Select
    Next
    AllSelect.Delete
GTES:
    MsgBox "Replace " & ReplaceCount & " Text"
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub
Sub ECS0002_Import_ListAttBlockRef()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
'Setting
    Dim ListBlockname As String
    ListBlockname = "HIN1_AS_ENG"
    
'Khoi dong AutoCad
    Dim Thisdrawing As AcadDocument
    Set Thisdrawing = KhoidongAutoCad()

'Setting sheet lam viec
    Dim WS As Worksheet
    Set WS = ThisWorkbook.Sheets("KIX")
    
'Clear Old Data
    WS.Range("A2:O100").ClearContents
    
'Select All ListBlockname in PaperSpace
    Dim EachLayout As AcadLayout
    Dim EachLayoutName As String
    Dim AllSelect As AcadSelectionSet
    Set AllSelect = Thisdrawing.SelectionSets.ADD("AllSelect" & Now)
    Dim FT(4) As Integer:   Dim FD(4) As Variant
    FT(0) = -4:             FD(0) = "<AND"
    FT(1) = 0:              FD(1) = "INSERT"
    FT(2) = 2:              FD(2) = ListBlockname
    FT(3) = 410:            FD(3) = "LayoutName"
    FT(4) = -4:             FD(4) = "AND>"
    For Each EachLayout In Thisdrawing.Layouts
        EachLayoutName = EachLayout.Name
        FD(3) = EachLayoutName
        If EachLayoutName <> "Model" Then
            AllSelect.Select acSelectionSetAll, , , FT, FD
        End If
    Next
    If AllSelect.Count = 0 Then
        AllSelect.Delete
        GoTo GTES
    End If
    
'Creat AttArr
    Dim AttArr() As Variant
    Dim RNo As Integer: RNo = 2
    Dim CNo As Integer
    ReDim AttArr(2 To AllSelect.Count + 1, 0 To 14)
    Dim EachBlockRef As AcadBlockReference
    Dim EachHandle As String
    Dim EachInsertPoint As Variant
    Dim EachInsertPointY As Double
    Dim varAttributes As Variant
    For Each EachBlockRef In AllSelect
        EachInsertPoint = EachBlockRef.InsertionPoint
        EachInsertPointY = Round(EachInsertPoint(1), 1)
        EachHandle = EachBlockRef.Handle
        AttArr(RNo, 0) = EachInsertPointY
        AttArr(RNo, 1) = EachHandle
        varAttributes = EachBlockRef.GetAttributes
        For i = LBound(varAttributes) To UBound(varAttributes)
            AttArr(RNo, i + 2) = varAttributes(i).TextString
        Next
        RNo = RNo + 1
    Next
    AllSelect.Delete
    
'Sort theo Toa do Y tu lon den nho
    AttArr = ECF1003_SortArr2ChieuZoA(AttArr, 0, "Number")
    
'Write AttArr to excel
    Dim EachValue As String
    For RNo = LBound(AttArr, 1) To UBound(AttArr, 1)
        For CNo = 1 To UBound(AttArr, 2)
            EachValue = AttArr(RNo, CNo)
            WS.Cells(RNo, CNo).Value = EachValue
        Next
    Next

GTES:
    MsgBox "Finish"
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub
Sub ECS0003_ExportKIX()
    Application.ScreenUpdating = False
    Application.EnableEvents = False

'Khoi dong AutoCad
    Dim Thisdrawing As AcadDocument
    Set Thisdrawing = KhoidongAutoCad()
    
'Setting sheet lam viec
    Dim WS As Worksheet
    Set WS = ThisWorkbook.Sheets("KIX")

'Define EndRow
    Dim EndRow As Integer
    EndRow = WS.Cells(Rows.Count, 1).End(xlUp).Row
    If EndRow < 2 Then
        GoTo GTES
    End If
    
'Export
    Dim RNo As Integer
    Dim BlockHandle As Variant
    Dim SizeBlock As AcadObject
    Dim varAttributes As Variant
    Dim EachAttValue As String
    For RNo = 2 To EndRow
        BlockHandle = WS.Cells(RNo, 1).Value
        Set SizeBlock = Thisdrawing.HandleToObject(BlockHandle)
        varAttributes = SizeBlock.GetAttributes
        For i = LBound(varAttributes) To UBound(varAttributes)
            EachAttValue = WS.Cells(RNo, i + 2).Value
            varAttributes(i).TextString = EachAttValue
        Next
    Next
GTES:
    MsgBox "Finish"
    Application.ScreenUpdating = True
    Application.EnableEvents = True

End Sub
Sub ECS0004_ConvertPartListDFKtoKIX()
    Application.ScreenUpdating = False
    Application.EnableEvents = False

'Setting sheet lam viec
    Dim DFKWS As Worksheet
    Set DFKWS = ThisWorkbook.Sheets("PARTLIST")
    Dim WS As Worksheet
    Set WS = ThisWorkbook.Sheets("KIX")
    
'Define EndRow
    Dim EndRow As Integer: EndRow = WS.Cells(Rows.Count, 1).End(xlUp).Row
    Dim DFKEndRow As Integer: DFKEndRow = DFKWS.Cells(Rows.Count, 2).End(xlUp).Row
    If EndRow < 2 Or DFKEndRow < 2 Then GoTo GTES

    
'Creat DFKRNoArr
    Dim DFKRNo As Integer
    Dim DFKRNoArr() As Integer: Dim aa As Integer
    Dim EachDFK_PN As String
    Dim EachDFK_MN As String
    For DFKRNo = 2 To DFKEndRow
        EachDFK_PN = DFKWS.Cells(DFKRNo, 1).Value
        EachDFK_MN = DFKWS.Cells(DFKRNo, 2).Value
        If Trim(EachDFK_MN) <> "" Or Trim(EachDFK_PN) <> "" Then
            ReDim Preserve DFKRNoArr(0 To aa)
            DFKRNoArr(aa) = DFKRNo
            aa = aa + 1
        End If
    Next
    If aa = 0 Then GoTo GTES
    
'Creat DFKPartList
    Dim DFKPartList() As String
    ReDim DFKPartList(aa - 1, 0 To 5)
    Dim EachDFK_Des As String
    Dim EachDFK_Material As String
    Dim EachDFK_Unit As String
    Dim EachDFK_MU As String
    For i = 0 To UBound(DFKPartList)
        DFKRNo = DFKRNoArr(i)
        EachDFK_PN = DFKWS.Cells(DFKRNo, 1).Value
        EachDFK_MN = DFKWS.Cells(DFKRNo, 2).Value
        EachDFK_Des = DFKWS.Cells(DFKRNo, 3).Value
        EachDFK_Material = DFKWS.Cells(DFKRNo, 4).Value
        EachDFK_Unit = DFKWS.Cells(DFKRNo, 6).Value
        EachDFK_MU = DFKWS.Cells(DFKRNo, 9).Value
        
        DFKPartList(i, 0) = EachDFK_PN
        DFKPartList(i, 1) = EachDFK_MN
        DFKPartList(i, 2) = EachDFK_Des
        DFKPartList(i, 3) = EachDFK_Material
        DFKPartList(i, 4) = EachDFK_Unit
        DFKPartList(i, 5) = EachDFK_MU
    Next

'Convert DFKPartList to KIXPartList
    Dim KIXPartList() As String
    ReDim KIXPartList(aa - 1, 2 To 14)
    Dim EachKIX_PN As String
    Dim EachKIX_MN As String
    Dim EachKIX_NAME As String
    Dim EachKIX_TYPE As String
    Dim EachKIX_MAKER As String
    Dim EachKIX_MU As String
    Dim EachKIX_QU As String
    For i = 0 To UBound(KIXPartList)
        EachDFK_PN = DFKPartList(i, 0)
        EachDFK_MN = DFKPartList(i, 1)
        EachDFK_Des = DFKPartList(i, 2)
        EachDFK_Material = DFKPartList(i, 3)
        EachDFK_Unit = DFKPartList(i, 4)
        EachDFK_MU = DFKPartList(i, 5)
        
        EachKIX_PN = EachDFK_PN
        EachKIX_MN = EachDFK_MN
        If EachKIX_MN <> "" Then
            EachKIX_NAME = Before_(EachDFK_Des, "-")
            EachKIX_TYPE = After_(EachDFK_Des, "-")
        Else
            EachKIX_NAME = ""
            EachKIX_TYPE = ""
        End If
        EachKIX_MAKER = EachDFK_Material
        EachKIX_MU = EachDFK_MU
        EachKIX_QU = EachDFK_Unit
        
        KIXPartList(i, 2) = EachKIX_PN
        KIXPartList(i, 3) = EachKIX_MN
        KIXPartList(i, 4) = EachKIX_NAME
        KIXPartList(i, 😎 = EachKIX_TYPE
        KIXPartList(i, 9) = EachKIX_MAKER
        KIXPartList(i, 12) = EachKIX_MU
        KIXPartList(i, 13) = EachKIX_QU
    Next
    
'Write to WS
    Dim GetWriteRow As Variant
    Dim WriteRNo As Integer
    Dim CNo As Integer
    For i = 0 To UBound(KIXPartList)
        EachKIX_PN = KIXPartList(i, 2)
        EachKIX_MN = KIXPartList(i, 3)
    'Case Part
        If EachKIX_PN <> "" Then
            GetWriteRow = TBFH132_DefineRowNoOfValue(EachKIX_PN, WS, 2, 2, EndRow)
            If VarType(GetWriteRow) <> vbBoolean Then
                WriteRNo = GetWriteRow
                WS.Cells(WriteRNo, 12).Value = KIXPartList(i, 12)
                WS.Cells(WriteRNo, 13).Value = KIXPartList(i, 13)
            End If
        End If
    'Case Mate
        If EachKIX_MN <> "" Then
            GetWriteRow = TBFH132_DefineRowNoOfValue(EachKIX_MN, WS, 3, 2, EndRow)
            If VarType(GetWriteRow) <> vbBoolean Then
                WriteRNo = GetWriteRow
                For CNo = 2 To 14
                    WS.Cells(WriteRNo, CNo).Value = KIXPartList(i, CNo)
                Next
            End If
        End If
    Next
GTES:
    MsgBox "Finish"
    Application.ScreenUpdating = True
    Application.EnableEvents = True

End Sub

buianhtuan.cdt · ‎09-26-2021

'Setting PublicLayerName
    Public Pb01_NormalLayerName As String
    Public Pb02_SlimLayerName As String
    Public Pb03_BoldLayerName As String
    Public Pb04_HiddenLayerName As String
    Public Pb05_CenterLayerName As String
    Public Pb06_PhantomLayerName As String
    Public Pb07_TextLayerName As String
    Public Pb08_DimLayerName As String
    Public Pb09_DefpointsLayerName As String
    Public Pb11_ZigzagLayerName As String
    Public Pb12_DraftLayerName As String
    Public Pb13_HatchLayerName As String
    Public Pb14_DotLayerName As String
    Public Pb15_SpecialLayerName As String
    Public Pb16_FrameLayerName As String
    Public Pb17_BlankLayerName As String
    Public Pb18_Layer08 As String
    Public Pb19_Layer09 As String
    Public Pb20_Layer20 As String
'Setting LayerName And Color of MIn,MOut
    Dim Pb21_MOutLayername As String
    Dim Pb22_MInLayername As String
    Dim Pb23_MOutColor As AcColor
    Dim Pb24_MInColor As AcColor
Function HCF4196_GetPoint(MyDrawing As AcadDocument, StrMsg As String) As Variant
    On Error Resume Next
    Dim Point As Variant
    Point = False
    Point = MyDrawing.Utility.GetPoint(, vbCr & StrMsg)
    If VarType(Point) = vbBoolean Then
        HCF4196_GetPoint = False
    Else
        HCF4196_GetPoint = Point
    End If
End Function
Function HCF4197_GetSecondPoint(MyDrawing As AcadDocument, Point1 As Variant, StrMsg As String) As Variant
    HCF4197_GetSecondPoint = False
    On Error GoTo ExitFunc
    Dim Point As Variant
    Point = MyDrawing.Utility.GetPoint(Point1, vbCr & StrMsg)
    HCF4197_GetSecondPoint = Point
ExitFunc:
End Function
Function HCF4179_SetPublicLayerName()
Select Case ProjectName
    Case "KKS"
        Pb01_NormalLayerName = KKS_NormalLayerName
        Pb02_SlimLayerName = KKS_SlimLayerName
        Pb03_BoldLayerName = KKS_BoldLayerName
        Pb04_HiddenLayerName = KKS_HiddenLayerName
        Pb05_CenterLayerName = KKS_CenterLayerName
        Pb06_PhantomLayerName = KKS_PhantomLayerName
        Pb07_TextLayerName = KKS_TextLayerName
        Pb08_DimLayerName = KKS_DimLayerName
        Pb09_DefpointsLayerName = KKS_DefpointsLayerName
        Pb11_ZigzagLayerName = KKS_ZigzagLayerName
        Pb12_DraftLayerName = KKS_DraftLayerName
        Pb13_HatchLayerName = KKS_HatchLayerName
        Pb14_DotLayerName = KKS_DotLayerName
        Pb15_SpecialLayerName = KKS_SpecialLayerName
        Pb16_FrameLayerName = KKS_FrameLayerName
        Pb17_BlankLayerName = KKS_BlankLayerName
        Pb18_Layer08 = "ABCDEF"
        Pb19_Layer09 = "ABCDEF"
        Pb20_Layer20 = "ABCDEF"
    Case "DFK"
        Pb01_NormalLayerName = DFK_NormalLayerName
        Pb02_SlimLayerName = "ABCDEF"
        Pb03_BoldLayerName = "ABCDEF"
        Pb04_HiddenLayerName = DFK_HiddenLayerName
        Pb05_CenterLayerName = DFK_CenterLayerName
        Pb06_PhantomLayerName = DFK_PhantomLayerName
        Pb07_TextLayerName = DFK_TextLayerName
        Pb08_DimLayerName = DFK_DimLayerName
        Pb09_DefpointsLayerName = DFK_DefpointsLayerName
        Pb11_ZigzagLayerName = "ABCDEF"
        Pb12_DraftLayerName = "ABCDEF"
        Pb13_HatchLayerName = "ABCDEF"
        Pb14_DotLayerName = "ABCDEF"
        Pb15_SpecialLayerName = "ABCDEF"
        Pb16_FrameLayerName = "ABCDEF"
        Pb17_BlankLayerName = "ABCDEF"
        Pb18_Layer08 = "ABCDEF"
        Pb19_Layer09 = "ABCDEF"
        Pb20_Layer20 = "ABCDEF"
End Select
End Function

Function HCF4190_CallSetting_LayerNameAndColorOfMInMOut()
    Select Case ProjectName
        Case "KKS"
            Pb21_MOutLayername = KKS_SlimLayerName
            Pb22_MInLayername = "0"
            Pb23_MOutColor = acByLayer
            Pb24_MInColor = acByLayer
        Case "DFK"
            Pb21_MOutLayername = "0"
            Pb22_MInLayername = "0"
            Pb23_MOutColor = acYellow
            Pb24_MInColor = acByLayer
    End Select
End Function
Function HCF4191_Call_ChangeLayerMOfSelectSet(objSelectOnScreen As AcadSelectionSet)
'Creat Circle Arr and CenterPointArr
    Dim CircleArr As Variant
    Dim CenterPointArr As Variant
    CircleArr = HCF4075_CreatCircleObjArrInSelectSet(objSelectOnScreen, True)
    If VarType(CircleArr) = vbBoolean Then Exit Function
    CenterPointArr = HCF4064_CreatCenterPointArrFromCircleArr(CircleArr)
'Creat ConcentricArr
    Dim ConcentricArr As Variant
    Dim CenterPoint As Variant
    Dim EachConcentricArr() As Variant
    Dim EachCircle As AcadCircle
    Dim EachCenterPoint As Variant
    Dim EachDistance As Double
    Dim f As Integer
    ReDim ConcentricArr(0 To UBound(CenterPointArr))
    For i = LBound(ConcentricArr) To UBound(ConcentricArr)
        CenterPoint = CenterPointArr(i)
        f = 0
        ReDim EachConcentricArr(0)
        For k = LBound(CircleArr) To UBound(CircleArr)
            Set EachCircle = CircleArr(k)
            If EachCircle.Visible = True Then
                EachDistance = HCF4122_DistanceFromPoint2CircleCenter(CenterPoint, EachCircle, 1)
                If EachDistance = 0 Then
                    ReDim Preserve EachConcentricArr(0 To f)
                    Set EachConcentricArr(f) = EachCircle
                    EachCircle.Visible = False
                    f = f + 1
                End If
            End If
        Next
        If f > 0 Then
            Call HCF4123_Call_SortCircleArrByDiameter_Large2Small(EachConcentricArr)
            ConcentricArr(i) = EachConcentricArr
        End If
    Next
 'Visible obj
    Call HCF4078_VisibleObjInSelectSet(objSelectOnScreen, True)
'Change Layer and color
    Dim MOutCircle As AcadCircle
    Dim MInCircle As AcadCircle
    Dim Dia As Double
    Dim IsMSize As Boolean
    For i = LBound(ConcentricArr) To UBound(ConcentricArr)
        EachConcentricArr = ConcentricArr(i)
        If UBound(EachConcentricArr) = 1 Then
            Set MOutCircle = EachConcentricArr(0)
            Set MInCircle = EachConcentricArr(1)
            Dia = MOutCircle.Diameter
            IsMSize = HCF4124_IsMSize(Dia)
            If IsMSize = True Then
                MOutCircle.Layer = Pb21_MOutLayername
                MOutCircle.Color = Pb23_MOutColor
                MInCircle.Layer = Pb22_MInLayername
                MInCircle.Color = Pb24_MInColor
            End If
        End If
    Next
End Function
Function HCF4192_Call_GetMinMaxPointFromSelectedBlockRefOrFromUser(MinPoint As Variant, MaxPoint As Variant)
'Defaut Value
    MinPoint = False
    MaxPoint = False
'Get MinMaxPoint From Selected BlockRef
    Dim GetObj() As Variant
    Dim Obj As AcadEntity
    Dim ObjBlockRef As AcadBlockReference
    Dim GetMinMaxPoint As Variant
    GetObj = HCF4059_GetObj(Thisdrawing, "Select Obj to define MinPoint and MaxPoint For Arrange Dimension:")
    If GetObj(0) <> False Then
        Set Obj = GetObj(1)
        If Obj.ObjectName = "AcDbBlockReference" Then
            Set ObjBlockRef = Obj
            GetMinMaxPoint = HCF4160_LimitPointOfBlockRef(ObjBlockRef)
            If VarType(GetMinMaxPoint) <> vbBoolean Then
                MinPoint = GetMinMaxPoint(0)
                MaxPoint = GetMinMaxPoint(1)
                Exit Function
            End If
        End If
    End If
'Get Point From User
    Dim Get2Point As Variant
    Dim MsgPoint1 As String: MsgPoint1 = "Select MinPoint for define limit:"
    Dim MsgPoint2 As String: MsgPoint2 = "Select MaxPoint for define limit:"
    Dim OsmodePoint1 As Integer: OsmodePoint1 = 105         'EndPoint,Node,Intersection,Insertion
    Dim OsmodePoint2 As Integer: OsmodePoint2 = 105         'EndPoint,Node,Intersection,Insertion
    Get2Point = HCF4162_Get2PointWithOSMODE(MsgPoint1, MsgPoint2, OsmodePoint1, OsmodePoint2, True)
    If VarType(Get2Point) = vbBoolean Then
        Exit Function
    Else
        MinPoint = Get2Point(0)
        MaxPoint = Get2Point(1)
    End If
'Confirm MinPoint, MaxPoint
    Call HCF4164_Call_MinPointMaxPointFrom2Point(MinPoint, MaxPoint)
End Function
Function HCF4193_DefineDimPoint00FromOrdinateDimArr(DimPoint00 As Variant, OrdinateDimArr As Variant)
'Defaut Value
    DimPoint00 = False

'Check OrdinateDimSS and Creat OD00Arr
    Dim OD00Arr() As AcadDimOrdinate: Dim aa As Integer
    Dim EachEntity As AcadDimOrdinate
    For i = LBound(OrdinateDimArr) To UBound(OrdinateDimArr)
        Set EachEntity = OrdinateDimArr(i)
        If Round(EachEntity.Measurement, 2) = 0 Then
            ReDim Preserve OD00Arr(0 To aa)
            Set OD00Arr(aa) = EachEntity
            aa = aa + 1
        End If
    Next
    If aa <> 2 Then Exit Function
    
'Define X0DimObj Y0DimObj
    Dim X0DimObj As Variant: X0DimObj = False
    Dim Y0DimObj As Variant: Y0DimObj = False
    Dim ODObj As AcadDimOrdinate
    Dim XorY As String
    Dim MinPoint As Variant
    Dim MaxPoint As Variant
    Dim DeltaX As Double
    Dim DeltaY As Double
    For i = LBound(OD00Arr) To UBound(OD00Arr)
        Set ODObj = OD00Arr(i)
        ODObj.GetBoundingBox MinPoint, MaxPoint
        DeltaX = MaxPoint(0) - MinPoint(0)
        DeltaY = MaxPoint(1) - MinPoint(1)
        If DeltaX >= DeltaY Then
            XorY = "Y"
        Else
            XorY = "X"
        End If
        Select Case XorY
            Case "X"
                Set X0DimObj = ODObj
            Case "Y"
                Set Y0DimObj = ODObj
        End Select
    Next
    If VarType(X0DimObj) = vbBoolean Or VarType(Y0DimObj) = vbBoolean Then Exit Function

'Define Point00()
    Dim Point00(0 To 2) As Double
    Dim X0Value As Double
    Dim Y0Value As Double
    Call HCF4194_Call_DefineX0ValueFromX0DimObj(X0DimObj, X0Value)
    Call HCF4195_Call_DefineY0ValueFromY0DimObj(Y0DimObj, Y0Value)
    Point00(0) = X0Value
    Point00(1) = Y0Value
    DimPoint00 = Point00
    
End Function

Function HCF4194_Call_DefineX0ValueFromX0DimObj(X0DimObj As Variant, X0Value As Double)

'Copy Obj
    Dim CopyX0DimObj As AcadDimOrdinate
    Set CopyX0DimObj = X0DimObj.Copy
    CopyX0DimObj.Visible = False
    
'Define X0Value
    Dim BeforeTextPosion As Variant
    Dim AfterTextPosition As Variant
    Dim Pi As Double: Pi = 4 * Atn(1)
    Dim MinPoint As Variant
    Dim MaxPoint As Variant
    BeforeTextPosion = CopyX0DimObj.TextPosition
    AfterTextPosition = Thisdrawing.Utility.PolarPoint(BeforeTextPosion, Pi, 10000)
    AfterTextPosition = Thisdrawing.Utility.PolarPoint(AfterTextPosition, -Pi / 2, 10000)
    CopyX0DimObj.TextPosition = AfterTextPosition
    CopyX0DimObj.GetBoundingBox MinPoint, MaxPoint
    X0Value = MaxPoint(0)

'Delete Copy
    CopyX0DimObj.Delete

End Function
Function HCF4195_Call_DefineY0ValueFromY0DimObj(Y0DimObj As Variant, Y0Value As Double)

'Copy Obj
    Dim CopyY0DimObj As AcadDimOrdinate
    Set CopyY0DimObj = Y0DimObj.Copy
    CopyY0DimObj.Visible = False
    
'Define Y0Value
    Dim BeforeTextPosion As Variant
    Dim AfterTextPosition As Variant
    Dim Pi As Double: Pi = 4 * Atn(1)
    Dim MinPoint As Variant
    Dim MaxPoint As Variant
    BeforeTextPosion = CopyY0DimObj.TextPosition
    AfterTextPosition = Thisdrawing.Utility.PolarPoint(BeforeTextPosion, -Pi / 2, 10000)
    CopyY0DimObj.TextPosition = AfterTextPosition
    CopyY0DimObj.GetBoundingBox MinPoint, MaxPoint
    Y0Value = MaxPoint(1)
    
'Delete Copy
    CopyY0DimObj.Delete

End Function
Function HCF4198X_01_Call_GetPitchAndDeepOfRenNhuyen(Suffix As String, Pitch_PitchDepth_Mode As String)

'Get Pitch
    Dim GetStr As Variant
    Dim Pitch As String
    GetStr = HCF4049_GetString(Thisdrawing, False, "Thread Pitch(*.*=)", False)
    If VarType(GetStr) <> vbBoolean Then
        Pitch = GetStr
        Suffix = Replace(Suffix, "*.*", Pitch)
    End If
    If Pitch_PitchDepth_Mode <> "PitchDepth" Then Exit Function
    
'Get Deep From User
    Dim Depth As Double
    Dim GetDepth As Boolean
    Dim Osmode As Integer: Osmode = 35      'EndPoint,MiddlePoint,Intersection
    Dim Msg As String: Msg = "Thread Depth="
    GetDepth = HCF4204_GetDistanceWithOsmode_DimLfac(Depth, Osmode, Msg, 1)
    If GetDepth = True Then
        Suffix = Replace(Suffix, "aaa", Depth)
    Else
        Suffix = Replace(Suffix, "aaa", "***")
    End If
    
End Function
Function HCF4198X_02_Call_KKS_CreatHoleArr(HoleArr() As String)
    ReDim HoleArr(1 To 15, 0 To 4)
    HoleArr(1, 0) = 1:    HoleArr(1, 1) = "穴":         HoleArr(1, 2) = "%%C":    HoleArr(1, 3) = ""
    HoleArr(2, 0) = 2:    HoleArr(2, 1) = "キリ":       HoleArr(2, 2) = "":       HoleArr(2, 3) = "キリ"
    HoleArr(3, 0) = 3:    HoleArr(3, 1) = "M":          HoleArr(3, 2) = "M":      HoleArr(3, 3) = ""
    HoleArr(4, 0) = 4:    HoleArr(4, 1) = "M深2D":      HoleArr(4, 2) = "M":      HoleArr(4, 3) = "深aaa"
    HoleArr(5, 0) = 5:    HoleArr(5, 1) = "M貫通":      HoleArr(5, 2) = "M":      HoleArr(5, 3) = "貫通"
    HoleArr(6, 0) = 6:    HoleArr(6, 1) = "M深*下穴深*": HoleArr(6, 2) = "M":     HoleArr(6, 3) = "深aaa\X下穴深bbb"
    HoleArr(7, 0) = 7:    HoleArr(7, 1) = "M細目":      HoleArr(7, 2) = "M":      HoleArr(7, 3) = "xP*.*(細目)"
    HoleArr(8, 0) = 8:    HoleArr(8, 1) = "M細目深*":   HoleArr(8, 2) = "M":      HoleArr(8, 3) = "xP*.*(細目)深aaa"
    HoleArr(9, 0) = 9:    HoleArr(9, 1) = "ザグリ":     HoleArr(9, 2) = "":       HoleArr(9, 3) = "キリ\X%%Caaaザグリ深bbb"
    HoleArr(10, 0) = 10:  HoleArr(10, 1) = "モミサラ":  HoleArr(10, 2) = "":      HoleArr(10, 3) = "キリ\X%%Caaaサラモミ深0.5"
    HoleArr(11, 0) = 11:  HoleArr(11, 1) = "H7":        HoleArr(11, 2) = "%%C":   HoleArr(11, 3) = "H7"
    HoleArr(12, 0) = 12:  HoleArr(12, 1) = "H7深*":     HoleArr(12, 2) = "%%C":   HoleArr(12, 3) = "H7深aaa"
    HoleArr(13, 0) = 13:  HoleArr(13, 1) = "H8深*":     HoleArr(13, 2) = "%%C":   HoleArr(13, 3) = "H8深aaa"
    HoleArr(14, 0) = 14:  HoleArr(14, 1) = "PCD":       HoleArr(14, 2) = "P.C.D.": HoleArr(14, 3) = ""
    HoleArr(15, 0) = 15:  HoleArr(15, 1) = "Rc":        HoleArr(15, 2) = "":      HoleArr(15, 3) = ""

End Function
Function HCF4198X_03_Call_KKS_CreatNoteArr(NoteArr() As String)
    ReDim NoteArr(1 To 9, 0 To 2)
    NoteArr(1, 0) = 1:  NoteArr(1, 1) = "BACK SIDE":            NoteArr(1, 2) = "\X(裏側より)"
    NoteArr(2, 0) = 2:  NoteArr(2, 1) = "INLET C0.5":           NoteArr(2, 2) = "\X口元C0.5"
    NoteArr(3, 0) = 3:  NoteArr(3, 1) = "INOUTLET C0.5":        NoteArr(3, 2) = "\X両口元C0.5"
    NoteArr(4, 0) = 4:  NoteArr(4, 1) = "OUTLET C0.5":          NoteArr(4, 2) = "\X裏側口元C0.5"
    NoteArr(5, 0) = 5:  NoteArr(5, 1) = "INLET C0.5,BACK SIDE": NoteArr(5, 2) = "\X口元C0.5\P(裏側より)"
    NoteArr(6, 0) = 6:  NoteArr(6, 1) = "下穴深**":             NoteArr(6, 2) = "\X下穴深**"
    NoteArr(7, 0) = 7:  NoteArr(7, 1) = "下穴貫通不可":         NoteArr(7, 2) = "\X(下穴貫通不可)"
    NoteArr(8, 0) = 8:  NoteArr(8, 1) = "下穴貫通":             NoteArr(8, 2) = "\X(下穴貫通)"
    NoteArr(9, 0) = 9:  NoteArr(9, 1) = "等配":                 NoteArr(9, 2) = "\X(等配)"
End Function
Function HCF4198X_04_Call_KKS_CreatCBArr(CBArr() As String)
    '(M* Type*,d,D,H)
    ReDim CBArr(0 To 28, 0 To 3)
    CBArr(0, 0) = "M3 TYPE1":   CBArr(0, 1) = "3.3":    CBArr(0, 2) = "6.5":    CBArr(0, 3) = "3.3"
    CBArr(1, 0) = "M4 TYPE1":   CBArr(1, 1) = "4.5":    CBArr(1, 2) = "8":      CBArr(1, 3) = "4.4"
    CBArr(2, 0) = "M5 TYPE1":   CBArr(2, 1) = "5.7":    CBArr(2, 2) = "9.5":    CBArr(2, 3) = "5.4"
    CBArr(3, 0) = "M6 TYPE1":   CBArr(3, 1) = "6.8":    CBArr(3, 2) = "11":     CBArr(3, 3) = "6.5"
    CBArr(4, 0) = "M8 TYPE1":   CBArr(4, 1) = "8.6":    CBArr(4, 2) = "14":     CBArr(4, 3) = "8.6"
    CBArr(5, 0) = "M10 TYPE1":  CBArr(5, 1) = "11":     CBArr(5, 2) = "17.5":   CBArr(5, 3) = "10.8"
    CBArr(6, 0) = "M12 TYPE1":  CBArr(6, 1) = "14":     CBArr(6, 2) = "20":     CBArr(6, 3) = "13"
    CBArr(7, 0) = "M16 TYPE1":  CBArr(7, 1) = "18":     CBArr(7, 2) = "26":     CBArr(7, 3) = "17.5"
    CBArr(8, 0) = "M20 TYPE1":  CBArr(8, 1) = "22":     CBArr(8, 2) = "32":     CBArr(8, 3) = "21.5"
    
    CBArr(10, 0) = "M3 TYPE2":  CBArr(10, 1) = "3.3":   CBArr(10, 2) = "6.5":   CBArr(10, 3) = "4.5"
    CBArr(11, 0) = "M4 TYPE2":  CBArr(11, 1) = "4.5":   CBArr(11, 2) = "8.5":   CBArr(11, 3) = "5.5"
    CBArr(12, 0) = "M5 TYPE2":  CBArr(12, 1) = "5.7":   CBArr(12, 2) = "10":    CBArr(12, 3) = "7"
    CBArr(13, 0) = "M6 TYPE2":  CBArr(13, 1) = "6.8":   CBArr(13, 2) = "13":    CBArr(13, 3) = "8"
    CBArr(14, 0) = "M8 TYPE2":  CBArr(14, 1) = "8.6":   CBArr(14, 2) = "17":    CBArr(14, 3) = "10.5"
    CBArr(15, 0) = "M10 TYPE2": CBArr(15, 1) = "11":    CBArr(15, 2) = "20":    CBArr(15, 3) = "13.5"
    CBArr(16, 0) = "M12 TYPE2": CBArr(16, 1) = "14":    CBArr(16, 2) = "22":    CBArr(16, 3) = "16"
    CBArr(17, 0) = "M16 TYPE2": CBArr(17, 1) = "18":    CBArr(17, 2) = "30":    CBArr(17, 3) = "21"
    CBArr(18, 0) = "M20 TYPE2": CBArr(18, 1) = "22":    CBArr(18, 2) = "35":    CBArr(18, 3) = "26.5"
    
    CBArr(20, 0) = "M3 TYPE3":  CBArr(20, 1) = "3.3":   CBArr(20, 2) = "9.5":   CBArr(20, 3) = "5"
    CBArr(21, 0) = "M4 TYPE3":  CBArr(21, 1) = "4.5":   CBArr(21, 2) = "11":    CBArr(21, 3) = "6.3"
    CBArr(22, 0) = "M5 TYPE3":  CBArr(22, 1) = "5.7":   CBArr(22, 2) = "14":    CBArr(22, 3) = "8"
    CBArr(23, 0) = "M6 TYPE3":  CBArr(23, 1) = "6.8":   CBArr(23, 2) = "15":    CBArr(23, 3) = "9.6"
    CBArr(24, 0) = "M8 TYPE3":  CBArr(24, 1) = "8.6":   CBArr(24, 2) = "20":    CBArr(24, 3) = "12.1"
    CBArr(25, 0) = "M10 TYPE3": CBArr(25, 1) = "11":    CBArr(25, 2) = "25":    CBArr(25, 3) = "15.5"
    CBArr(26, 0) = "M12 TYPE3": CBArr(26, 1) = "14":    CBArr(26, 2) = "30":    CBArr(26, 3) = "18.5"
    CBArr(27, 0) = "M16 TYPE3": CBArr(27, 1) = "18":    CBArr(27, 2) = "36":    CBArr(27, 3) = "24"
    CBArr(28, 0) = "M20 TYPE3": CBArr(28, 1) = "22":    CBArr(28, 2) = "44":    CBArr(28, 3) = "29.5"

End Function
Function HCF4198X_05_Call_KKS_CreatCSArr(CSArr() As String)
    '(M*,d,D)
    ReDim CSArr(0 To 5, 0 To 2)
    CSArr(0, 0) = "M3":     CSArr(0, 1) = "3.3":    CSArr(0, 2) = "6.5"
    CSArr(1, 0) = "M4":     CSArr(1, 1) = "4.5":    CSArr(1, 2) = "8.6"
    CSArr(2, 0) = "M5":     CSArr(2, 1) = "5.7":    CSArr(2, 2) = "10.6"
    CSArr(3, 0) = "M6":     CSArr(3, 1) = "6.8":    CSArr(3, 2) = "12.6"
    CSArr(4, 0) = "M8":     CSArr(4, 1) = "8.6":    CSArr(4, 2) = "17"
    CSArr(5, 0) = "M10":    CSArr(5, 1) = "11":     CSArr(5, 2) = "21"
End Function
Function HCF4198X_06_Call_GetDepth(Suffix As String)
'Get Deep From User
    Dim Depth As Double
    Dim GetDepth As Boolean
    Dim Osmode As Integer: Osmode = 35      'EndPoint,MiddlePoint,Intersection
    Dim Msg As String: Msg = "Thread Depth="
    GetDepth = HCF4204_GetDistanceWithOsmode_DimLfac(Depth, Osmode, Msg, 1)
    If GetDepth = True Then
        Suffix = Replace(Suffix, "aaa", Depth)
    Else
        Suffix = Replace(Suffix, "aaa", "***")
    End If
End Function
Function HCF4198X_07_Call_CouterSink(Suffix As String, Diameter1 As Double, CSArr As Variant)
    Dim GetVlookup As Variant
    Dim CounterSink_Dia1 As String: CounterSink_Dia1 = CStr(Diameter1)
    Dim CounterSink_Dia2 As String
'Define Dia2
    GetVlookup = HCF4117_VlookupInArr2Dimension_NumberOrString(CSArr, 1, 2, CounterSink_Dia1)
    If VarType(GetVlookup) = vbBoolean Then
        Suffix = Replace(Suffix, "aaa", "***")
    Else
        CounterSink_Dia2 = GetVlookup
        Suffix = Replace(Suffix, "aaa", CounterSink_Dia2)
    End If
End Function
Function HCF4198X_08_Call_CouterBore(Suffix As String, CenterPoint As Variant, Diameter1 As Double, CBArr As Variant)
'Get Dia2
    Dim D2Point As Variant
    Dim D2PointMsg As String: D2PointMsg = "Select Diameter 2 Point of CounterBore Hole:"
    Dim Radius As Double
    Dim Diameter2 As Double
    Call HCF4113_SettingOsnap("Nearest", "")
    D2Point = HCF4197_GetSecondPoint(Thisdrawing, CenterPoint, D2PointMsg)
    If VarType(D2Point) = vbBoolean Then
        Suffix = Replace(Suffix, "aaa", "***")
        Suffix = Replace(Suffix, "bbb", "***")
        Exit Function
    Else
        Radius = Func20LengthLineThrough2Point(CenterPoint, D2Point)
        Diameter2 = Round(2 * Radius, 1)
    End If
    
'Define CounterBoreDepth
    Dim GetVlookup As Variant
    Dim CounterBore_Dia1 As String: CounterBore_Dia1 = CStr(Diameter1)
    Dim CounterBore_Dia2 As String: CounterBore_Dia2 = CStr(Diameter2)
    Dim CounterBore_Depth As String

    For i = LBound(CBArr) To UBound(CBArr)
        If CBArr(i, 1) = CounterBore_Dia1 And CBArr(i, 2) = CounterBore_Dia2 Then
            CounterBore_Depth = CBArr(i, 3)
            Suffix = Replace(Suffix, "aaa", CounterBore_Dia2)
            Suffix = Replace(Suffix, "bbb", CounterBore_Depth)
            Exit Function
        End If
    Next
    Suffix = Replace(Suffix, "aaa", "***")
    Suffix = Replace(Suffix, "bbb", "***")
End Function
Function HCF4198X_09_Call_AddNote(Prefix As String, Suffix As String, Note As String)
'Add Note to Suffix
    If InStr(Suffix, "\X") = 0 Then
        If InStr(Note, "\P") = 0 Then
            Suffix = Suffix & Note
        Else
            Prefix = "\P" & Prefix
            Suffix = Suffix & Note
        End If
    Else
        If InStr(Note, "\P") = 0 Then
            Prefix = "\P" & Prefix
            Note = Replace(Note, "\X", "\P")
            Suffix = Suffix & Note
        Else
            Prefix = "\P" & "\P" & Prefix
            Note = Replace(Note, "\X", "\P")
            Suffix = Suffix & Note
        End If
    End If
End Function
Function HCF4198X_10_Call_GetDepthDepth(Suffix As String)
'Get MDeep From User
    Dim MDepth As Double
    Dim GetDepth As Boolean
    Dim Osmode As Integer: Osmode = 35      'EndPoint,MiddlePoint,Intersection
    Dim MsgM As String: MsgM = "Thread Depth="
    GetDepth = HCF4204_GetDistanceWithOsmode_DimLfac(MDepth, Osmode, MsgM, 1)
    If GetDepth = True Then
        Suffix = Replace(Suffix, "aaa", MDepth)
    Else
        Suffix = Replace(Suffix, "aaa", "***")
    End If
    
'Get SitaAna Depth From User
    Dim SitaDepth As Double
    Dim MsgSita As String: MsgSita = "Sita Ana Depth="
    GetDepth = HCF4204_GetDistanceWithOsmode_DimLfac(SitaDepth, Osmode, MsgSita, 1)
    If GetDepth = True Then
        Suffix = Replace(Suffix, "bbb", SitaDepth)
    Else
        Suffix = Replace(Suffix, "bbb", "***")
    End If
End Function
Function HCF4198X_11_Call_Rc(TextOverride As String, strQty As String)
'Set RcArr
    ReDim RcArr(1 To 6, 0 To 1)
    RcArr(1, 0) = 1:    RcArr(1, 1) = "Rc1/16"
    RcArr(2, 0) = 2:    RcArr(2, 1) = "Rc1/8"
    RcArr(3, 0) = 3:    RcArr(3, 1) = "Rc1/4"
    RcArr(4, 0) = 4:    RcArr(4, 1) = "Rc3/8"
    RcArr(5, 0) = 5:    RcArr(5, 1) = "Rc1/2"
    RcArr(6, 0) = 6:    RcArr(6, 1) = "Rc3/4"

'Creat RcArrMsg
    Dim RcArrMsg As String
    Dim EachMsg As String
    For i = LBound(RcArr) To UBound(RcArr)
        EachMsg = RcArr(i, 0) & "(" & RcArr(i, 1) & ")"
        If i = 1 Then
            RcArrMsg = EachMsg
        Else
            RcArrMsg = RcArrMsg & Space(2) & EachMsg
        End If
    Next
    
'Get RcType
    Dim GetRcType As Variant
    Dim RcType As String
    GetRcType = HCF4049_GetString(Thisdrawing, False, RcArrMsg, True)
    If VarType(GetRcType) = vbBoolean Then Exit Function
    GetRcType = HCF4117_VlookupInArr2Dimension_NumberOrString(RcArr, 0, 1, GetRcType)
    If VarType(GetRcType) = vbBoolean Then
        TextOverride = strQty & "Rc*/*"
    Else
        TextOverride = strQty & GetRcType
    End If

'Get SitaAna Type
    Dim GetSitaAnaType As Variant
    Dim SitaAnaType As String
    GetSitaAnaType = HCF4049_GetString(Thisdrawing, False, "下穴貫通(1), 下穴深***(2)", True)
    If VarType(GetSitaAnaType) = vbBoolean Then Exit Function
    Select Case GetSitaAnaType
        Case "1"
            TextOverride = TextOverride & "\X下穴貫通"
            Exit Function
        Case "2"
            TextOverride = TextOverride & "\X下穴深aaa"
        Case Else
            Exit Function
    End Select
    
'Get SitaAna Depth From User
    Dim GetDepth As Variant
    Dim SitaDepth As Double
    Dim Osmode As Integer: Osmode = 35      'EndPoint,MiddlePoint,Intersection
    Dim MsgSita As String: MsgSita = "下穴深さ="
    GetDepth = HCF4204_GetDistanceWithOsmode_DimLfac(SitaDepth, Osmode, MsgSita, 1)
    If GetDepth = True Then
        TextOverride = Replace(TextOverride, "aaa", SitaDepth)
    Else
        TextOverride = Replace(TextOverride, "aaa", "***")
    End If
End Function
Function HCF4199_Call_GetLFrom2PointThangHang(ProcessFinished As Boolean, l As Double, MsgPoint1 As String, MsgPoint2 As String)

'Get DimLfac
    Dim Dimlfac As Double
    Dimlfac = Thisdrawing.GetVariable("DIMLFAC")
    
'Get 2Point
    Dim Get2Point As Variant
    Dim Point1 As Variant
    Dim Point2 As Variant
    Dim OsmodePoint1 As Integer: OsmodePoint1 = 35  'EndPoint,MiddlePoint,Intersection
    Dim OsmodePoint2 As Integer: OsmodePoint2 = 35  'EndPoint,MiddlePoint,Intersection
    Get2Point = HCF4162_Get2PointWithOSMODE(MsgPoint1, MsgPoint2, OsmodePoint1, OsmodePoint2, True)
    If VarType(Get2Point) = vbBoolean Then
        Exit Function
    Else
        Point1 = Get2Point(0)
        Point2 = Get2Point(1)
    End If
    
'Define Length
    l = Func20LengthLineThrough2Point(Point1, Point2)
    l = l * Dimlfac
    ProcessFinished = True
End Function
Function HCF4200_Call_SetUCSFromPoint00()

    Dim Pi As Double: Pi = 4 * Atn(1)
    Dim origin(0 To 2) As Double
    Dim ucsObj As AcadUCS
    Dim xAxisPnt As Variant
    Dim yAxisPnt As Variant
    
    xAxisPnt = Thisdrawing.Utility.PolarPoint(origin, 0, 10)
    yAxisPnt = Thisdrawing.Utility.PolarPoint(origin, Pi / 2 + LineAngle, 10)
      
' Add the UCS to the UserCoordinatesSystems collection
    Set ucsObj = Thisdrawing.UserCoordinateSystems.Add(origin, xAxisPnt, yAxisPnt, "New_UCS")
      
' Display the UCS icon
    Thisdrawing.ActiveViewport.UCSIconAtOrigin = True
    Thisdrawing.ActiveViewport.UCSIconOn = True
      
' Make the new UCS the active UCS
    Thisdrawing.ActiveUCS = ucsObj

End Function
Function HCF4201_GetDouble(StrMsg As String) As Variant
    On Error GoTo ExitFunc
    HCF4201_GetDouble = False
    Dim GetDouble As Double
    GetDouble = Thisdrawing.Utility.GetReal(vbCr & StrMsg)
    HCF4201_GetDouble = GetDouble
ExitFunc:
End Function
Function HCF4202_Call_LockUnlockLayer(LayerName As String, Lock_Unlock_Mode As String)
'Define Layer
    Dim Layer As AcadLayer
    Dim TmpLayer As AcadLayer
    Dim HaveLayerName As Boolean
    For Each TmpLayer In Thisdrawing.Layers
        If TmpLayer.Name = LayerName Then
            Set Layer = TmpLayer
            HaveLayerName = True
        End If
    Next
    If HaveLayerName = False Then Exit Function

'Lock, Unlock Layer
    Select Case Lock_Unlock_Mode
        Case "Lock"
            Layer.Lock = True
        Case "Unlock"
            Layer.Lock = False
    End Select
End Function
Function HCF4203_Call_GetOnlyOneBlockRefFromBlockName(BlockName As String, ProcessResult As Boolean, ResultBlockRef As AcadBlockReference)
    ProcessResult = False
'Get
    Dim SS As AcadSelectionSet
    Set SS = Thisdrawing.SelectionSets.Add("SS" & Now)
    Dim FT(3) As Integer
    Dim FD(3) As Variant
    FT(0) = -4: FD(0) = "<AND"
    FT(1) = 0: FD(1) = "INSERT"
    FT(2) = 2: FD(2) = BlockName
    FT(3) = -4: FD(3) = "AND>"
    SS.Select acSelectionSetAll, , , FT, FD
    If SS.Count <> 1 Then
        SS.Delete
        Exit Function
    End If
    
'Result
    Dim EachBlockRef As AcadBlockReference
    For Each EachBlockRef In SS
        Set ResultBlockRef = EachBlockRef
        ProcessResult = True
    Next
    SS.Delete
End Function
Function HCF4204_GetDistanceWithOsmode_DimLfac(Distance As Double, Osmode As Integer, Msg As String, RoundMode As Integer) As Boolean
'Defaut
    HCF4204_GetDistanceWithOsmode_DimLfac = False
    
'Backup Osmode va set osmode
    Dim BackupOsnap As Variant: BackupOsnap = HCF4113_SettingOsnap("Backup", "")
    Dim Dimlfac As Double:      Dimlfac = Thisdrawing.GetVariable("DIMLFAC")
    Thisdrawing.SetVariable "OSMODE", Osmode
    
'Get Distance
    On Error GoTo GTEF
    Distance = Thisdrawing.Utility.GetDistance(, Msg)
    Distance = Dimlfac * Distance
    Distance = Round(Distance, 1)
    HCF4204_GetDistanceWithOsmode_DimLfac = True
    
'Restore Osmode
GTEF:
    Call HCF4113_SettingOsnap("Restore", BackupOsnap)
End Function

Function HCF4205_DefineRowPositionInArr2ChieuOfValue_StringNumber(Arr2Chieu As Variant, LookupColumnNo As Integer, LookupValue As Variant, ResultRNo As Integer) As Variant
'Defaut Value of Function
    HCF4205_DefineRowPositionInArr2ChieuOfValue_StringNumber = False
'Define RNo
    Dim EachValue As Variant
    For i = LBound(Arr2Chieu) To UBound(Arr2Chieu)
        EachValue = Arr2Chieu(i, LookupColumnNo)
        If EachValue = LookupValue Then
            ResultRNo = i
            HCF4205_DefineRowPositionInArr2ChieuOfValue_StringNumber = True
            Exit Function
        End If
    Next
End Function


Sub HCS3131_KKS_CreatChamferDimension()
'(TB VBABoss) Creat Chamfer Dimension,[CD]
'Setting
    Dim CDDistance As Double
    Dim DimScale As Double
    DimScale = Thisdrawing.GetVariable("DIMSCALE")
    CDDistance = 25 * DimScale
'Pi
    Dim Pi As Double
    Pi = 4 * Atn(1)
'Get ChamferQty From User
    Dim ChamferQty As String
    Dim GetString As Variant
    GetString = HCF4049_GetString(Thisdrawing, False, vbCr & "Chamfer Qty:", True)
    If VarType(GetString) = vbBoolean Then Exit Sub
    ChamferQty = GetString
    ChamferQty = LCase(ChamferQty)
    If ChamferQty = "" Or ChamferQty = "0" Or ChamferQty = "1" Then
        ChamferQty = ""
    Else
        If InStr(1, ChamferQty, "xx") = 0 Then
            ChamferQty = ChamferQty & "-"
        Else
            ChamferQty = Replace(ChamferQty, "xx", "x")
        End If
    End If
'Setting OSMode EndPoint
    Dim BackupOsmode As Integer
    Dim EndPointOsmode As Integer
    EndPointOsmode = 1
    BackupOsmode = Thisdrawing.GetVariable("OSMODE")
    Thisdrawing.SetVariable "OSMODE", EndPointOsmode
'Select 2 Point of Chamfer
    Dim Msg1 As String: Msg1 = "Select Point1 of chamfer line"
    Dim Msg2 As String: Msg2 = "Select Point2 chamfer line (counter-clockwise)"
    Dim Get2Point As Variant
    Dim Point1 As Variant
    Dim Point2 As Variant
    Dim Distance As Double
    Dim Angle As Double
    Get2Point = HCF4101_Get2Point(Msg1, Msg2)
    If VarType(Get2Point) = vbBoolean Then
        Thisdrawing.SetVariable "OSMODE", BackupOsmode
        Exit Sub
    End If
    Point1 = Get2Point(0)
    Point2 = Get2Point(1)
    Distance = Get2Point(2)
    Angle = Get2Point(3)
'Restore OSMode
    Thisdrawing.SetVariable "OSMODE", BackupOsmode
'Define CValue
    Dim Dimlfac As Double
    Dim CValue As Double
    Dimlfac = Thisdrawing.GetVariable("DIMLFAC")
    CValue = Abs(Distance * Cos(Angle)) * Dimlfac
    CValue = Round(CValue, 1)
'Creat AlignDimension
'AddDimAligned(ExtLine1Point, ExtLine2Point, TextPosition) As AcadDimAligned
    Dim ChamferDim As AcadDimAligned
    Dim ExtLine1Point As Variant
    Dim ExtLine2Point As Variant
    Dim TextPosition As Variant
    ExtLine2Point = Thisdrawing.Utility.PolarPoint(Point1, Angle - Pi / 2, CDDistance)
    ExtLine1Point = Point1
    TextPosition = HCF4102_Middle2Point(Point1, Point2)
    Set ChamferDim = Thisdrawing.ModelSpace.AddDimAligned(ExtLine1Point, ExtLine2Point, TextPosition)
'Suppress Line of ChamferDim
    ChamferDim.DimLine2Suppress = True
    ChamferDim.ExtLine1Suppress = True
    ChamferDim.ExtLine2Suppress = True
'Change TextOverride
    Dim TextOverride As String
    TextOverride = ChamferQty & "C" & CValue
    ChamferDim.TextOverride = TextOverride
End Sub

Sub HCS3130_ChangeLayer_HiddenCircle20()
'(TB VBABoss) Change Layer of Circle From Hidden to Layer 0,[HC20]
    Thisdrawing.Utility.Prompt (vbCrLf & "(TB VBABoss) Change Layer of Circle From Hidden to Layer 0,[HC20]" & vbCr)
'Setting Layer
    Dim FromLayerName As String
    Dim ToLayerName As String
    Call HCF4179_SetPublicLayerName
    FromLayerName = Pb04_HiddenLayerName
    ToLayerName = "0"
'Select Circle
    Thisdrawing.Utility.Prompt (vbCrLf & "Select Circles:" & vbCr)
    Dim objSelectOnScreen As AcadSelectionSet
    Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
    Dim FT(3) As Integer
    Dim FD(3) As Variant
    FT(0) = -4:  FD(0) = "<AND"
    FT(1) = 0:  FD(1) = "CIRCLE"
    FT(2) = 8:  FD(2) = FromLayerName
    FT(3) = -4:  FD(3) = "AND>"
    objSelectOnScreen.SelectOnScreen FT, FD
    If objSelectOnScreen.Count = 0 Then
        objSelectOnScreen.Delete
        Exit Sub
    End If
'Change LayerName
    Dim EachCircle As AcadCircle
    For Each EachCircle In objSelectOnScreen
        EachCircle.Layer = ToLayerName
        Call Func43SetBylayer(EachCircle)
    Next
'Setting Layer For MIn,MOunt
    Call HCF4190_CallSetting_LayerNameAndColorOfMInMOut
'Change Layer M
    Call HCF4191_Call_ChangeLayerMOfSelectSet(objSelectOnScreen)
    objSelectOnScreen.Delete
End Sub
Sub HCS3132_KKS_CreateDiametreDimension()
'(TB VBABoss) KKS Dim Hole,[DH]
    Thisdrawing.Utility.Prompt vbCrLf & "Dim Hole" & vbLf
    
'Setting Osnap, Dynamic Input
    Dim BackupOsnap As Variant: BackupOsnap = HCF4113_SettingOsnap("Backup", "")
    Dim BackupDYNMODE As Variant
    Dim DimScale As Double
    DimScale = Thisdrawing.GetVariable("DIMSCALE")
    BackupDYNMODE = Thisdrawing.GetVariable("DYNMODE")
    Thisdrawing.SetVariable "DYNMODE", 3
    Call HCF4200_Call_SetUCSFromPoint00

'Set layername
    Call HCF4179_SetPublicLayerName
    
'Setting HoleArr()
    Dim HoleArr() As String
    Call HCF4198X_02_Call_KKS_CreatHoleArr(HoleArr)
    
'Setting Note
    Dim NoteArr() As String
    Call HCF4198X_03_Call_KKS_CreatNoteArr(NoteArr)
    
'Setting Couterbore, Countersink data
    Dim CBArr() As String
    Dim CSArr() As String
    Call HCF4198X_04_Call_KKS_CreatCBArr(CBArr)     '(M* Type*,d,D,H)
    Call HCF4198X_05_Call_KKS_CreatCSArr(CSArr)     '(M*,d,D)

'Get Hole qty
    Dim GetQty As Variant
    Dim strQty As String
    Call HCF4119_Call_DFK_GetQtyFromUser(GetQty, "Hole Qty:")
    If VarType(GetQty) = vbBoolean Then
         GoTo PWES
    Else
        strQty = GetQty
    End If
    
'Select CenterPoint
    Dim CenterPoint As Variant
    Dim CenterPointMsg As String: CenterPointMsg = "Select Center Point:"
    Call HCF4113_SettingOsnap("Center", "")
    CenterPoint = HCF4196_GetPoint(Thisdrawing, CenterPointMsg)
    If VarType(CenterPoint) = vbBoolean Then GoTo PWES
    
'Select DPoint and define radius
    Dim DPoint As Variant
    Dim DPointMsg As String: DPointMsg = "Select Diameter Point:"
    Dim Radius As Double
    Dim Diameter1 As Double
    Call HCF4113_SettingOsnap("Nearest", "")
    DPoint = HCF4197_GetSecondPoint(Thisdrawing, CenterPoint, DPointMsg)
    If VarType(DPoint) = vbBoolean Then GoTo PWES
    Radius = Func20LengthLineThrough2Point(CenterPoint, DPoint)
    Diameter1 = Round(2 * Radius, 1)
    
'Get HoleType
    Dim HoleArrMsg As String
    Dim EachMsg As String
    For i = LBound(HoleArr) To UBound(HoleArr)
        EachMsg = HoleArr(i, 0) & "(" & HoleArr(i, 1) & ")"
        If i = 1 Then
            HoleArrMsg = EachMsg
        Else
            HoleArrMsg = HoleArrMsg & Space(2) & EachMsg
        End If
    Next
    Dim GetHoleType As Variant
    Dim HoleType As String
    GetHoleType = HCF4049_GetString(Thisdrawing, False, HoleArrMsg, True)
    If VarType(GetHoleType) = vbBoolean Then GoTo PWES
    GetHoleType = HCF4117_VlookupInArr2Dimension_NumberOrString(HoleArr, 0, 0, GetHoleType)
    If VarType(GetHoleType) = vbBoolean Then GetHoleType = "1"
    
'Define Prefix, Suffix From GetHoleType
    Dim Prefix As String
    Dim Suffix As String
    Dim TextOverride As String
    Dim Deep As Double
    Prefix = HCF4117_VlookupInArr2Dimension_NumberOrString(HoleArr, 0, 2, GetHoleType)
    Prefix = strQty & Prefix
    Suffix = HCF4117_VlookupInArr2Dimension_NumberOrString(HoleArr, 0, 3, GetHoleType)

    Select Case GetHoleType
        Case "4"    'M DEPTH
            Deep = Round(4 * Radius, 0)
            Suffix = Replace(Suffix, "aaa", Deep)
        Case "6" 'M Depth, SitaAna Depth
            Call HCF4198X_10_Call_GetDepthDepth(Suffix)
        Case "7"    'REN NHUYEN
            Call HCF4198X_01_Call_GetPitchAndDeepOfRenNhuyen(Suffix, "Pitch")
        Case "8"    'REN NHUYEN DEPTH
            Call HCF4198X_01_Call_GetPitchAndDeepOfRenNhuyen(Suffix, "PitchDepth")
        Case "9"    'CounterBore
            Call HCF4198X_08_Call_CouterBore(Suffix, CenterPoint, Diameter1, CBArr)
        Case "10"           'CounterSink
            Call HCF4198X_07_Call_CouterSink(Suffix, Diameter1, CSArr)
        Case "12", "13"     'H7,H8 Depth
            Call HCF4198X_06_Call_GetDepth(Suffix)
        Case "15" 'Rc
            Call HCF4198X_11_Call_Rc(TextOverride, strQty)
            GoTo GTCreatDiameterDimension
    End Select
    
'Get Note
    Dim NoteArrMsg As String
    Dim GetNote As Variant
    Dim Note As String
    For i = LBound(NoteArr) To UBound(NoteArr)
        EachMsg = NoteArr(i, 0) & "(" & NoteArr(i, 1) & ")"
        If i = 1 Then
            NoteArrMsg = EachMsg
        Else
            NoteArrMsg = NoteArrMsg & Space(2) & EachMsg
        End If
    Next
    GetNote = HCF4049_GetString(Thisdrawing, False, NoteArrMsg, True)
    If VarType(GetNote) = vbBoolean Then
        GoTo PWES
    Else
        GetNote = HCF4117_VlookupInArr2Dimension_NumberOrString(NoteArr, 0, 2, GetNote)
    End If
    If VarType(GetNote) <> vbBoolean Then Note = GetNote
    
'Add Note to Suffix
    Call HCF4198X_09_Call_AddNote(Prefix, Suffix, Note)
    
'Creat Diameter Dimension
GTCreatDiameterDimension:
    Dim objDiameterDimension As AcadDimDiametric
    Dim ChordPoint As Variant
    Dim farchordPoint As Variant
    Dim leaderLen As Integer
    Dim Pi As Double: Pi = Atn(1) * 4
    ChordPoint = Thisdrawing.Utility.PolarPoint(CenterPoint, 5 * Pi / 4, Radius)
    farchordPoint = Thisdrawing.Utility.PolarPoint(CenterPoint, Pi / 4, Radius)
    leaderLen = 15 * DimScale
    Set objDiameterDimension = Thisdrawing.ModelSpace.AddDimDiametric(ChordPoint, farchordPoint, leaderLen)
    objDiameterDimension.TextOutsideAlign = True
    objDiameterDimension.ForceLineInside = False
    objDiameterDimension.CenterType = acCenterNone
    objDiameterDimension.TextPrefix = Prefix
    If Suffix <> "" Then objDiameterDimension.TextSuffix = Suffix
    If TextOverride <> "" Then objDiameterDimension.TextOverride = TextOverride
    objDiameterDimension.Layer = Pb08_DimLayerName
    objDiameterDimension.Update
    
'Process when exit sub
PWES:
    Call HCF4113_SettingOsnap("Restore", BackupOsnap)
    Thisdrawing.SetVariable "DYNMODE", BackupDYNMODE
End Sub
Sub HCS3133_GhiDungSaiKichThuoc1()
'(TB VBABoss) Ghi Dung Sai Kich Thuoc Type 1,[DS1]

'Select Dimension
    Thisdrawing.Utility.Prompt (vbCr & "Select Dimension:")
    Dim SS As AcadSelectionSet
    Set SS = Thisdrawing.SelectionSets.Add("SS" & Now)
    Dim FT(0) As Integer
    Dim FD(0) As Variant
    FT(0) = 0:  FD(0) = "DIMENSION"
    SS.SelectOnScreen FT, FD
    If SS.Count = 0 Then
        SS.Delete
        Exit Sub
    End If
    
'Get Dung Sai1
    Dim GetDungSai As Variant
    Dim DungSai1 As Double
    GetDungSai = HCF4201_GetDouble("Input Tolerance:")
    If VarType(GetDungSai) = vbBoolean Then
        Exit Sub
    Else
        DungSai1 = GetDungSai
        If DungSai1 < 0 Then
            DungSai1 = Abs(DungSai1)
        End If
    End If

'Set Tolerance For Dimension
    Dim EachDim As AcadDimension
    For Each EachDim In SS
        If DungSai1 <> 0 Then
            EachDim.ToleranceDisplay = acTolSymmetrical
            EachDim.ToleranceUpperLimit = DungSai1
            EachDim.ToleranceLowerLimit = DungSai1
        Else
            EachDim.ToleranceUpperLimit = 0
            EachDim.ToleranceLowerLimit = 0
            EachDim.ToleranceDisplay = acTolNone
        End If
    Next
End Sub
Sub HCS3134_GhiDungSaiKichThuoc2()
'(TB VBABoss) Ghi Dung Sai Kich Thuoc Type 2,[DS2]

'Select Dimension
    Thisdrawing.Utility.Prompt (vbCr & "Select Dimension:")
    Dim SS As AcadSelectionSet
    Set SS = Thisdrawing.SelectionSets.Add("SS" & Now)
    Dim FT(0) As Integer
    Dim FD(0) As Variant
    FT(0) = 0:  FD(0) = "DIMENSION"
    SS.SelectOnScreen FT, FD
    If SS.Count = 0 Then
        SS.Delete
        Exit Sub
    End If
    
'Get Tolerance Upper Limit
    Dim GetDungSai As Variant
    Dim UpperTolerance As Double
    GetDungSai = HCF4201_GetDouble("Input Tolerance Upper Limit:")
    If VarType(GetDungSai) = vbBoolean Then
        Exit Sub
    Else
        UpperTolerance = GetDungSai
    End If
    
'Get Tolerance Lower Limit
    Dim LowerTolerance As Double
    GetDungSai = HCF4201_GetDouble("Input Tolerance Lower Limit:")
    If VarType(GetDungSai) = vbBoolean Then
        Exit Sub
    Else
        If GetDungSai > UpperTolerance Then
            LowerTolerance = UpperTolerance
            UpperTolerance = GetDungSai
        Else
            LowerTolerance = GetDungSai
        End If
        If LowerTolerance = UpperTolerance Then
            Exit Sub
        End If
        If LowerTolerance > 0 Then
            LowerTolerance = -LowerTolerance
        Else
            If LowerTolerance < 0 Then
                LowerTolerance = Abs(LowerTolerance)
            End If
        End If

    End If

'Set Tolerance For Dimension
    Dim EachDim As AcadDimension
    For Each EachDim In SS
        EachDim.ToleranceDisplay = acTolDeviation
        EachDim.ToleranceUpperLimit = UpperTolerance
        EachDim.ToleranceLowerLimit = LowerTolerance
    Next
End Sub
Sub HCS3135_Call_KKS_CheckDoNhamTong()
'(TB VBABoss) Check Do Nham Tong KKS,Automatic

'Check ProjectName
    If ProjectName <> "KKS" Then Exit Sub

'Unlock Layer 90_Frame
    Call HCF4179_SetPublicLayerName
    Dim LockLayerName As String: LockLayerName = Pb16_FrameLayerName
    Call HCF4202_Call_LockUnlockLayer(LockLayerName, "Unlock")

'Check xem co phai ban ve Part hay khong?
'Function HCF4203_Call_GetOnlyOneBlockRefFromBlockName(BlockName As String, ProcessResult As Boolean, ResultBlockRef As AcadBlockReference)
    Dim BlockName As String: BlockName = PartPropertyBlock
    Dim ProcessResult As Boolean
    Dim ResultBlockRef As AcadBlockReference
    Call HCF4203_Call_GetOnlyOneBlockRefFromBlockName(BlockName, ProcessResult, ResultBlockRef)
    If ProcessResult = False Then
        MsgBox "Check Do Nham Tong(Err):" & vbNewLine & "This drawing is not part drawing."
        Exit Sub
    End If
'Kiem tra xem co BlockRef do nham tong hay khong?
    Dim DNT_Blockname As String: DNT_Blockname = "MAIN_TRT"
    Dim DNT_ObjBlockRef As AcadBlockReference
    Call HCF4203_Call_GetOnlyOneBlockRefFromBlockName(DNT_Blockname, ProcessResult, ResultBlockRef)
    If ProcessResult = False Then
        MsgBox "Check Do Nham Tong(Err):" & vbNewLine & "This drawing is dont have do nham tong."
        Exit Sub
    End If
    
'Define DNT_ObjBlock
    Dim DNT_ObjBlock As AcadBlock
    Set DNT_ObjBlock = Thisdrawing.Blocks(DNT_Blockname)
    
'Xac dinh so luong ki hieu do nham trong DNT_ObjBlock
    Dim EachEntity As AcadEntity
    Dim DN_Qty As Integer
    For Each EachEntity In DNT_ObjBlock
        Select Case EachEntity.ObjectName
            Case "AcDbCircle"
                DN_Qty = DN_Qty + 1
            Case "AcDbText"
                DN_Qty = DN_Qty + 1
        End Select
    Next
    
'Creat DNTArr
    Dim DNTArr() As Variant: Dim aa As Integer
    ReDim DNTArr(0 To DN_Qty - 1, 0 To 1)
    Dim EachDN As String
    Dim EachPositon As Variant
    Dim EachX As Double
    Dim EachWrite As Boolean
    Dim EachCircle As AcadCircle
    Dim EachText As AcadText
    For Each EachEntity In DNT_ObjBlock
        EachWrite = False
        Select Case EachEntity.ObjectName
            Case "AcDbCircle"
                Set EachCircle = EachEntity
                EachDN = "0"
                EachPositon = EachCircle.center
                EachX = Round(EachPositon(0), 0)
                EachWrite = True
            Case "AcDbText"
                Set EachText = EachEntity
                EachDN = EachText.TextString
                EachPositon = EachText.InsertionPoint
                EachX = Round(EachPositon(0), 0)
                EachWrite = True
        End Select
        If EachWrite = True Then
            DNTArr(aa, 0) = EachDN
            DNTArr(aa, 1) = EachX
            aa = aa + 1
        End If
    Next
    
'Sort DNTArr theo toa do X
    DNTArr = HCF4068_SortArrAtoZ_Arr2Chieu(DNTArr, 1, "Number")
    
'Creat DNArr(0_25_12.5_6.3_3.2_1.6,Main_Sub_No,0/1)
    Dim DNArr(0 To 5, 0 To 3) As Variant
    DNArr(0, 0) = "0":      DNArr(0, 1) = "No":     DNArr(0, 2) = 0
    DNArr(1, 0) = "25":     DNArr(1, 1) = "No":     DNArr(1, 2) = 0
    DNArr(2, 0) = "12.5":   DNArr(2, 1) = "No":     DNArr(2, 2) = 0
    DNArr(3, 0) = "6.3":    DNArr(3, 1) = "No":     DNArr(3, 2) = 0
    DNArr(4, 0) = "3.2":    DNArr(4, 1) = "No":     DNArr(4, 2) = 0
    DNArr(5, 0) = "1.6":    DNArr(5, 1) = "No":     DNArr(5, 2) = 0
    
'Ghi Main_Sub_No vao DNArr
    Dim EachTmp As String
    Dim GetRNo As Boolean
    Dim RNo As Integer
    For i = LBound(DNTArr) To UBound(DNTArr)
        EachDN = DNTArr(i, 0)
        GetRNo = HCF4205_DefineRowPositionInArr2ChieuOfValue_StringNumber(DNArr, 0, EachDN, RNo)
        If GetRNo = True Then
            If i = 0 Then
                DNArr(RNo, 1) = "Main"
            Else
                DNArr(RNo, 1) = "Sub"
            End If
        End If
    Next

'Xac dinh so luong do nham 0 trong ban ve
    Dim SS As AcadSelectionSet
    Set SS = Thisdrawing.SelectionSets.Add("SS" & Now)
    Dim FT() As Integer
    Dim FD() As Variant
    ReDim FT(4): ReDim FD(4)
    FT(0) = -4:     FD(0) = "<AND"
    FT(1) = 0:      FD(1) = "CIRCLE"
    FT(2) = 8:      FD(2) = Pb08_DimLayerName
    FT(3) = 62:     FD(3) = 4 'Cyan
    FT(4) = -4:     FD(4) = "AND>"
    SS.Select acSelectionSetAll, , , FT, FD
    DNArr(0, 2) = SS.Count
    SS.Clear
    
'Xac dinh so luong do nham 25,12.5,6.3,3.2,1.6
    ReDim FT(7): ReDim FD(7)
    FT(0) = -4:     FD(0) = "<AND"
    FT(1) = -4:     FD(1) = "<OR"
    FT(2) = 0:      FD(2) = "TEXT"
    FT(3) = 0:      FD(3) = "MTEXT"
    FT(4) = -4:     FD(4) = "OR>"
    FT(5) = 8:      FD(5) = Pb08_DimLayerName
    FT(6) = 62:     FD(6) = 256 'By layer
    FT(7) = -4:     FD(7) = "AND>"
    SS.Select acSelectionSetAll, , , FT, FD
    For Each EachEntity In SS
        EachDN = EachEntity.TextString
        GetRNo = HCF4205_DefineRowPositionInArr2ChieuOfValue_StringNumber(DNArr, 0, EachDN, RNo)
        If GetRNo = True Then
            DNArr(RNo, 2) = DNArr(RNo, 2) + 1
        End If
    Next
    SS.Delete

'Check su phu hop giua do nham tong va do nham trong ban ve
    Dim EachMainSub As String
    Dim EachQty As Integer
    Dim EachCheck As Integer
    Dim TotalCheck As Integer
    Dim ListDNTrongBanVe As String
    For i = LBound(DNArr) To UBound(DNArr)
        EachDN = DNArr(i, 0)
        EachMainSub = DNArr(i, 1)
        EachQty = DNArr(i, 2)
        Select Case EachMainSub
            Case "Main"
                If EachQty = 0 Then
                    EachCheck = 0
                Else
                    EachCheck = 1
                End If
            Case "Sub"
                If EachQty = 0 Then
                    EachCheck = 1
                Else
                    EachCheck = 0
                End If
            Case "No"
                If EachQty = 0 Then
                    EachCheck = 0
                Else
                    EachCheck = 1
                End If
        End Select
        DNArr(i, 3) = EachCheck
        TotalCheck = TotalCheck + EachCheck
        If EachQty > 0 Then
            If ListDNTrongBanVe = "" Then
                ListDNTrongBanVe = EachDN
            Else
                ListDNTrongBanVe = ListDNTrongBanVe & Space(3) & EachDN
            End If
        End If
    Next
    
'Show Result
    If TotalCheck > 0 Then
        MsgBox "Do nham tong <> Do nham trong ban ve" & vbNewLine & _
                ListDNTrongBanVe
    End If


'Lock layer 90_Frame
    Call HCF4202_Call_LockUnlockLayer(LockLayerName, "Lock")

End Sub






Sub TBR18OrdinateDimensionStraighten()
'(VBA AutoCad)Ordinate Dimension Straighten,[ODS]
    Thisdrawing.Utility.Prompt (vbCr & "Ordinate Dimension Straighten")
    
'Select Dimension
    Thisdrawing.Utility.Prompt (vbCr & "Select Ordinate Dimension to Straighten:")
    Dim objSelectOnScreen As AcadSelectionSet
    Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
    Dim FT(0) As Integer
    Dim FD(0) As Variant
    FT(0) = 0:  FD(0) = "DIMENSION"
    objSelectOnScreen.SelectOnScreen FT, FD
    If objSelectOnScreen.Count = 0 Then
        objSelectOnScreen.Delete
        Exit Sub
    End If

'Filter Only Ordinate Dimension
    Dim OrdinateDimArr() As Variant
    Dim kArr As Integer
    Dim EachEntity As AcadDimension
    Dim EachOrdinateDim As AcadDimOrdinate
    For Each EachEntity In objSelectOnScreen
        If EachEntity.ObjectName = "AcDbOrdinateDimension" Then
            ReDim Preserve OrdinateDimArr(0 To kArr)
            Set OrdinateDimArr(kArr) = EachEntity
            kArr = kArr + 1
        End If
    Next
    If kArr = 0 Then
        objSelectOnScreen.Delete
        Exit Sub
    End If

'Get Point(0,0) From OrdinateDimArr or user
    Dim Point00 As Variant
    Call HCF4193_DefineDimPoint00FromOrdinateDimArr(Point00, OrdinateDimArr)
    If VarType(Point00) = vbBoolean Then
        Point00 = HCF4196_GetPoint(Thisdrawing, "Select Dimension Point (0,0):")
    End If
    If VarType(Point00) = vbBoolean Then
        objSelectOnScreen.Delete
        Exit Sub
    End If

'Set UCS to MinPoint
    Call FuncCadHome05SetUCSFromPoint(Point00)
    
'Get MinPoint and MaxPoint
    Dim MinPoint As Variant
    Dim MaxPoint As Variant
    Call HCF4192_Call_GetMinMaxPointFromSelectedBlockRefOrFromUser(MinPoint, MaxPoint)

'Define MinX,MaxX,MinY,MaxY from MinPoint,MaxPoint
    Dim MinXMaxXMinYMaxY As Variant
    MinXMaxXMinYMaxY = FuncCadHome01MaxMinXYFrom2Point(MinPoint, MaxPoint)

'Process
    Dim DimDirection As String
    Dim ChangeCount As Integer
    Dim DimMeasurement As Double
    Dim OldTextPosition As Variant
    Dim OldTextPositionX As Double
    Dim OldTextPositionY As Double
    Dim NewTextPosition(0 To 2) As Double
    Dim WorldNewTextPositon As Variant
    For i = LBound(OrdinateDimArr) To UBound(OrdinateDimArr)
        Set EachOrdinateDim = OrdinateDimArr(i)
        DimDirection = FuncCadHome03OrdinateDimDirection(EachOrdinateDim, MinXMaxXMinYMaxY)
        OldTextPosition = EachOrdinateDim.TextPosition
        OldTextPosition = Thisdrawing.Utility.TranslateCoordinates(OldTextPosition, acWorld, acUCS, 0)
        OldTextPositionX = Round(OldTextPosition(0), 2)
        OldTextPositionY = Round(OldTextPosition(1), 2)
        DimMeasurement = Round(EachOrdinateDim.Measurement, 2)
    'Define NewTextPosition
        Select Case DimDirection
            Case "UP", "DOWN"
                If DimMeasurement <> Abs(OldTextPositionX) Then
                    If OldTextPositionX < 0 Then
                        NewTextPosition(0) = -EachOrdinateDim.Measurement
                    Else
                        NewTextPosition(0) = EachOrdinateDim.Measurement
                    End If
                    NewTextPosition(1) = OldTextPosition(1)
                Else
                    GoTo GTExitLoop
                End If
            Case "LEFT", "RIGHT"
                If DimMeasurement <> Abs(OldTextPositionY) Then
                    NewTextPosition(0) = OldTextPosition(0)
                    If OldTextPositionY < 0 Then
                        NewTextPosition(1) = -EachOrdinateDim.Measurement
                    Else
                        NewTextPosition(1) = EachOrdinateDim.Measurement
                    End If
                Else
                    GoTo GTExitLoop
                End If
            Case Else
                GoTo GTExitLoop
        End Select
    'Move Dim
        WorldNewTextPositon = NewTextPosition
        WorldNewTextPositon = Thisdrawing.Utility.TranslateCoordinates(WorldNewTextPositon, acUCS, acWorld, 0)
        EachOrdinateDim.TextPosition = WorldNewTextPositon
        EachOrdinateDim.Update
GTExitLoop:
    Next
    objSelectOnScreen.Delete
End Sub

buianhtuan.cdt · ‎09-26-2021

;(TB VBABoss) Ghi Dung Sai Kich Thuoc Type 2,[DS2]
(defun C:DS2()
(command "-vbarun" "HCS3134_GhiDungSaiKichThuoc2")
)

;(TB VBABoss) Ghi Dung Sai Kich Thuoc Type 1,[DS1]
(defun C:DS1()
(command "-vbarun" "HCS3133_GhiDungSaiKichThuoc1")
)

;(TB VBABoss) Change Layer of Circle From Hidden to Layer 0,[HC20]
(defun C:HC20()
(command "-vbarun" "HCS3130_ChangeLayer_HiddenCircle20")
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

Text in layout with vba

Text in layout with vba

Text in layout with vba

Forums Links

Post to forums