Get and set dynamic block property

truss_85 · ‎04-04-2011

Hi to everyone;

I have a block which contains visible and unvisible objects and attributes. I need to export custom block properties, which I added to a dynamic block, like in express tool export attribute information.

or it is possible to convert my custom property, which can contains unvisible and visible objects, to attribute value.

Hallex · ‎04-05-2011

Try this quick example

Create project with form

Add this code into the form module

Option Explicit
Dim selprop As String
Dim propArray()
' UserForm1:
' ListBox1
'CommandButton1
'CommandButton2
'


Private Sub CommandButton1_Click()
Me.Hide
Call GetDynProps
Me.Show
End Sub


Public Sub GetDynProps()

' tested on A2009 only
     Dim ss As AcadSelectionSet
     Dim ent As AcadEntity
     Dim bname As String
   Dim props() As AcadDynamicBlockReferenceProperty
     Dim pvalue As Variant
     Dim blkref As AcadBlockReference
     With ThisDrawing.SelectionSets
          While .Count > 0
               .Item(0).Delete
          Wend
          Set ss = .Add("$DynBlocks$")
     End With

     Dim ftype(0 To 1) As Integer
     Dim fdata(0 To 1) As Variant

     ftype(0) = 0: ftype(1) = 66
     fdata(0) = "INSERT": fdata(1) = 1
     ss.SelectOnScreen ftype, fdata
     
  If ss.Count = 0 Then
  MsgBox "No blocks with attributes selected...Exit"
  Exit Sub
  End If

  Set blkref = ss.Item(0)
  If blkref.IsDynamicBlock Then
  MsgBox "Ya"
  
  Dim i As Integer
  props = blkref.GetDynamicBlockProperties
 
  Dim prop As AcadDynamicBlockReferenceProperty
  ReDim propArray(UBound(props), 1)
  
For i = LBound(props) To UBound(props)
Set prop = props(i)
pvalue = prop.Value

propArray(i, 0) = prop.PropertyName
propArray(i, 1) = CStr(pvalue)

Next i

End If
ListBox1.List = propArray

     
End Sub

Private Sub CommandButton2_Click()

Dim i
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) = True Then
selprop = ListBox1.List(i, 1)

Exit For
End If

Next
If selprop = vbNullString Then
MsgBox "No item selected in ListBox...Exit"
Exit Sub
End If

Me.Hide

Dim varPt, mtx, ctx
Dim obj As AcadEntity
Dim oAttrib As AcadAttributeReference

ThisDrawing.Utility.GetSubEntity obj, varPt, mtx, ctx, vbCr & "Select attribute:"

If obj Is Nothing Then
MsgBox "Nothing selected, try again...Exit"
Exit Sub
End If

If Not TypeOf obj Is AcadAttributeReference Then
MsgBox "You have to select attribute only, try again...Exit"
Exit Sub
End If

Set oAttrib = obj
Dim strTag As String
strTag = oAttrib.TagString

oAttrib.TextString = selprop
MsgBox "Done"
End
End Sub

Private Sub UserForm_Initialize()
Me.Width = 200
Me.Height = 150
Me.Caption = "Edit Attribute"
ListBox1.Left = 6
ListBox1.top = 0
ListBox1.Width = 180
ListBox1.Height = 80
ListBox1.ColumnWidths = "100 pt;60 pt"
ListBox1.BoundColumn = 1
ListBox1.ColumnCount = 2
ListBox1.MultiSelect = fmMultiSelectSingle
Me.CommandButton1.Caption = "Select block"
CommandButton2.Caption = "Select attribute"
End Sub

~'J'~

_____________________________________
C6309D9E0751D165D0934D0621DFF27919

truss_85 · ‎04-07-2011

Thank you very much my friend,

Great work, it totaly worked.

Hallex · ‎04-07-2011

Glad to help

btw you coul be ask me on dwgru as well

Cheers

~'J'~

_____________________________________
C6309D9E0751D165D0934D0621DFF27919

truss_85 · ‎04-07-2011

I try that 😉

I just wondering custum block properties are read only.

If it is possible I want change value by using vba.

Hallex · ‎04-07-2011

Personaly, I don't like to imagine your goal virtually

Better yet, let you upload the sample drawing with this block in this thread

In this case you will be get a help quickier I think...

~'J'~

_____________________________________
C6309D9E0751D165D0934D0621DFF27919

truss_85 · ‎04-09-2011

Sorry for being late,

I am very busy these days.

Here is my sample block, it is simply represent a hydrant in pipe network.

I have many of them in projects, I have a program which calculates hydrant outlet capacity which depends on flow rate and area of irrigation.

Program needs geometric data like km, elevation I have them and there is not a problem but my problem occurs after the calculation I need to rearrange hydrant out let counts. It is easy to do it when these parameters are attributes of a block.

Attributes are easily export and inport to the project but custom properties of a dyn block... I want them too.

Thanks for concerning...

johndsouza · ‎04-15-2021

newVal = 2000 * 1#

props(i).Value = newVal

buianhtuan.cdt · ‎05-16-2021

Sub TBS12_BackupRestoreColor()
'Backup Color(ColorColumnFrom, ColorColumnTo,ColorNumber
    Dim BackupColorArr() As Variant
    Call TBF46_BackupColor(BackupColorArr)
'Clear Color
    Dim WS As Worksheet
    Set WS = ThisWorkbook.ActiveSheet
    Dim TmpRange As Range
    Set TmpRange = WS.Range(WS.Cells(5, 6), WS.Cells(77, 36))
    TmpRange.Interior.Color = 16777215
    Call TBS08_DayoffFillCellColor
'Restore Color
    Call TBF47_RestoreColor(BackupColorArr)
End Sub
Sub TBS13_CreatNewSheet()
'New or Edit?
    Dim MsgBoxResult As VbMsgBoxResult
    Dim MsgPrompt As String
    Dim MsgButton As VbMsgBoxStyle
    Dim MsgTitle As String
    MsgPrompt = "‚Í‚¢F‘S‚Äƒf[ƒ^‚ðíœ‚µ‚ÄV‹KƒV[ƒg‚ðì¬‚µ‚Ü‚·B" & vbNewLine & _
                "‚¢‚¢‚¦Fƒf[ƒ^‚ð‚»‚Ì‚Ü‚ÜB"
    MsgButton = vbYesNoCancel + vbSystemModal
    MsgTitle = "ƒV[ƒgV‹KE•ÒW"
    MsgBoxResult = MsgBox(MsgPrompt, MsgButton, MsgTitle)
    Select Case MsgBoxResult
        Case vbYes
            Call TBF48_CreatNewSheet("New")
        Case vbNo
            Call TBF48_CreatNewSheet("Edit")
        Case vbCancel
    End Select
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function TBF41_SetFormular(SUS As Worksheet)
    Dim RNo As Integer
    Dim CNo As Integer
    Dim GouKei As Double
    Dim GaiChuu As Double
    Dim JinIn As Double
    Dim TrungBinhNguoi As Variant
    Dim TBNguoiThucTe As Variant
    Dim TBNguoiMucTieu As Variant
    Dim ChuuKi As String
    Dim PhanTram As Variant
'If value="" then value=0
    For RNo = 5 To 14
        Select Case RNo
            Case 5, 6, 7, 11, 12, 13
                For CNo = 48 To 50
                    If SUS.Cells(RNo, CNo).Value = "" Then SUS.Cells(RNo, CNo) = 0
                Next
        End Select
    Next
    For RNo = 4 To 14
        Select Case RNo
            Case 4, 10 'chuuki
                ChuuKi = SUS.Cells(RNo + 1, 47).Value
                SUS.Range(SUS.Cells(RNo, 48), SUS.Cells(RNo, 50)).Value = Left(ChuuKi, 3)
                SUS.Cells(RNo, 51).Value = Mid(ChuuKi, 5, 5)
                SUS.Cells(RNo, 52).Value = Right(ChuuKi, 5)
            Case 5, 6, 7, 11, 12, 13 'Shanai,Kyoto
                SUS.Cells(RNo, 51).Value = SUS.Cells(RNo, 48).Value + SUS.Cells(RNo, 49).Value
                SUS.Cells(RNo, 52).Value = SUS.Cells(RNo, 48).Value + SUS.Cells(RNo, 49).Value + SUS.Cells(RNo, 50).Value
            Case 8, 14 '(xx.x/hito)
                For CNo = 48 To 52
                    GouKei = SUS.Cells(RNo - 3, CNo).Value
                    GaiChuu = SUS.Cells(RNo - 2, CNo).Value
                    JinIn = SUS.Cells(RNo - 1, CNo).Value
                    If JinIn = 0 Then
                        TrungBinhNguoi = 0
                    Else
                        TrungBinhNguoi = (GouKei - GaiChuu) / JinIn
                        If TrungBinhNguoi >= 100 Then
                            TrungBinhNguoi = Format(TrungBinhNguoi, "000.0")
                        Else
                            TrungBinhNguoi = Format(TrungBinhNguoi, "00.0")
                        End If
                    End If
                    SUS.Cells(RNo, CNo).Value = TrungBinhNguoi
                Next
        End Select
    Next
'%
    RNo = 9
    For CNo = 48 To 52
        TBNguoiThucTe = SUS.Cells(RNo - 1, CNo).Value
        TBNguoiMucTieu = SUS.Cells(RNo + 5, CNo).Value
        TBNguoiThucTe = CDbl(TBNguoiThucTe)
        TBNguoiMucTieu = CDbl(TBNguoiMucTieu)
        If TBNguoiMucTieu = 0 Then
            PhanTram = 0
        Else
            PhanTram = TBNguoiThucTe / TBNguoiMucTieu * 100
            If PhanTram >= 100 Then
                PhanTram = Format(PhanTram, "000.0")
            Else
                PhanTram = Format(PhanTram, "00.0")
            End If
        End If
        SUS.Cells(RNo, CNo).Value = PhanTram
    Next
End Function
Function TBF42_CreatNote(WS As Worksheet, SUS As Worksheet)
'Xac dinh chieu dai text lon nhat va co dau cham khong
    Dim RowNo As Integer
    Dim ColumnNo As Integer
    Dim MaxLengthText_GouKei As String
    Dim MaxLengthText_GaiChuu As String
    Dim MaxLengthText_JinIn As String
    Dim MaxLengthText_TrungBinh As String
    Dim TmpText As String
    For ColumnNo = 48 To 52
        For RowNo = 5 To 14
            TmpText = SUS.Cells(RowNo, ColumnNo).Value
            Select Case RowNo
                Case 5, 11
                    If Len(TmpText) > Len(MaxLengthText_GouKei) Then MaxLengthText_GouKei = TmpText
                Case 6, 12
                    If Len(TmpText) > Len(MaxLengthText_GaiChuu) Then MaxLengthText_GaiChuu = TmpText
                Case 7, 13
                    If Len(TmpText) > Len(MaxLengthText_JinIn) Then MaxLengthText_JinIn = TmpText
                Case 8, 14
                    If Len(TmpText) > Len(MaxLengthText_TrungBinh) Then MaxLengthText_TrungBinh = TmpText
            End Select
        Next
    Next
'Define MaxSpaceQty
    Dim MaxSpaceQty_GouKei As Integer
    Dim MaxSpaceQty_GaiChuu As Integer
    Dim MaxSpaceQty_JinIn As Integer
    Dim MaxSpaceQty_TrungBinh As Integer
    MaxSpaceQty_GouKei = TBF44_ConvertTextLength2SpaceQty(MaxLengthText_GouKei)
    MaxSpaceQty_GaiChuu = TBF44_ConvertTextLength2SpaceQty(MaxLengthText_GaiChuu)
    MaxSpaceQty_JinIn = TBF44_ConvertTextLength2SpaceQty(MaxLengthText_JinIn)
    MaxSpaceQty_TrungBinh = TBF44_ConvertTextLength2SpaceQty(MaxLengthText_TrungBinh)
'Creat BeforeTextArr
    Dim BeforeTextArr(5 To 14, 48 To 52) As String
    Dim TmpSpaceQty As Integer
    Dim AddSpaceQty As Integer
    Dim BeforeText As String
    Dim TmpNote As String
    For ColumnNo = 48 To 52
        For RowNo = 5 To 14
            TmpText = SUS.Cells(RowNo, ColumnNo).Value
            TmpSpaceQty = TBF44_ConvertTextLength2SpaceQty(TmpText)
            Select Case RowNo
                Case 5, 11
                    AddSpaceQty = MaxSpaceQty_GouKei - TmpSpaceQty
                    If AddSpaceQty = 0 Then
                        BeforeText = SUS.Cells(RowNo - 1, ColumnNo).Value & TmpText
                    Else
                        BeforeText = SUS.Cells(RowNo - 1, ColumnNo).Value & TmpText & Space(AddSpaceQty)
                    End If
                Case 6, 12
                    AddSpaceQty = MaxSpaceQty_GaiChuu - TmpSpaceQty
                    If AddSpaceQty = 0 Then
                        BeforeText = SUS.Cells(RowNo, 47).Value & TmpText
                    Else
                        BeforeText = SUS.Cells(RowNo, 47).Value & TmpText & Space(AddSpaceQty)
                    End If
                Case 7, 13
                    AddSpaceQty = MaxSpaceQty_JinIn - TmpSpaceQty
                    TmpNote = SUS.Cells(RowNo, 47).Value
                    If AddSpaceQty = 0 Then
                        BeforeText = Replace(TmpNote, "xx.x", TmpText)
                    Else
                        BeforeText = Replace(TmpNote, "xx.x", TmpText) & Space(AddSpaceQty)
                    End If
                Case 8, 14
                    AddSpaceQty = MaxSpaceQty_TrungBinh - TmpSpaceQty
                    TmpNote = SUS.Cells(RowNo, 47).Value
                    If AddSpaceQty = 0 Then
                        BeforeText = Replace(TmpNote, "xx.x", TmpText)
                    Else
                        BeforeText = Replace(TmpNote, "xx.x", TmpText) & Space(AddSpaceQty)
                    End If
                Case 9
                    BeforeText = TmpText & "%"
                Case 10
                    BeforeText = ""
            End Select
            BeforeTextArr(RowNo, ColumnNo) = BeforeText
        Next
    Next
'Creat AfterTextArr
    Dim AfterTextArr(5 To 14, 48 To 52) As String
    Dim SpaceNhat As String: SpaceNhat = "@"
    Dim AfterText As String
    For ColumnNo = 48 To 52
        For RowNo = 5 To 14
            BeforeText = BeforeTextArr(RowNo, ColumnNo)
            Select Case RowNo
                Case 5, 11
                    Select Case ColumnNo
                        Case 48, 49, 50
                            AfterText = BeforeText & SpaceNhat & SpaceNhat & SpaceNhat
                        Case 51, 52
                            AfterText = BeforeText & SpaceNhat
                    End Select
                Case 6, 7, 8, 12, 13
                    AfterText = BeforeText & SpaceNhat
                Case 9, 10, 14
                    AfterText = BeforeText
            End Select
            AfterTextArr(RowNo, ColumnNo) = AfterText
        Next
    Next
'Creat NoteArr(MeiRowNo,GouKeiRowNo,MokuRowNo,MeiNote,GouKeiNote,MokuNote)
    Dim NoteArr(2 To 6, 0 To 5) As Variant
    Dim MeiRowNo As Integer
    Dim GouKeiRowNo As Integer
    Dim MokuRowNo As Integer
    Dim MeiNote As String
    Dim GouKeiNote As String
    Dim MokuNote As String
    For i = 2 To 6
        MeiRowNo = SUS.Cells(i, 43).Value
        GouKeiRowNo = SUS.Cells(i, 44).Value
        MokuRowNo = SUS.Cells(i, 45).Value
        NoteArr(i, 0) = MeiRowNo
        NoteArr(i, 1) = GouKeiRowNo
        NoteArr(i, 2) = MokuRowNo
    Next
    For ColumnNo = 48 To 52
        MeiNote = SUS.Cells(7, ColumnNo).Value
        MeiNote = MeiNote & Tukhoa5
        NoteArr(ColumnNo - 46, 3) = MeiNote
    Next
    For ColumnNo = 48 To 52
        GouKeiNote = ""
        MokuNote = ""
        For RowNo = 5 To 9
            AfterText = AfterTextArr(RowNo, ColumnNo)
            GouKeiNote = GouKeiNote & AfterText
        Next
        For RowNo = 11 To 14
            AfterText = AfterTextArr(RowNo, ColumnNo)
            MokuNote = MokuNote & AfterText
        Next
        NoteArr(ColumnNo - 46, 4) = GouKeiNote
        NoteArr(ColumnNo - 46, 5) = MokuNote
    Next
'Write to WS sheet
    For i = 2 To 6
        MeiRowNo = NoteArr(i, 0)
        GouKeiRowNo = NoteArr(i, 1)
        MokuRowNo = NoteArr(i, 2)
        MeiNote = NoteArr(i, 3)
        GouKeiNote = NoteArr(i, 4)
        MokuNote = NoteArr(i, 5)
        If MeiRowNo > 0 Then WS.Cells(MeiRowNo, 3).Value = MeiNote
        If GouKeiRowNo > 0 Then WS.Cells(GouKeiRowNo, 2).Value = GouKeiNote
        If MokuRowNo > 0 Then WS.Cells(MokuRowNo, 2).Value = MokuNote
    Next
End Function
Function TBF44_ConvertTextLength2SpaceQty(InputText As String) As Integer
    Dim CoDauCham As Integer
    Dim TextLength As Integer
    Dim SpaceQty As Integer
    If InStr(InputText, ".") <> 0 Then CoDauCham = 1
    TextLength = Len(InputText)
    SpaceQty = TextLength * 2 - CoDauCham
    TBF44_ConvertTextLength2SpaceQty = SpaceQty
End Function
Function TBF45_DefineColorColumnFrom_ColorColumnTo_ColorNumber(WS As Worksheet, RowNo As Integer, ColorColumnFrom As Integer, ColorColumnTo As Integer, ColorNumber As Long)
'Setting
    Dim ColorRefRow As Integer: ColorRefRow = 4
    Dim ColumnFrom As Integer: ColumnFrom = 6
    Dim ColumnTo As Integer: ColumnTo = 36
'Define ColorInder,Comment,ColorColumnFrom
    Dim CheckColor As Variant
    Dim i As Integer
    For i = ColumnFrom To ColumnTo
        CheckColor = TBF1810_CheckSatSunDayOffColorIndex(WS, RowNo, i)
        If VarType(CheckColor) <> vbBoolean Then
            ColorNumber = CheckColor
            ColorColumnFrom = i
            GoTo ExitFor
        End If
    Next
ExitFor:
'Define ColorColumnTo
    For i = ColumnTo To ColumnFrom Step -1
        CheckColor = TBF1810_CheckSatSunDayOffColorIndex(WS, RowNo, i)
        If VarType(CheckColor) <> vbBoolean Then
            ColorColumnTo = i
            GoTo ExitFor2
        End If
    Next
ExitFor2:
End Function
Function TBF46_BackupColor(BackupColorArr() As Variant)
'Define DataSheet and SetupSheet
    Dim WS As Worksheet
    Set WS = ThisWorkbook.ActiveSheet
'Define RowFrom, RowTo, ColumnFrom, ColumnTo
    Dim RowFrom As Integer: RowFrom = 5
    Dim RowTo As Integer
    Dim ColumnFrom As Integer: ColumnFrom = 6
    Dim ColumnTo As Integer: ColumnTo = 36
    Call TBF43_DefineRowEndNo_ByColor(WS, RowTo, 2)
'Backup Color(ColorColumnFrom, ColorColumnTo,ColorNumber
    ReDim BackupColorArr(RowFrom To RowTo, 0 To 2)
    Dim RowNo As Integer
    Dim ColorColumnFrom As Integer
    Dim ColorColumnTo As Integer
    Dim ColorNumber As Long
    For RowNo = RowFrom To RowTo
        ColorColumnFrom = 0
        ColorColumnTo = 0
        ColorNumber = 0
        Call TBF45_DefineColorColumnFrom_ColorColumnTo_ColorNumber(WS, RowNo, ColorColumnFrom, ColorColumnTo, ColorNumber)
        BackupColorArr(RowNo, 0) = ColorColumnFrom
        BackupColorArr(RowNo, 1) = ColorColumnTo
        BackupColorArr(RowNo, 2) = ColorNumber
    Next
End Function
Function TBF47_RestoreColor(BackupColorArr() As Variant)
'Define DataSheet and SetupSheet
    Dim WS As Worksheet
    Set WS = ThisWorkbook.ActiveSheet
    Dim RowFrom As Integer: RowFrom = 5
    Dim RowTo As Integer
    Dim ColumnFrom As Integer: ColumnFrom = 6
    Dim ColumnTo As Integer: ColumnTo = 36
    Call TBF43_DefineRowEndNo_ByColor(WS, RowTo, 2)
    Dim RefValue As String
    Dim RefRow As Integer: RefRow = 4
    Dim RowNo As Integer
    Dim ColumnNo As Integer
    Dim FillColorRange As Range
    Dim ColorColumnFrom As Integer
    Dim ColorColumnTo As Integer
    Dim ColorNumber As Long
    For RowNo = RowFrom To RowTo
        ColorColumnFrom = BackupColorArr(RowNo, 0)
        ColorColumnTo = BackupColorArr(RowNo, 1)
        ColorNumber = BackupColorArr(RowNo, 2)
        If ColorNumber <> 0 Then
            For ColumnNo = ColorColumnFrom To ColorColumnTo
                RefValue = WS.Cells(RefRow, ColumnNo).Value
                If RefValue <> "" Then
                    Set FillColorRange = WS.Cells(RowNo, ColumnNo)
                    FillColorRange.Interior.Color = ColorNumber
                End If
            Next
        End If
    Next
End Function


Function TBF48_CreatNewSheet(NewEditMode As String)
'Get Filename from Inputbox
'InputBox(prompt[,title][,default][,xpos][,ypos][,helpfile,context])
    Dim StrTitle As String
    Dim StrDefautValue As String
    Dim StrPrompt As String
    StrPrompt = "V‹KƒV[ƒg–¼‚ð‹L“ü‚µ‚Ä‰º‚³‚¢B"
    Dim InputBoxType As Integer: InputBoxType = 2 'chuoi ki tu
    Dim StrResult As Variant
    StrResult = Application.InputBox(StrPrompt, StrTitle, StrDefautValue, , , , , InputBoxType)
    If VarType(StrResult) = vbBoolean Then StrResult = ""
'Creat NewSheet
    Dim BeforeSheet As Worksheet
    Dim OriginSheet As Worksheet
    Dim AfterSheet As Worksheet
    Set OriginSheet = ThisWorkbook.Sheets("Œ´–{")
    Set BeforeSheet = ThisWorkbook.ActiveSheet
    Select Case NewEditMode
        Case "New"
            OriginSheet.Copy After:=Sheets(Sheets.Count)
        Case "Edit"
            BeforeSheet.Copy After:=Sheets(Sheets.Count)
    End Select
    Set AfterSheet = Sheets(Sheets.Count)
    AfterSheet.Visible = xlSheetVisible
    If StrResult <> "" Then
        AfterSheet.Name = StrResult
    End If
    AfterSheet.Select
    BeforeSheet.Visible = xlSheetHidden
End Function

buianhtuan.cdt · ‎02-01-2022

Function HCF4243_CreatLineOfCircleSSWith2Point(PointArr As Variant, MinPoint As Variant, MaxPoint As Variant, LineDirection As String, LineExt As Double, LayerName As String)

'Define pi
    Dim Pi As Double:    Pi = 4 * Atn(1)
    
'Creat XYArr From CenterPointArr
    Dim XYPointArr As Variant
    Select Case LineDirection
        Case "X"
            XYPointArr = HCF4108_CreatXYPointFromPointArr(PointArr, "Y")
        Case "Y"
            XYPointArr = HCF4108_CreatXYPointFromPointArr(PointArr, "X")
    End Select
    If VarType(XYPointArr) = vbBoolean Then
        Exit Function
    End If
    
'Draw OriginLine
    Dim OriginLine As AcadLine
    Dim OCLMinPoint As Variant
    Dim OCLMaxPoint As Variant
    Select Case LineDirection
        Case "X"
            OCLMinPoint = Thisdrawing.Utility.PolarPoint(MinPoint, Pi, LineExt)
            OCLMaxPoint = Thisdrawing.Utility.PolarPoint(MaxPoint, 0, LineExt)
        Case "Y"
            OCLMinPoint = Thisdrawing.Utility.PolarPoint(MinPoint, -Pi / 2, LineExt)
            OCLMaxPoint = Thisdrawing.Utility.PolarPoint(MaxPoint, Pi / 2, LineExt)
    End Select
    Set OriginLine = Thisdrawing.ModelSpace.AddLine(OCLMinPoint, OCLMaxPoint)
    OriginLine.Layer = LayerName
    
'Creat Line of Circle
    Dim EachPoint As Variant
    Dim EachLine As AcadLine
    For i = LBound(XYPointArr) To UBound(XYPointArr)
        EachPoint = XYPointArr(i)
        Select Case LineDirection
            Case "X"
                Call HCF4108_Call_CopyObjXorY(OriginLine, MinPoint, EachPoint, "Y")
            Case "Y"
                Call HCF4108_Call_CopyObjXorY(OriginLine, MinPoint, EachPoint, "X")
        End Select
    Next
    OriginLine.Delete
End Function

Sub HCS3150_ChangeColor2ByBlock()
'(TB VBABoss) Change Color 2 ByBlock,[BB]
    Thisdrawing.Utility.Prompt vbCrLf & "(TB VBABoss) Change Color 2 ByBlock" & vbLf
    
'Setting Public
    Call HCF0000_SetPublic
    
'Select Object
    Dim SS As AcadSelectionSet: Set SS = Thisdrawing.SelectionSets.Add("SS" & Now)
    SS.SelectOnScreen
    If SS.Count = 0 Then
        SS.Delete
        Exit Sub
    End If
    
'Change Color 2 ByBlock
    Dim EachEntity As AcadEntity
    Dim EachLayerName As String
    For Each EachEntity In SS
        EachLayerName = EachEntity.Layer
        Select Case EachLayerName
            Case Pb01_NormalLayerName
                EachEntity.Layer = "0"
                EachEntity.Color = acByBlock
            Case Else
                EachEntity.Color = acByBlock
        End Select
    Next
    SS.Delete

End Sub
Sub HCS3151_KKS_CheckZubanWithFilename()
'(TB VBABoss) KKS_CheckZubanWithFilename

'Setting Public
    Call HCF0000_SetPublic
    
'Check ProjectName
    If ProjectName <> "KKS" Then Exit Sub

'Get Part Property Block
    Dim TitleBlock As AcadBlockReference
    Set TitleBlock = HCF4004_GetPartPropertyBlockRef(Thisdrawing)
    If TitleBlock Is Nothing Then
        Exit Sub
    End If
    
'Define Zuban From PPBlock
    Dim Seiban_PP As String
    Dim Zuban_PP As String
    Dim Sindo_PP As String
    Seiban_PP = HCF4005_GetAttValueOfPartPropertyBlockRef(Thisdrawing, TitleBlock, "製番")
    Zuban_PP = HCF4005_GetAttValueOfPartPropertyBlockRef(Thisdrawing, TitleBlock, "図番")
    Sindo_PP = HCF4005_GetAttValueOfPartPropertyBlockRef(Thisdrawing, TitleBlock, "進度")

'Define Zuban From Filename
    Dim StrSeiban As String
    Dim StrZuban As String
    Dim StrSindo As String
    Call HCF4241_GetSeibanZubanSindoFromFilename(StrSeiban, StrZuban, StrSindo)
    
'Check Zuban
    Dim ErrMsg As String
    If Seiban_PP <> StrSeiban Then
        ErrMsg = "Seiban Wrong"
    End If
    If Zuban_PP <> StrZuban Then
        If ErrMsg = "" Then
            ErrMsg = "Zuban Wrong"
        Else
            ErrMsg = ErrMsg & vbNewLine & "Zuban Wrong"
        End If
    End If
    If Sindo_PP <> StrSindo Then
        If ErrMsg = "" Then
            ErrMsg = "Sindo Wrong"
        Else
            ErrMsg = ErrMsg & vbNewLine & "Sindo Wrong"
        End If
    End If
    
'MsgBox
    If ErrMsg = "" Then
        Exit Sub
    Else
        MsgBox ErrMsg
    End If
End Sub
Sub HCS3152_KSS_Balloon_2BallIsMirrorPart()
'(TB VBABoss)KSS Balloon 2 Ball Is Mirror Part,[BMI]
    Thisdrawing.Utility.Prompt vbCrLf & "(TB VBABoss)KSS Balloon 2 Ball Is Mirror Part,[BMI]" & vbLf

'Settings
    Dim MirrorMaker As String: MirrorMaker = "*"
    Dim MirrorNote As String: MirrorNote = "(xxxxMIRROR)"
    Dim MirrorColor As AcColor: MirrorColor = acBlue
    Dim ZuBan_TagName As String: ZuBan_TagName = "ITEM"
    Dim HinMei_TagName As String: HinMei_TagName = "JOB"

'Select 2 Balloon
    Dim SS As AcadSelectionSet
    Dim Ball1 As AcadBlockReference
    Dim Ball2 As AcadBlockReference
    Set SS = Thisdrawing.SelectionSets.Add("SS" & Now)
    Dim FT(0) As Integer
    Dim FD(0) As Variant
    FT(0) = 0: FD(0) = "INSERT"
    Thisdrawing.Utility.Prompt (vbCrLf & "Select Only 2 Balloon to Write Mirror Note:")
    SS.SelectOnScreen FT, FD
    If SS.Count <> 2 Then
        SS.Delete
        Exit Sub
    Else
        Set Ball1 = SS.Item(0)
        Set Ball2 = SS.Item(1)
    End If

'Define PartNo1, PartNo2
'Define HinMei1, HinMei2
    Dim PartNo1 As String
    Dim PartNo2 As String
    Dim HinMei1 As String
    Dim HinMei2 As String
    Dim varAttributes As Variant
    Dim TextString As String
    varAttributes = Ball1.GetAttributes
    For i = LBound(varAttributes) To UBound(varAttributes)
        TextString = varAttributes(i).TextString
        Select Case varAttributes(i).TagString
            Case ZuBan_TagName
                PartNo1 = Right(TextString, 4)
            Case HinMei_TagName
                HinMei1 = TextString
        End Select
    Next
    
    varAttributes = Ball2.GetAttributes
    For i = LBound(varAttributes) To UBound(varAttributes)
        TextString = varAttributes(i).TextString
        Select Case varAttributes(i).TagString
            Case ZuBan_TagName
                PartNo2 = Right(TextString, 4)
            Case HinMei_TagName
                HinMei2 = TextString
        End Select
    Next
    
'Define NewBallNo,NewHinMei
    Dim NewPartNo1 As String
    Dim NewPartNo2 As String
    Dim NewHinMei1 As String
    Dim NewHinMei2 As String
    NewPartNo1 = MirrorMaker & PartNo1
    NewPartNo2 = MirrorMaker & PartNo2
    NewHinMei1 = HinMei1 & MirrorNote
    NewHinMei2 = HinMei2 & MirrorNote
    NewHinMei1 = Replace(NewHinMei1, "xxxx", PartNo2)
    NewHinMei2 = Replace(NewHinMei1, "xxxx", PartNo1)
    
'Update PP
    varAttributes = Ball1.GetAttributes
    For i = LBound(varAttributes) To UBound(varAttributes)
        Select Case varAttributes(i).TagString
            Case ZuBan_TagName
                varAttributes(i).TextString = NewPartNo1
            Case HinMei_TagName
                varAttributes(i).TextString = NewHinMei1
        End Select
    Next
    
    varAttributes = Ball2.GetAttributes
    For i = LBound(varAttributes) To UBound(varAttributes)
        Select Case varAttributes(i).TagString
            Case ZuBan_TagName
                varAttributes(i).TextString = NewPartNo2
            Case HinMei_TagName
                varAttributes(i).TextString = NewHinMei2
        End Select
    Next

'Change Ball Color
    Ball1.Color = MirrorColor
    Ball2.Color = MirrorColor

    SS.Delete
    
End Sub
Sub HCS3153_KSS_Balloon_BallIsNewPart()
'(TB VBABoss)KSS Balloon Ball Is New Part,[BNEW]
    Thisdrawing.Utility.Prompt vbCrLf & "(TB VBABoss)KSS Balloon Ball Is New Part,[BNEW]" & vbLf

'Settings
    Dim NewPartMaker As String: NewPartMaker = "*"
    Dim NewPartColor As AcColor: NewPartColor = acMagenta
    Dim ZuBan_TagName As String: ZuBan_TagName = "ITEM"
    Dim HinMei_TagName As String: HinMei_TagName = "JOB"

'Select Balloon
    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) = "INSERT"
    Thisdrawing.Utility.Prompt (vbCrLf & "Select Only 2 Balloon to Write Mirror Note:")
    SS.SelectOnScreen FT, FD
    If SS.Count = 0 Then
        SS.Delete
        Exit Sub
    End If

'Change HinMei, PartNo
    Dim EachPartNo As String
    Dim EachHinMei As String
    Dim varAttributes As Variant
    Dim TextString As String
    Dim EachBall As AcadBlockReference
    For Each EachBall In SS
        varAttributes = EachBall.GetAttributes
        For i = LBound(varAttributes) To UBound(varAttributes)
            TextString = varAttributes(i).TextString
            Select Case varAttributes(i).TagString
                Case ZuBan_TagName
                    EachPartNo = NewPartMaker & Right(TextString, 4)
                    varAttributes(i).TextString = EachPartNo
                Case HinMei_TagName
                    EachHinMei = TextString
                    EachHinMei = Replace(EachHinMei, "USED", "REF")
                    varAttributes(i).TextString = EachHinMei
            End Select
        Next
        EachBall.Color = NewPartColor
    Next

    SS.Delete
End Sub
Sub HCS3154_CreatHiddenLineOfCircle()
'(TB VBABoss)Creat Hidden Line Of Circle,[CHL]
    Thisdrawing.Utility.Prompt (vbCrLf & "(TB VBABoss)Creat Hidden Line Of Circle") & vbCrLf
    
'Setting Layer
    Call HCF0000_SetPublic
    Dim CLLayer As String
    Dim HiddenLayer As String
    CLLayer = Pb05_CenterLayerName
    HiddenLayer = Pb04_HiddenLayerName
    
   
'Othor On
    Thisdrawing.SetVariable "ORTHOMODE", 1
    
'Define ExtDistance of Centerline
    Dim CenterLineExt As Double
    Call HCF4104_Call_SettingCenterLineExtendDistance(CenterLineExt)
    
'Select Circle
    Thisdrawing.Utility.Prompt (vbCrLf & "Select Circles")
    Dim SS As AcadSelectionSet
    Set SS = Thisdrawing.SelectionSets.Add("SelectOnScreen" & Now)
    Dim FT(0) As Integer: Dim FD(0) As Variant
    FT(0) = 0:  FD(0) = "CIRCLE"
    SS.SelectOnScreen FT, FD
    If SS.Count = 0 Then
        SS.Delete
        Exit Sub
    End If
    
'Select 2 Point
'Result (Point1,Point2,Distance,Angle,Direction,MinX,MaxX,MinY,MaxY,MinPoint,MaxPoint)
    Dim Msg1 As String: Msg1 = "Select Point1"
    Dim Msg2 As String: Msg2 = "Select Point2(Perpendicular)"
    Dim Get2Point As Variant
    Dim Direction As String
    Dim MinPoint As Variant
    Dim MaxPoint As Variant
    Get2Point = HCF4101_Get2Point(Msg1, Msg2)
    If VarType(Get2Point) = vbBoolean Then
        Exit Sub
    End If
    Direction = Get2Point(4)
    MinPoint = Get2Point(9)
    MaxPoint = Get2Point(10)
    
'Creat CenterPointArr
    Dim CenterPointArr As Variant
    CenterPointArr = HCF4107_CreatCenterPointArrFromSelectSet_Circle_Arc_Block(SS)
    If VarType(CenterPointArr) = vbBoolean Then
        Exit Sub
    End If
    
'Creat QuadPointArr
    Dim QuadPointArr As Variant
    QuadPointArr = HCF4242_CreatQuadPointArrOfCircleSS(SS, Direction, 2)

'Creat Centerline
    Call HCF4243_CreatLineOfCircleSSWith2Point(CenterPointArr, MinPoint, MaxPoint, Direction, CenterLineExt, CLLayer)
    
'Creat HiddenLine Of Circle
    Call HCF4243_CreatLineOfCircleSSWith2Point(QuadPointArr, MinPoint, MaxPoint, Direction, 0, HiddenLayer)

End Sub
Sub HCS3155_KSS_Balloon_ChangeBetweenNormalBallRefBall()
'(TB VBABoss)KSS Ball Change Between NormalBall RefBall,[BREF]
    Thisdrawing.Utility.Prompt (vbCrLf & "(TB VBABoss)Creat Hidden Line Of Circle") & vbCrLf
'Setting Blockname
    Dim NormalBlockname As String: NormalBlockname = "PARTBALLOON"
    Dim RefBlockname As String: RefBlockname = "MATEBALLOON"

'Select Balloon
    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) = "INSERT"
    Thisdrawing.Utility.Prompt (vbCrLf & "Select Balloon to Change Between Normal and Ref:")
    SS.SelectOnScreen FT, FD
    If SS.Count = 0 Then
        SS.Delete
        Exit Sub
    End If
    
'Process
    Dim EachBall As AcadBlockReference
    Dim EachEffectiveName As String
    Dim EachInsertBlockname As String
    Dim EachXScale As Integer
    Dim EachYScale As Integer
    Dim EachZScale As Integer
    Dim EachRotationAngle As Double
    Dim EachInsertPoint As Variant
    Dim EachNewBall As AcadBlockReference
    Dim OldDynamicPPArr As Variant
    Dim NewDynamicPPArr As Variant
    Dim OldvarAttributes As Variant
    Dim NewvarAttributes As Variant
    Dim EachOldValue As Variant
    Dim EachNewValue() As Variant
    
    For Each EachBall In SS
        'Define InsertBlockname
            EachEffectiveName = EachBall.EffectiveName
            Select Case EachEffectiveName
                Case NormalBlockname
                    EachInsertBlockname = RefBlockname
                Case RefBlockname
                    EachInsertBlockname = NormalBlockname
            End Select
        
        'Define Scale and Rotate Angle
            EachXScale = EachBall.XScaleFactor
            EachYScale = EachBall.YScaleFactor
            EachZScale = EachBall.ZScaleFactor
            EachRotationAngle = EachBall.Rotation
            EachInsertPoint = EachBall.InsertionPoint
            
        'Insert NewBall
            Set EachNewBall = Thisdrawing.ModelSpace.InsertBlock(EachInsertPoint, EachInsertBlockname, EachXScale, EachYScale, EachZScale, EachRotationAngle)
        
        'Copy Dynamic PP
            If EachBall.IsDynamicBlock = True And EachNewBall.IsDynamicBlock = True Then
                OldDynamicPPArr = EachBall.GetDynamicBlockProperties
                NewDynamicPPArr = EachNewBall.GetDynamicBlockProperties
                For i = LBound(OldDynamicPPArr) To UBound(OldDynamicPPArr)
                    EachOldValue = OldDynamicPPArr(i).Value
                    If IsArray(EachOldValue) <> True Then
                        NewDynamicPPArr(i).Value = EachOldValue
                    End If
                Next
            End If
            
        'Copy AttValue
            If EachBall.HasAttributes = True And EachNewBall.HasAttributes = True Then
                OldvarAttributes = EachBall.GetAttributes
                NewvarAttributes = EachNewBall.GetAttributes
                For i = LBound(OldvarAttributes) To UBound(OldvarAttributes)
                    NewvarAttributes(i).TextString = OldvarAttributes(i).TextString
                Next
            End If
    Next
    
'Delete
    SS.Erase
    SS.Delete
    
End Sub




Sub HCS3086_BalloonNoSearch()
'(VBA AutoCad) Balloon No Search,[BNS]
    Thisdrawing.Utility.Prompt vbCrLf & "(VBA AutoCad) Balloon No Search,[BNS]" & vbLf

'Setting SearchTagString
    Dim SearchTagString As String
    SearchTagString = "ITEM"

'Get Balloon Number
    Dim SearchBalloonNo As String
    Dim GetString As Variant
    GetString = HCF4049_GetString(Thisdrawing, False, vbCr & "Search Balloon No:", False)
    If VarType(GetString) = vbBoolean Then
        Exit Sub
    Else
        SearchBalloonNo = GetString
        SearchBalloonNo = UCase(SearchBalloonNo)
    End If

'Select All Block in Thisdrawing
    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) = "INSERT"
    SS.Select acSelectionSetAll, , , FT, FD
    If SS.Count = 0 Then
        SS.Delete
        Exit Sub
    End If
    
'Creat SearchResultArr
    Dim SearchResultArr() As Variant
    Dim EachBlockRef As AcadBlockReference
    Dim varAttributes As Variant
    Dim EachTagValue As String
    Dim EachTextValue As String

    For Each EachBlockRef In SS
        If EachBlockRef.IsDynamicBlock = True And EachBlockRef.HasAttributes = True Then
            varAttributes = EachBlockRef.GetAttributes
            For i = LBound(varAttributes) To UBound(varAttributes)
                EachTagValue = varAttributes(i).TagString
                If EachTagValue = SearchTagString Then
                    EachTextValue = varAttributes(i).TextString
                    If InStr(EachTextValue, SearchBalloonNo) <> 0 Then
                        ReDim Preserve SearchResultArr(0 To k)
                        Set SearchResultArr(k) = EachBlockRef
                        k = k + 1
                    End If
                End If
            Next
        End If
    Next
    SS.Delete
    If k = 0 Then
        MsgBox "No Balloon"
        Exit Sub
    End If
    
'Show Result
    Dim MinPoint As Variant
    Dim MaxPoint As Variant
    Dim Balloon As AcadBlockReference
    Dim Response As VbMsgBoxResult
    For i = LBound(SearchResultArr) To UBound(SearchResultArr)
        Set Balloon = SearchResultArr(i)
        Balloon.GetBoundingBox MinPoint, MaxPoint
        Application.ZoomWindow MinPoint, MaxPoint
        If k > 1 And i < UBound(SearchResultArr) Then
            Response = MsgBox("Continue", vbYesNo)
            Select Case Response
                Case vbYes
                Case vbNo
                    Exit Sub
            End Select
        End If
    Next
End Sub
Function HCF4240_CreatCenterPointArrFromCircleBlockRefArr(ObjArr As Variant, RoundMode As Integer) As Variant

'Defaut Value
    HCF4240_CreatCenterPointArrFromCircleBlockRefArr = False
    
'Check ObjArr is Array
    If Func70IsEmptyArray(ObjArr) = True Then Exit Function
    
'Creat ObjArrCenter
    Dim CenterPointArr() As Variant
    Dim IsInArr As Boolean
    Dim f As Integer

    Dim EachBlockRef As AcadBlockReference
    Dim EachCircle As AcadCircle
    Dim EachEntity As AcadEntity
    Dim EachCenterPoint As Variant
    For i = LBound(ObjArr) To UBound(ObjArr)
        Set EachEntity = ObjArr(i)
        Select Case EachEntity.ObjectName
            Case "AcDbBlockReference"
                Set EachBlockRef = EachEntity
                EachCenterPoint = EachBlockRef.InsertionPoint
            Case "AcDbCircle"
                Set EachCircle = EachEntity
                EachCenterPoint = EachCircle.center
            Case Else
                GoTo GTNS1
        End Select
        
        If f = 0 Then
            IsInArr = False
        Else
            IsInArr = HCF4173_PointAIsInPointArr(CenterPointArr, EachCenterPoint, RoundMode)
        End If
        
        If IsInArr = False Then
            ReDim Preserve CenterPointArr(0 To f)
            CenterPointArr(f) = EachCenterPoint
            f = f + 1
        End If
GTNS1:
    Next
    If f > 0 Then
        HCF4240_CreatCenterPointArrFromCircleBlockRefArr = CenterPointArr
    End If

End Function
Function HCF4241_GetSeibanZubanSindoFromFilename(StrSeiban As String, StrZuban As String, StrSindo As String)

'Define Filename
    Dim StrFileName As String
    StrFileName = Thisdrawing.Name
    StrFileName = Before_(StrFileName, ".")

'Define Seiban,Zuban,Sindo
    Dim ArrSplit As Variant
    Dim Delimited As String: Delimited = "-"
    ArrSplit = Split(StrFileName, Delimited)
    Select Case UBound(ArrSplit)
        Case 1
            StrSeiban = ArrSplit(0)
            StrZuban = ArrSplit(1)
            StrSindo = "0"
        Case 2
            StrSeiban = ArrSplit(0)
            StrZuban = ArrSplit(1)
            StrSindo = ArrSplit(2)
            If StrSindo = "00" Then StrSindo = "0"
    End Select
    
End Function
Function HCF4242_CreatQuadPointArrOfCircleSS(CircleSS As AcadSelectionSet, XorY As String, RoundMode As Integer) As Variant
'Defaut Value
    HCF4242_CreatQuadPointArrOfCircleSS = False
    
'Define pi
    Dim Pi As Double:    Pi = 4 * Atn(1)
    
'Check Input
    If CircleSS.Count = 0 Then
        Exit Function
    End If
    
'Creat Arr
    Dim QuadPointArr() As Variant
    Dim EachCircle As AcadCircle
    Dim EachQuadPoint1 As Variant
    Dim EachQuadPoint2 As Variant
    Dim EachQuadPoint3 As Variant
    Dim EachQuadPoint4 As Variant
    Dim EachCenterPoint As Variant
    Dim EachR As Double
    Dim IsInArr1 As Boolean
    Dim IsInArr2 As Boolean
    Dim IsInArr3 As Boolean
    Dim IsInArr4 As Boolean
    Dim f As Integer

    For Each EachCircle In CircleSS
        EachCenterPoint = EachCircle.center
        EachR = EachCircle.Radius
        EachQuadPoint1 = Thisdrawing.Utility.PolarPoint(EachCenterPoint, 0, EachR)
        EachQuadPoint2 = Thisdrawing.Utility.PolarPoint(EachCenterPoint, Pi / 2, EachR)
        EachQuadPoint3 = Thisdrawing.Utility.PolarPoint(EachCenterPoint, Pi, EachR)
        EachQuadPoint4 = Thisdrawing.Utility.PolarPoint(EachCenterPoint, 3 * Pi / 2, EachR)

        If f = 0 Then
            IsInArr1 = False
            IsInArr2 = False
            IsInArr3 = False
            IsInArr4 = False
        Else
            IsInArr1 = HCF4173_PointAIsInPointArr(QuadPointArr, EachQuadPoint1, RoundMode)
            IsInArr2 = HCF4173_PointAIsInPointArr(QuadPointArr, EachQuadPoint2, RoundMode)
            IsInArr3 = HCF4173_PointAIsInPointArr(QuadPointArr, EachQuadPoint3, RoundMode)
            IsInArr4 = HCF4173_PointAIsInPointArr(QuadPointArr, EachQuadPoint4, RoundMode)
        End If
        
        Select Case XorY
            Case "Y"
                If IsInArr1 = False Then
                    ReDim Preserve QuadPointArr(0 To f)
                    QuadPointArr(f) = EachQuadPoint1
                    f = f + 1
                End If
                If IsInArr3 = False Then
                    ReDim Preserve QuadPointArr(0 To f)
                    QuadPointArr(f) = EachQuadPoint3
                    f = f + 1
                End If
            Case "X"
                If IsInArr2 = False Then
                    ReDim Preserve QuadPointArr(0 To f)
                    QuadPointArr(f) = EachQuadPoint2
                    f = f + 1
                End If
                If IsInArr4 = False Then
                    ReDim Preserve QuadPointArr(0 To f)
                    QuadPointArr(f) = EachQuadPoint4
                    f = f + 1
                End If
        End Select
    Next
    
'Result
    HCF4242_CreatQuadPointArrOfCircleSS = QuadPointArr

End Function
Function HCF4037X_MoveBlockToBlock(MyDrawing As AcadDocument, MoveCopy As String)

'Select Obj to Move or Copy
    Dim MoveObjArr As Variant
    MoveObjArr = HCF4035_SelectOnScreenByType(MyDrawing, "INSERT", "CIRCLE", "LINE", "", "")
    If Func70IsEmptyArray(MoveObjArr) = True Then Exit Function
'Define MoveObjArrCenter
    Dim MoveObjArrCenter As Variant
    MoveObjArrCenter = HCF4036X_DefineCenterOfObjArr(MoveObjArr)
    If Func70IsEmptyArray(MoveObjArrCenter) = True Then Exit Function
    

    Dim ToObjArr As Variant
    Dim ToObjArrCenter As Variant
    Dim EachEntity As AcadEntity
    Dim EachCopyEntiy As AcadEntity
    Dim EachCenterPoint As Variant
    
    Select Case MoveCopy
        Case "Move"
            'Select Move To Obj
            ToObjArr = HCF4035_SelectOnScreenByType(MyDrawing, "INSERT", "CIRCLE", "", "", "")
            If Func70IsEmptyArray(ToObjArr) = True Then Exit Function
            'Define ToObjArrCenter
            ToObjArrCenter = HCF4036X_DefineCenterOfObjArr(ToObjArr)
            If Func70IsEmptyArray(ToObjArrCenter) = True Then Exit Function
            'Move Obj
            For i = LBound(MoveObjArr) To UBound(MoveObjArr)
                Set EachEntity = MoveObjArr(i)
                EachEntity.Move MoveObjArrCenter, ToObjArrCenter
            Next
        Case "Copy"
            Do
                'Select Copy To Obj
                ToObjArr = HCF4035_SelectOnScreenByType(MyDrawing, "INSERT", "CIRCLE", "", "", "")
                If Func70IsEmptyArray(ToObjArr) = True Then Exit Function
                'Define ToObjArrCenter
                ToObjArrCenter = HCF4240_CreatCenterPointArrFromCircleBlockRefArr(ToObjArr, 2)
                If VarType(ToObjArrCenter) = vbBoolean Then Exit Function
                'Copy Obj
                For k = LBound(ToObjArrCenter) To UBound(ToObjArrCenter)
                    EachCenterPoint = ToObjArrCenter(k)
                    For i = LBound(MoveObjArr) To UBound(MoveObjArr)
                        Set EachEntity = MoveObjArr(i)
                        Set EachCopyEntiy = EachEntity.Copy
                        EachCopyEntiy.Move MoveObjArrCenter, EachCenterPoint
                    Next
                Next
                
            Loop While Func70IsEmptyArray(ToObjArrCenter) = False
    End Select
End Function

buianhtuan.cdt · ‎02-01-2022

;(TB VBABoss) Change Color 2 ByBlock,[BB]
(defun C:BB()
(command "-vbarun" "HCS3150_ChangeColor2ByBlock")
)
;(VBA AutoCad) Balloon No Search,[BNS]
(defun C:BNS()
(command "-vbarun" "HCS3086_BalloonNoSearch")
)
;(TB VBABoss)KSS Balloon 2 Ball Is Mirror Part,[BMI]
(defun C:BMI()
(command "-vbarun" "HCS3152_KSS_Balloon_2BallIsMirrorPart")
)
;(TB VBABoss)KSS Balloon Ball Is New Part,[BNEW]
(defun C:BNEW()
(command "-vbarun" "HCS3153_KSS_Balloon_BallIsNewPart")
)
;(TB VBABoss)Creat Hidden Line Of Circle,[CHL]
(defun C:CHL()
(command "-vbarun" "HCS3154_CreatHiddenLineOfCircle")
)
;(TB VBABoss)KSS Ball Change Between NormalBall RefBall,[BREF]
(defun C:BREF()
(command "-vbarun" "HCS3155_KSS_Balloon_ChangeBetweenNormalBallRefBall")
)

Community

Get and set dynamic block property

Get and set dynamic block property

Get and set dynamic block property