VBA
Discuss AutoCAD ActiveX and VBA (Visual Basic for Applications) questions here.
cancel
Showing results for 
Show  only  | Search instead for 
Did you mean: 

Updating block definitions in a drawing via VBA

14 REPLIES 14
SOLVED
Reply
Message 1 of 15
leife
4098 Views, 14 Replies

Updating block definitions in a drawing via VBA

I have a large number of drawings that I need to update.  The update is to some text is a block.

 

If I was to do this manually I would either use bedit or redefine the block.

 

I would like to use VBA to locate the block and update some text inside the block.  I know in AutoLISP I could use tblsearch to locate the block and make updates.  I'm not sure now this is done using VBA.  Has anyone written some code to do this type of update?

 

Thanks.

14 REPLIES 14
Message 2 of 15
fixo
in reply to: leife

If it is text you have to open BlockDefinition and change a text in there,
but it would be constant for all block references, otherwise, create copy
of block per every drawing with other text, me think easier yet create attribute in the place of text then go after this way, just an idea, sorry
Message 3 of 15
fixo
in reply to: fixo

In addition see code example, just for quick test

Private Sub Text2Attr(oBlock As AcadBlock, oText As AcadText, pmt As String, tag As String, ByRef insPt As Variant)
Dim oAttrib As AcadAttribute
Dim strTxt As String

strTxt = oText.TextString
Set oAttrib = oBlock.AddAttribute(oText.Height, acAttributeModeNormal, pmt, insPt, tag, oText.TextString)

With oAttrib
.Backward = oText.Backward
.Layer = oText.Layer
.Linetype = oText.Linetype
.LinetypeScale = oText.LinetypeScale
.Lineweight = oText.Lineweight
.ObliqueAngle = oText.ObliqueAngle
.Rotation = oText.Rotation
.ScaleFactor = oText.ScaleFactor
.StyleName = oText.StyleName
.LockPosition = True
If oText.Alignment <> acAlignmentLeft Or oText.Alignment <> acAlignmentAligned Or oText.Alignment <> acAlignmentFit Then

.Alignment = oText.Alignment
.TextAlignmentPoint = insPt

End If
.TrueColor = oText.TrueColor
.Update
End With
oAttrib.Move oAttrib.insertionpoint, insPt
oAttrib.Update

Dim blkEnt As AcadEntity
For Each blkEnt In oBlock
If TypeOf blkEnt Is AcadText Then
Set oText = blkEnt
If oText.TextString = strTxt Then
oText.Delete
Set oText = Nothing

Exit For
End If
End If
Next

ThisDrawing.SendCommand ("_attsync N " & oBlock.Name & vbCr)
ThisDrawing.Regen acAllViewports 'optional
End Sub


Sub Att_test()

Dim Ent As AcadEntity
Dim oText As AcadText
Dim varPt As Variant
Dim tmx As Variant, ctx As Variant
On Error Resume Next
Do

  ThisDrawing.Utility.GetSubEntity Ent, varPt, tmx, ctx, "Select text in the block instance: "
If Err.Number = -2147352567 Then
   MsgBox "missed, try again"
      Exit Sub
End If
   If Ent Is Nothing Then Exit Do
    If Not TypeOf Ent Is AcadText Then
     MsgBox "not a text"
      Exit Sub
    End If
    
     If TypeOf Ent Is AcadText Then Set oText = Ent
     
     Dim blkObj As AcadObject
     Dim blkDef As AcadBlock
     Set blkObj = ThisDrawing.ObjectIdToObject(oText.OwnerID)
     Set blkDef = blkObj
     
     MsgBox blkDef.Name
     Dim orig As Variant
     orig = blkDef.Origin
     Dim insPt As Variant
     insPt = oText.insertionpoint
     Dim posPt As Variant
     posPt = ThisDrawing.Utility.TranslateCoordinates(insPt, acUCS, acWorld, True)
Dim tag As String
tag = InputBox(vbCr & "Enter attribute tag: ", "Attribute Tag", "MYTAG")
Dim pmt As String
pmt = InputBox(vbCr & "Enter attribute prompt: ", "Attribute Prompt", "MyPrompt")
  
Call Text2Attr(blkDef, oText, pmt, UCase(tag), posPt)

Set Ent = Nothing
Loop While Err.Number <> -2147352567

End Sub

 

Message 4 of 15
leife
in reply to: fixo

Thanks very much for the coding.

 

However, I think it really should be text instead of an attribute.  An attribute would work, but I think text makes more sense in this context.

 

I was able to develop a routine to make the update for me.  Below is the routine.  I hope this is useful for those that may need to make a similar change.  It requires passing an AutoCAD document, the name of the block, and the old and new text.  

 

Public Sub putBlkText(acadDoc As AcadDocument, BlkName As String, OldText As String, NewText As String)
    Dim blks As AcadBlocks
    Dim blk As AcadBlock
    Dim en As AcadEntity
    Dim enTxt As AcadText

    Set blks = acadDoc.Blocks
    Set blk = blks(BlkName)
    For Each en In blk
        If en.ObjectName = "AcDbText" Then
            Set enTxt = en
            If enTxt.TextString = OldText Then
                enTxt.TextString = NewText
                enTxt.Update
            End If
        End If
    Next en
End Sub

 

Message 5 of 15
buianhtuan.cdt
in reply to: leife

; Quick Block
; Creates a block instantly out of the objects that you select
(defun c:QCB (/ selectionset insertionpoint number Blockname)
;;; Tharwat 11. May. 2012 ;;
(if (and (setq selectionset (ssget "_:L"))
(setq insertionpoint (getpoint "\n Specify insertion point :"))
)
(progn
(setq number 1
Blockname (strcat "MyBlock" (itoa number))
)
(while (tblsearch "BLOCK" Blockname)
(setq Blockname
(strcat "MyBlock" (itoa (setq number (1+ number))))
)
)
(command "_.-Block" Blockname insertionpoint selectionset "")
(command "_.-insert" Blockname insertionpoint "" "" "")
)
(princ)
)
(princ)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Public Const LibraryPath As String = "C:\Users\buian\Desktop\TEST BRICS\TBLibrary"
'PageSize
Public Const A4X11 As Integer = 210
Public Const A3X11 As Integer = 420
Public Const A2X11 As Integer = 594
'=====================================================================================================
'=====================================================================================================
'=====================================================================================================
Sub TBR13Change2ByBlock()
'Change Entity in block to byBlock, [C2BB]

Dim RenameBlock As Boolean
Dim response As VbMsgBoxResult
Dim NewBlockname As String
'Ask rename block
response = MsgBox("Rename Block???", vbYesNoCancel)
Select Case response
Case vbYes
RenameBlock = True
NewBlockname = Thisdrawing.Utility.GetString(True, "New Block Name:" & vbCrLf)
Case vbNo
RenameBlock = False
Case vbCancel
Exit Sub
End Select
'Ask reset draft
Dim HiddenOrCenter2Draft As String
response = MsgBox("Reset Hidden or Center to Bylayer or Byblock???", vbYesNoCancel)
Select Case response
Case vbYes
HiddenOrCenter2Draft = "ResetDraft"
Case vbNo
HiddenOrCenter2Draft = ""
Case vbCancel
Exit Sub
End Select
Call Func5001_KKSChangeByBlockByLayerRenameBlock("ByBlock", HiddenOrCenter2Draft, RenameBlock, NewBlockname)

End Sub
Sub TBR14Change2ByLayer()
'Change Entity in block to byLayer, [C2BL]

Dim RenameBlock As Boolean
Dim response As VbMsgBoxResult
Dim NewBlockname As String
'Ask rename block
response = MsgBox("Rename Block???", vbYesNoCancel)
Select Case response
Case vbYes
RenameBlock = True
NewBlockname = Thisdrawing.Utility.GetString(True, "New Block Name:" & vbCrLf)
Case vbNo
RenameBlock = False
Case vbCancel
Exit Sub
End Select
'Ask reset draft
Dim HiddenOrCenter2Draft As String
response = MsgBox("Reset Hidden or Center to Bylayer or Byblock???", vbYesNoCancel)
Select Case response
Case vbYes
HiddenOrCenter2Draft = "ResetDraft"
Case vbNo
HiddenOrCenter2Draft = ""
Case vbCancel
Exit Sub
End Select
Call Func5001_KKSChangeByBlockByLayerRenameBlock("ByLayer", HiddenOrCenter2Draft, RenameBlock, NewBlockname)

End Sub
Sub TBR24ChangeHidden2Draft()
'(VBA AutoCad)Change layer Hidden Entity in block to Draft, [H2D]

Dim RenameBlock As Boolean
Dim response As VbMsgBoxResult
Dim NewBlockname As String
response = MsgBox("Rename Block???", vbYesNoCancel)
Select Case response
Case vbYes
RenameBlock = True
NewBlockname = Thisdrawing.Utility.GetString(True, "New Block Name:" & vbCrLf)
Case vbNo
RenameBlock = False
Case vbCancel
Exit Sub
End Select
Call Func5001_KKSChangeByBlockByLayerRenameBlock("", "Hidden2Draft", RenameBlock, NewBlockname)

End Sub
Sub TBR25ChangeCenter2Draft()
'(VBA AutoCad)Change layer Center Entity in block to Draft, [C2D]

Dim RenameBlock As Boolean
Dim response As VbMsgBoxResult
Dim NewBlockname As String
response = MsgBox("Rename Block???", vbYesNoCancel)
Select Case response
Case vbYes
RenameBlock = True
NewBlockname = Thisdrawing.Utility.GetString(True, "New Block Name:" & vbCrLf)
Case vbNo
RenameBlock = False
Case vbCancel
Exit Sub
End Select
Call Func5001_KKSChangeByBlockByLayerRenameBlock("", "Center2Draft", RenameBlock, NewBlockname)

End Sub
Sub TBR26SonBlockRename()
'(VBA AutoCad)Rename All Block in SelectSet, [SONRB], Son Rename Block

Dim RenameBlock As Boolean
Dim response As VbMsgBoxResult
Dim NewBlockname As String
RenameBlock = True
NewBlockname = Thisdrawing.Utility.GetString(True, "New Block Name:" & vbCrLf)

Call Func5001_KKSChangeByBlockByLayerRenameBlock("", "", RenameBlock, NewBlockname)

End Sub
Sub TBR27AddLimitPoint()
'(VBA AutoCad) Add Limit Point of SelectSet[LMP]
Thisdrawing.Utility.Prompt (vbCrLf & "Add Limit Point")

'Setting
Dim Mode As String
Dim ObjBlockRef As AcadBlockReference

'Select by SelectSet
Dim objSelectOnScreen As AcadSelectionSet
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
objSelectOnScreen.SelectOnScreen
If objSelectOnScreen.count = 0 Then
MsgBox "No Selected Entity"
objSelectOnScreen.Delete
Exit Sub
End If

'Define Mode
Dim CountEntity As Integer
Dim CountBlockRef As Integer
Dim EachEntity As AcadEntity
For Each EachEntity In objSelectOnScreen
If EachEntity.ObjectName = "AcDbBlockReference" Then
CountBlockRef = CountBlockRef + 1
Else
CountEntity = CountEntity + 1
End If
Next
If CountBlockRef > CountEntity Then
Mode = "BlockRef"
Else
Mode = "SelectSet"
End If
Select Case Mode
Case "SelectSet"
Call Func5004_LimitPointOfBlockOrSelectSet(Mode, objSelectOnScreen)
Case "BlockRef"
For Each EachEntity In objSelectOnScreen
If EachEntity.ObjectName = "AcDbBlockReference" Then
Set ObjBlockRef = EachEntity
Call Func5004_LimitPointOfBlockOrSelectSet(Mode, ObjBlockRef)
End If
Next
End Select
Thisdrawing.Regen (acActiveViewport)

End Sub
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Sub Sub4000_UpdateBlockFromOtherDrawing()
'(VBA AutoCad) Update Block From Other Drawing,[UB]

'1.Select file
Dim FilePath As String
FilePath = Excel.Application.GetOpenFilename(FileFilter:="Brics File (*.dwg),*.dwg", Title:="Choose Brics files", MultiSelect:=False)
If FilePath = "False" Then
MsgBox "No files selected"
Exit Sub
End If

'2.Get UpdateToDrawing
Dim UpdateToDrawing As AcadDocument
Set UpdateToDrawing = Thisdrawing

'3.Open UpdateFromDrawing
Dim UpdateFromDrawing As AcadDocument
Set UpdateFromDrawing = Application.Documents.Open(FilePath, True)
UpdateFromDrawing.Activate

'4.Creat List All Visible Block in UpdateFromDrawing
Dim UpdateFromBlocknameList() As Variant
Dim ObjSelectSet As AcadSelectionSet
Set ObjSelectSet = UpdateFromDrawing.SelectionSets.Add("ObjSelectSet" & Now)
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 0: FD(0) = "INSERT"
ObjSelectSet.Select acSelectionSetAll, , , FT, FD
UpdateFromBlocknameList = Func5006_CreatBlocknameArrFromSelectSet(UpdateFromDrawing, ObjSelectSet)
ObjSelectSet.Delete
If Func70IsEmptyArray(UpdateFromBlocknameList) = True Then
MsgBox "No Block for update"
Exit Sub
End If

'5.Close UpdatefromDrawing,Dont save
UpdateFromDrawing.Close False
UpdateToDrawing.Activate

'6.Creat Common Block of UpdateFromDrawing and UpdateToDrawing
Dim CommonBlockArr() As Variant
Dim EachBlockname As String
Dim EachBlock As AcadBlock
Dim k As Integer
For i = LBound(UpdateFromBlocknameList) To UBound(UpdateFromBlocknameList)
EachBlockname = UpdateFromBlocknameList(i)
If Func5005_IsBlockInDrawing(UpdateToDrawing, EachBlockname) = True Then
Set EachBlock = UpdateToDrawing.Blocks(EachBlockname)
ReDim Preserve CommonBlockArr(0 To k)
Set CommonBlockArr(k) = EachBlock
k = k + 1
End If
Next
If Func70IsEmptyArray(CommonBlockArr) = True Then
MsgBox "No common block for update"
Exit Sub
End If

'7.Rename Block in Common Block List
Dim OldBlockname As String
Dim NewBlockname As String
Dim UpdateBlocknameArr() As Variant
ReDim UpdateBlocknameArr(0 To UBound(CommonBlockArr), 0 To 1)
For i = LBound(CommonBlockArr) To UBound(CommonBlockArr)
Set EachBlock = CommonBlockArr(i)
OldBlockname = EachBlock.Name
NewBlockname = OldBlockname & "_UB" & Func31HourMinute
EachBlock.Name = NewBlockname
UpdateBlocknameArr(i, 0) = OldBlockname
UpdateBlocknameArr(i, 1) = NewBlockname
Next

'8.Import [UpdateFromDrawing] into [UpdateToDrawing]
Dim ScaleMode As String: ScaleMode = "NoScale"
Dim InsertPointMode As String: InsertPointMode = "Point00" '
Dim StrInsertPointX As Double
Dim StrInsertPointY As Double
Dim RotateAngle As Double
Dim DeleteExplode As String: DeleteExplode = "Delete"
'Define Pathname and blockname
Dim ExternalBlockname As String
ExternalBlockname = "UpdateBlock" & Func31HourMinute
Call Func5009_InsertExternalDrawing(UpdateToDrawing, FilePath, ExternalBlockname, ScaleMode, InsertPointMode, StrInsertPointX, StrInsertPointY, RotateAngle, DeleteExplode)

'9 Dim UpdateCount As Integer
For i = LBound(UpdateBlocknameArr) To UBound(UpdateBlocknameArr)
OldBlockname = UpdateBlocknameArr(i, 0)
NewBlockname = UpdateBlocknameArr(i, 1)
Call Func5013_ReplaceBlock(Thisdrawing, OldBlockname, NewBlockname)
' UpdateToDrawing.SendCommand "-BLOCKREPLACE" & vbCr & NewBlockname & vbCr & OldBlockname & vbCr & "N" & vbCr
UpdateCount = UpdateCount + 1
Next
UpdateToDrawing.Regen acAllViewports

MsgBox "Updated " & UpdateCount & " Blocks"

End Sub
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
';;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
';;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
';;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Function Func5000_CreatBlockArrFromSelectSet(objSelectOnScreen As AcadSelectionSet) As Variant
'Function tao list tat ca block co trong selectset

Dim MotherSonBlockArr() As Variant
Dim i As Integer
Dim EachBlockReference As AcadBlockReference
Dim EachBlock As AcadBlock
Dim EachBlockname As String
Dim EachEntity As AcadEntity

'Define MotherSonBlockArr(0)
Dim IsNormalBlock As Boolean
For Each EachEntity In objSelectOnScreen
If EachEntity.ObjectName = "AcDbBlockReference" Then
Set EachBlockReference = EachEntity
Set EachBlock = Thisdrawing.Blocks(EachBlockReference.Name)
If Func64IsNormalBlock(EachBlockReference) = True Then
ReDim Preserve MotherSonBlockArr(0)
Set MotherSonBlockArr(0) = EachBlock
GoTo NextStep01
End If
End If
Next

NextStep01:
'Add MotherBlock to MotherSonBlockArr
Dim CheckHave As Boolean
Dim TmpBlock As AcadBlock
i = 1
For Each EachEntity In objSelectOnScreen
If EachEntity.ObjectName = "AcDbBlockReference" Then
Set EachBlockReference = EachEntity
CheckHave = False
Set EachBlock = Thisdrawing.Blocks(EachBlockReference.Name)
For k = LBound(MotherSonBlockArr) To UBound(MotherSonBlockArr)
Set TmpBlock = MotherSonBlockArr(k)
If EachBlock.Name = TmpBlock.Name Then
CheckHave = True
End If
Next
If Func64IsNormalBlock(EachBlockReference) = True And CheckHave = False Then
ReDim Preserve MotherSonBlockArr(0 To i)
Set MotherSonBlockArr(i) = EachBlock
i = i + 1
End If
End If
Next

'Add SonBlock to MotherSonBlockArr
Dim MotherBlock As AcadBlock
Dim SonBlockRef As AcadBlockReference
Dim SonBlock As AcadBlock
Dim Tmpblockref As AcadBlockReference
Dim j As Integer
Do
Set MotherBlock = MotherSonBlockArr(j)
For Each EachEntity In MotherBlock
If EachEntity.ObjectName = "AcDbBlockReference" Then
CheckHave = False
Set SonBlockRef = EachEntity
Set SonBlock = Thisdrawing.Blocks(SonBlockRef.Name)
'Xac dinh xem block co ten trong list hay khong
For k = LBound(MotherSonBlockArr) To UBound(MotherSonBlockArr)
Set TmpBlock = MotherSonBlockArr(k)
If SonBlock.Name = TmpBlock.Name Then
CheckHave = True
End If
Next
'Bo qua anonymous block, att block, dynamic block
If CheckHave = False And Func64IsNormalBlock(SonBlockRef) = True Then
i = UBound(MotherSonBlockArr) + 1
ReDim Preserve MotherSonBlockArr(0 To i)
Set MotherSonBlockArr(i) = SonBlock
End If
End If
Next
j = j + 1
Loop While j <= UBound(MotherSonBlockArr)

Func5000_CreatBlockArrFromSelectSet = MotherSonBlockArr

End Function
Function Func5001_KKSChangeByBlockByLayerRenameBlock(ByLayerOrByBlock As String, HiddenOrCenter2Draft As String, RenameBlock As Boolean, NewBlockname As String)

'1: Change ByLayer or Byblock
' Change to Bylayer: Linetype=Bylayer, Lineweight=bylayer,linetypescale=1,color=bylayer, normallayer in block to layer0
' Change to ByBlock: Linetype=Bylayer, Lineweight=bylayer,linetypescale=1,color=byblock, normallayer in block to layer0

'2:HiddenOrCenter2Draft(Hidden2Draft,Center2Draft,ResetDraft)

'Settting
Dim FromLayerName As String
Dim ToLayerName As String
Dim HiddenLinetype As String
Dim CenterLinetype As String
HiddenLinetype = "HIDDEN2"
CenterLinetype = "CENTER2"
Select Case HiddenOrCenter2Draft
Case "Hidden2Draft"
FromLayerName = HiddenLayerName
ToLayerName = DraftLayerName
Case "Center2Draft"
FromLayerName = CenterLayerName
ToLayerName = DraftLayerName
End Select

'Select Block Reference by SelectSet
Dim objSelectOnScreen As AcadSelectionSet
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
objSelectOnScreen.SelectOnScreen
If objSelectOnScreen.count = 0 Then
MsgBox "No Selected Entity"
objSelectOnScreen.Delete
Exit Function
End If

'Change ByLayerOrByBlock of EachEntity of SelectSet
'Process when ByLayerOrByBlock <>""
Dim EachEntity As AcadEntity
Dim EachBlockReference As AcadBlockReference
If ByLayerOrByBlock <> "" Then
For Each EachEntity In objSelectOnScreen
If EachEntity.Layer = "0" Then EachEntity.Layer = NormalLayerName
Call Func33SetLinetypeByLayer(EachEntity)
Call Func34SetLineweightByLayer(EachEntity)
Call Func35SetLinetypeScale(EachEntity)
Select Case ByLayerOrByBlock
Case "ByLayer"
EachEntity.Color = acByLayer
Case "ByBlock"
EachEntity.Color = acRed
End Select
Next
End If
'Creat MotherBlock and SonBlock of SelectSet
Dim MotherSonBlockArr() As Variant
MotherSonBlockArr = Func5000_CreatBlockArrFromSelectSet(objSelectOnScreen)

'Change layer and color in block
Dim EachBlock As AcadBlock
Dim EachLinetype As String

'Change NormalLayer to 0,Lineweight=bylayer,linetypescale=1
For i = LBound(MotherSonBlockArr) To UBound(MotherSonBlockArr)
Set EachBlock = MotherSonBlockArr(i)
For Each EachEntity In EachBlock
If EachEntity.Layer = NormalLayerName Then EachEntity.Layer = "0"
Call Func34SetLineweightByLayer(EachEntity)
Call Func35SetLinetypeScale(EachEntity)
Next
Next

'Change ByLayerOrByBlock of EachEntity of SelectSet
'Process when ByLayerOrByBlock <>""
If ByLayerOrByBlock = "ByBlock" Or ByLayerOrByBlock = "ByLayer" Then
For i = LBound(MotherSonBlockArr) To UBound(MotherSonBlockArr)
Set EachBlock = MotherSonBlockArr(i)
For Each EachEntity In EachBlock
If EachEntity.Layer = "0" Then
Select Case ByLayerOrByBlock
Case "ByLayer"
EachEntity.Color = acByLayer
Case "ByBlock"
EachEntity.Color = acByBlock
End Select
End If
Next
Next
End If


'Change Hidden,Center to bylayer
'Process when HiddenCenter2Draft = "ResetDraft"
If HiddenOrCenter2Draft = "ResetDraft" Then
For i = LBound(MotherSonBlockArr) To UBound(MotherSonBlockArr)
Set EachBlock = MotherSonBlockArr(i)
For Each EachEntity In EachBlock
EachLinetype = EachEntity.Linetype
Select Case EachLinetype
Case HiddenLinetype
EachEntity.Layer = HiddenLayerName
Call Func33SetLinetypeByLayer(EachEntity)
Case CenterLinetype
EachEntity.Layer = CenterLayerName
Call Func33SetLinetypeByLayer(EachEntity)
Case Else
Call Func33SetLinetypeByLayer(EachEntity)
End Select
Next
Next
End If

'Change Hidden or Center to Draft
'Process when HiddenOrCenter2Draft <>""
If HiddenOrCenter2Draft <> "" Then
For i = LBound(MotherSonBlockArr) To UBound(MotherSonBlockArr)
Set EachBlock = MotherSonBlockArr(i)
For Each EachEntity In EachBlock
'Change layer and linetype
If EachEntity.Layer = FromLayerName Then
EachEntity.Layer = ToLayerName
Select Case FromLayerName
Case HiddenLayerName
EachEntity.Linetype = HiddenLinetype
Case CenterLayerName
EachEntity.Linetype = CenterLinetype
End Select
End If
Select Case FromLayerName
Case HiddenLayerName
If EachEntity.Linetype = HiddenLinetype Then EachEntity.Layer = ToLayerName
Case CenterLayerName
If EachEntity.Linetype = CenterLinetype Then EachEntity.Layer = ToLayerName
End Select
Next
Next
End If


'Rename Block
If RenameBlock = True Then
For i = LBound(MotherSonBlockArr) To UBound(MotherSonBlockArr)
Set EachBlock = MotherSonBlockArr(i)
Call Func5003_ChangeBlockName(EachBlock, NewBlockname)
Next
End If
objSelectOnScreen.Delete
Thisdrawing.Regen (acActiveViewport)
MsgBox "Finish"
End Function
Function Func5003_ChangeBlockName(ObjBlock As AcadBlock, NewBlockname As String)

Dim OldBlockname As String
OldBlockname = ObjBlock.Name

'Process when NewBlockName=""
If NewBlockname = "" Then
NewBlockname = OldBlockname & Func31HourMinute
ObjBlock.Name = NewBlockname
Exit Function
End If

'Lay ten moi cho Block
Dim i As Integer
Dim AdjustName As String
On Error Resume Next
ObjBlock.Name = NewBlockname
Do While err.Number <> 0
err.Clear
i = i + 1
AdjustName = NewBlockname & "_" & i
ObjBlock.Name = AdjustName
Loop

End Function
Function Func5004_LimitPointOfBlockOrSelectSet(BlockRefOrSelectSetMode As String, BlockRefOrSelectSet As Variant)
'BlockRefOrSelectSetMode(BlockRef,SelectSet)
'Setting
Dim PointLayername As String: PointLayername = DraftLayerName
Dim objSelectOnScreen As AcadSelectionSet
Dim ObjBlockRef As AcadBlockReference
Dim ObjBlock As AcadBlock
Select Case BlockRefOrSelectSetMode
Case "BlockRef"
Set ObjBlockRef = BlockRefOrSelectSet
Set ObjBlock = Thisdrawing.Blocks(ObjBlockRef.Name)
Case "SelectSet"
Set objSelectOnScreen = BlockRefOrSelectSet
End Select

'Creat EntityArr, PointArr
Dim EntityArr() As Variant
Dim PointArr() As Variant
Dim i As Integer
Dim k As Integer
Dim EachEntity As AcadEntity
Select Case BlockRefOrSelectSetMode
Case "SelectSet"
For Each EachEntity In objSelectOnScreen
If EachEntity.Layer = "0" Or EachEntity.Layer = NormalLayerName Then
ReDim Preserve EntityArr(0 To i)
Set EntityArr(i) = EachEntity
i = i + 1
End If
If EachEntity.ObjectName = "AcDbPoint" Then
ReDim Preserve PointArr(0 To k)
Set PointArr(k) = EachEntity
k = k + 1
End If
Next
If i = 0 Then Exit Function
Case "BlockRef"
For Each EachEntity In ObjBlock
If EachEntity.Layer = "0" Or EachEntity.Layer = NormalLayerName Then
ReDim Preserve EntityArr(0 To i)
Set EntityArr(i) = EachEntity
i = i + 1
End If
If EachEntity.ObjectName = "AcDbPoint" Then
ReDim Preserve PointArr(0 To k)
Set PointArr(k) = EachEntity
k = k + 1
End If
Next
If i = 0 Then Exit Function
End Select


'Define MinX,MaxX,MinY,MaxY
Dim MinPoint As Variant
Dim MaxPoint As Variant
Dim MinX As Double
Dim MaxX As Double
Dim MinY As Double
Dim MaxY As Double
'Set gia tri ban dau cho MinX,MaxX,MinY,MaxY
Dim EachEntityArr As Variant
For Each EachEntityArr In EntityArr
EachEntityArr.GetBoundingBox MinPoint, MaxPoint
MinX = MinPoint(0)
MinY = MinPoint(1)
MaxX = MaxPoint(0)
MaxY = MaxPoint(1)
GoTo NextStep
Next
NextStep:
'Define MinX,MaxX,MinY,MaxY
For Each EachEntityArr In EntityArr
EachEntityArr.GetBoundingBox MinPoint, MaxPoint
If MinX > MinPoint(0) Then MinX = MinPoint(0)
If MinY > MinPoint(1) Then MinY = MinPoint(1)
If MaxX < MaxPoint(0) Then MaxX = MaxPoint(0)
If MaxY < MaxPoint(1) Then MaxY = MaxPoint(1)
Next
'Creat XYMinMaxPoint
Dim XYMinMaxPoint(0 To 3, 0 To 2) As Double
XYMinMaxPoint(0, 0) = MinX: XYMinMaxPoint(0, 1) = MaxY
XYMinMaxPoint(1, 0) = MinX: XYMinMaxPoint(1, 1) = MinY
XYMinMaxPoint(2, 0) = MaxX: XYMinMaxPoint(2, 1) = MaxY
XYMinMaxPoint(3, 0) = MaxX: XYMinMaxPoint(3, 1) = MinY

'Delete Old Point
Dim PointDeleteArr() As Variant
Dim j As Integer
Dim XYPoint(0 To 2) As Double
Dim Delta As Double
Dim TmpPoint As AcadPoint
Dim XYTmpPoint As Variant
If k = 0 Then GoTo NextStep02
For i = 0 To 3
XYPoint(0) = XYMinMaxPoint(i, 0)
XYPoint(1) = XYMinMaxPoint(i, 1)
For k = LBound(PointArr) To UBound(PointArr)
Set TmpPoint = PointArr(k)
XYTmpPoint = TmpPoint.Coordinates
Delta = Func20LengthLineThrough2Point(XYPoint, XYTmpPoint)
If Delta <= 0.1 Then
ReDim Preserve PointDeleteArr(0 To j)
Set PointDeleteArr(j) = TmpPoint
j = j + 1
End If
Next
Next
If j > 0 Then
For k = LBound(PointDeleteArr) To UBound(PointDeleteArr)
Set TmpPoint = PointDeleteArr(k)
TmpPoint.Delete
Next
End If

'Add Point
NextStep02:
Dim DraftPoint As AcadPoint
For i = 0 To 3
XYPoint(0) = XYMinMaxPoint(i, 0)
XYPoint(1) = XYMinMaxPoint(i, 1)
Select Case BlockRefOrSelectSetMode
Case "SelectSet"
Set DraftPoint = Thisdrawing.ModelSpace.AddPoint(XYPoint)
Case "BlockRef"
Set DraftPoint = ObjBlock.AddPoint(XYPoint)
End Select
DraftPoint.Layer = PointLayername
Next

End Function
Function Func5005_IsBlockInDrawing(Thisdrawing As AcadDocument, Blockname As String) As Boolean
Dim Block As AcadBlock
On Error Resume Next
Set Block = Thisdrawing.Blocks(Blockname)
If err Then
Func5005_IsBlockInDrawing = False
Else
Func5005_IsBlockInDrawing = True
End If

End Function

Function Func5006_CreatBlocknameArrFromSelectSet(Thisdrawing As AcadDocument, objSelectOnScreen As AcadSelectionSet) As Variant
'Function tao list tat ca blockname co trong selectset

Dim MotherSonBlockArr() As Variant
Dim MotherSonBlocknameArr() As Variant
Dim i As Integer
Dim EachBlockReference As AcadBlockReference
Dim EachBlock As AcadBlock
Dim EachBlockname As String
Dim EachEntity As AcadEntity

'Define MotherSonBlockArr(0)
Dim IsNormalBlock As Boolean
For Each EachEntity In objSelectOnScreen
If EachEntity.ObjectName = "AcDbBlockReference" Then
Set EachBlockReference = EachEntity
Set EachBlock = Thisdrawing.Blocks(EachBlockReference.Name)
If Func64IsNormalBlock(EachBlockReference) = True Then
ReDim Preserve MotherSonBlockArr(0)
Set MotherSonBlockArr(0) = EachBlock
GoTo NextStep01
End If
End If
Next
If Func70IsEmptyArray(MotherSonBlockArr) = True Then Exit Function
NextStep01:
'Add MotherBlock to MotherSonBlockArr
Dim CheckHave As Boolean
Dim TmpBlock As AcadBlock
i = 1
For Each EachEntity In objSelectOnScreen
If EachEntity.ObjectName = "AcDbBlockReference" Then
Set EachBlockReference = EachEntity
CheckHave = False
Set EachBlock = Thisdrawing.Blocks(EachBlockReference.Name)
For k = LBound(MotherSonBlockArr) To UBound(MotherSonBlockArr)
Set TmpBlock = MotherSonBlockArr(k)
If EachBlock.Name = TmpBlock.Name Then
CheckHave = True
End If
Next
If Func64IsNormalBlock(EachBlockReference) = True And CheckHave = False Then
ReDim Preserve MotherSonBlockArr(0 To i)
Set MotherSonBlockArr(i) = EachBlock
i = i + 1
End If
End If
Next

'Add SonBlock to MotherSonBlockArr
Dim MotherBlock As AcadBlock
Dim SonBlockRef As AcadBlockReference
Dim SonBlock As AcadBlock
Dim Tmpblockref As AcadBlockReference
Dim j As Integer
Do
Set MotherBlock = MotherSonBlockArr(j)
For Each EachEntity In MotherBlock
If EachEntity.ObjectName = "AcDbBlockReference" Then
CheckHave = False
Set SonBlockRef = EachEntity
Set SonBlock = Thisdrawing.Blocks(SonBlockRef.Name)
'Xac dinh xem block co ten trong list hay khong
For k = LBound(MotherSonBlockArr) To UBound(MotherSonBlockArr)
Set TmpBlock = MotherSonBlockArr(k)
If SonBlock.Name = TmpBlock.Name Then
CheckHave = True
End If
Next
'Bo qua anonymous block, att block, dynamic block
If CheckHave = False And Func64IsNormalBlock(SonBlockRef) = True Then
i = UBound(MotherSonBlockArr) + 1
ReDim Preserve MotherSonBlockArr(0 To i)
Set MotherSonBlockArr(i) = SonBlock
End If
End If
Next
j = j + 1
Loop While j <= UBound(MotherSonBlockArr)
ReDim MotherSonBlocknameArr(0 To UBound(MotherSonBlockArr))
For i = 0 To UBound(MotherSonBlockArr)
Set EachBlock = MotherSonBlockArr(i)
EachBlockname = EachBlock.Name
MotherSonBlocknameArr(i) = EachBlockname
Next

Func5006_CreatBlocknameArrFromSelectSet = MotherSonBlocknameArr

End Function
Function Func5007_GetPartPropertyBlockRef(Thisdrawing As AcadDocument) As AcadBlockReference

'Call Function Unlock layer Frame
Call Func06UnlockLayer(Thisdrawing, FrameLayerName)
Dim ObjAttBlock As AcadSelectionSet
Set ObjAttBlock = Thisdrawing.SelectionSets.Add("objAttBlock" & 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) = PartPropertyBlock
FT(3) = -4: FD(3) = "AND>"
ObjAttBlock.Select acSelectionSetAll, , , FT, FD
If ObjAttBlock.count = 0 Then
ObjAttBlock.Delete
Exit Function
End If

Dim TitleBlock As AcadBlockReference
For Each TitleBlock In ObjAttBlock
Set Func5007_GetPartPropertyBlockRef = TitleBlock
Next
ObjAttBlock.Delete
'Call Function Lock Layer Frame
Call Func07LockLayer(Thisdrawing, FrameLayerName)

End Function
Function Func5008_GetAttValueOfPartPropertyBlockRef(Thisdrawing As AcadDocument, TitleBlock As AcadBlockReference, TagName As String) As String

'Call Function Unlock layer Frame
Call Func06UnlockLayer(Thisdrawing, FrameLayerName)

If TitleBlock Is Nothing Then
Exit Function
End If

Dim varAttributes As Variant
Dim AttTextString As String

varAttributes = TitleBlock.GetAttributes
For i = LBound(varAttributes) To UBound(varAttributes)
If varAttributes(i).TagString = TagName Then
AttTextString = varAttributes(i).TextString
End If
Next

'Call Function Lock Layer Frame
Call Func07LockLayer(Thisdrawing, FrameLayerName)
Func5008_GetAttValueOfPartPropertyBlockRef = AttTextString

End Function


Function Func5009_C_InsertExternalDrawing(Thisdrawing As AcadDocument, Pathname As String, Blockname As String, InsertPoint As Variant, InsertBlockScale As Integer, RotateAngle As Double, DeleteExplodeMode As String)
'Mode(Delete,Explode,Block)
'Add External Reference
Dim ObjExternalReference As AcadExternalReference
Dim XScale As Integer
Dim YScale As Integer
Dim ZScale As Integer
Dim Overlay As Boolean: Overlay = False

'Define XScale,YScale,ZScale
XScale = InsertBlockScale
YScale = InsertBlockScale
ZScale = InsertBlockScale


'Attach ObjExternalReference
Dim ExternalBlock As AcadBlock
Set ObjExternalReference = Thisdrawing.ModelSpace.AttachExternalReference(Pathname, Blockname, InsertPoint, XScale, YScale, ZScale, RotateAngle, False)
'Set ExternalBlock = Thisdrawing.Blocks.Item(ObjExternalReference.Name)
'ExternalBlock.Detach
Thisdrawing.Blocks.Item(ObjExternalReference.Name).Bind True

'Explode Block,DeleteBlock
Dim ObjSelectSet As AcadSelectionSet
Dim EachObj As AcadEntity
Dim ObjBlockRef As AcadBlockReference
Dim ObjBlock As AcadBlock
Set ObjSelectSet = Thisdrawing.SelectionSets.Add("ObjSelectSet" & 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>"
ObjSelectSet.Select acSelectionSetAll, , , FT, FD
Set ObjBlockRef = ObjSelectSet.Item(0)
ObjSelectSet.Delete
Select Case DeleteExplodeMode
Case "Delete"
ObjBlockRef.Delete
Set ObjBlock = Thisdrawing.Blocks(Blockname)
ObjBlock.Delete
Case "Explode"
'Explode
Call Func5010_ExplodeBlockReference(Thisdrawing, ObjBlockRef)
Set ObjBlock = Thisdrawing.Blocks(Blockname)
ObjBlock.Delete
Case Else
End Select

End Function
Function Func5010_ExplodeBlockReference(Thisdrawing As AcadDocument, Obj As AcadEntity)
Dim ObjHandle As String
Dim ObjHandent As String
ObjHandle = Obj.Handle
ObjHandent = "(handent " & Chr(34) & ObjHandle & Chr(34) & ")"
Thisdrawing.SendCommand "EXPLODE" & vbCr & ObjHandent & vbCr & vbCr
End Function
Function Func5009_InsertExternalDrawing(Thisdrawing As AcadDocument, FilePath As String, Blockname As String, ScaleMode As String, InsertPointMode As String, StrInsertPointX As Variant, StrInsertPointY As Variant, RotateAngle As Double, DeleteExplode As String)

'Define PageSize
Dim TitleBlock As AcadBlockReference
Set TitleBlock = Func5007_GetPartPropertyBlockRef(Thisdrawing)
Dim PaperSize As String
PaperSize = Func5008_GetAttValueOfPartPropertyBlockRef(Thisdrawing, TitleBlock, "}–ʃTƒCƒY")

'Define InsertBlockScale from Dimscale and ScaleMode
Dim InsertBlockScale As Integer
InsertBlockScale = Func5009_A_DefineInsertBlockScale(Thisdrawing, ScaleMode)

'Define InsertPoint
Dim InsertPoint As Variant
InsertPoint = Func5009_B_DefineInsertPoint(Thisdrawing, PaperSize, InsertPointMode, StrInsertPointX, StrInsertPointY, InsertBlockScale)

'Define InsertPoint from PageSize,InsertPointMode,DimScale
Call Func5009_C_InsertExternalDrawing(Thisdrawing, FilePath, Blockname, InsertPoint, InsertBlockScale, RotateAngle, DeleteExplode)

End Function
Function Func5009_A_DefineInsertBlockScale(Thisdrawing As AcadDocument, ScaleMode As String) As Integer
'Define InsertBlockScale from Dimscale and ScaleMode
Dim InsertBlockScale As Integer
Dim Dimscale As Integer
Dimscale = Thisdrawing.GetVariable("DIMSCALE")
Select Case ScaleMode
Case "Scale"
InsertBlockScale = Dimscale
Case "NoScale"
InsertBlockScale = 1
Case Else
InsertBlockScale = 1
End Select
Func5009_A_DefineInsertBlockScale = InsertBlockScale
End Function
Function Func5009_B_DefineInsertPoint(Thisdrawing As AcadDocument, PaperSize As String, InsertPointMode As String, StrInsertPointX As Variant, StrInsertPointY As Variant, InsertBlockScale As Integer) As Variant

'Define InsertPointMode from Excel
Select Case InsertPointMode
Case "Automatic"
If VarType(StrInsertPointX) <> vbDouble Or VarType(StrInsertPointY) <> vbDouble Then
InsertPointMode = "SelectPoint"
End If
Select Case PaperSize
Case "A4"
Case "A3"
Case "A2"
Case Else
InsertPointMode = "SelectPoint"
End Select
Case "SelectPoint"
Case "Point00"
Case "DrawingOutside"
If PaperSize = "" Then InsertPointMode = "SelectPoint"
Case Else
InsertPointMode = "SelectPoint"
End Select

'Define InsertPoint
Dim BasicInsertPoint(0 To 2) As Double
Dim AfterInsertPoint(0 To 2) As Double
Dim SelectPoint As Variant
Select Case InsertPointMode
Case "Automatic"
AfterInsertPoint(0) = CDbl(StrInsertPointX) * InsertBlockScale
AfterInsertPoint(1) = CDbl(StrInsertPointY) * InsertBlockScale
Case "SelectPoint"
On Error GoTo next01
SelectPoint = Thisdrawing.Utility.GetPoint(, "Select Insert Point:")
AfterInsertPoint(0) = SelectPoint(0)
AfterInsertPoint(1) = SelectPoint(1)
next01:
If err Then GoTo next02
Case "DrawingOutside"
next02:
Select Case PaperSize
Case "A4"
AfterInsertPoint(0) = A4X11 * InsertBlockScale
Case "A3"
AfterInsertPoint(0) = A3X11 * InsertBlockScale
Case "A2"
AfterInsertPoint(0) = A2X11 * InsertBlockScale
End Select
Case "Point00"
AfterInsertPoint(0) = 0
AfterInsertPoint(1) = 0
End Select

Func5009_B_DefineInsertPoint = AfterInsertPoint

End Function

Function Func5011_GetInsertPointAndDirectionPoint() As Variant

'Select Insert Point and Direction Point
Dim InsertPoint As Variant
Dim DirectionPoint As Variant
Dim Result(0 To 1) As Variant

On Error GoTo Step1
InsertPoint = Thisdrawing.Utility.GetPoint(, "Select InsertPoint:")
DirectionPoint = Thisdrawing.Utility.GetPoint(InsertPoint, "Select DirectionPoint:")
Step1:
If err Then
Result(0) = False
Func5011_GetInsertPointAndDirectionPoint = False
Else
Result(0) = InsertPoint
Result(1) = DirectionPoint
Func5011_GetInsertPointAndDirectionPoint = Result
End If

End Function

Function Func5012_InsertSurfaceTexture(BeginBlockname As String)

'Get Dimscale and Define BlockScale
Dim Dimscale As Integer
Dimscale = Thisdrawing.GetVariable("DIMSCALE")

'Othor On
Thisdrawing.SetVariable "ORTHOMODE", 1

'Set UCS is World UCS
Dim Point00(0 To 2) As Double
Call FuncCadHome05SetUCSFromPoint(Point00)

'Select Insert Point and Direction Point and insert block
Dim Get2Point As Variant
Dim InsertPoint As Variant
Dim DirectionPoint As Variant
Do
Get2Point = Func5011_GetInsertPointAndDirectionPoint
If VarType(Get2Point) = vbBoolean Then Exit Function
InsertPoint = Get2Point(0)
DirectionPoint = Get2Point(1)
Call Func5012_A_InsertSurfaceTexture(BeginBlockname, Dimscale, InsertPoint, DirectionPoint)
Loop While VarType(Get2Point) <> vbBoolean

End Function
Function Func5012_A_InsertSurfaceTexture(BeginBlockname As String, Dimscale As Integer, InsertPoint As Variant, DirectionPoint As Variant)

'Dim
Dim ObjBlockRef As AcadBlockReference
Dim XScale As Integer
Dim YScale As Integer
Dim ZScale As Integer
Dim RotationAngle As Double
Dim Blockname As String
Dim EndBlockname As String

'Get Dimscale and Define BlockScale
XScale = Dimscale
YScale = Dimscale
ZScale = Dimscale

'Define Blockname
Dim InsertPointX As Double
Dim InsertPointY As Double
Dim DirectionPointX As Double
Dim DirectionPointY As Double
InsertPointX = Round(InsertPoint(0), 2)
InsertPointY = Round(InsertPoint(1), 2)
DirectionPointX = Round(DirectionPoint(0), 2)
DirectionPointY = Round(DirectionPoint(1), 2)
If InsertPointX = DirectionPointX Then
'90,270
If DirectionPointY > InsertPointY Then
EndBlockname = "90"
Else
EndBlockname = "270"
End If
Else
'0,180
If DirectionPointX > InsertPointX Then
EndBlockname = "0"
Else
EndBlockname = "180"
End If
End If
Blockname = BeginBlockname & EndBlockname
Set ObjBlockRef = Thisdrawing.ModelSpace.InsertBlock(InsertPoint, Blockname, XScale, YScale, ZScale, RotationAngle)

'Explode Block Reference
Dim ExplodeArr As Variant
ExplodeArr = ObjBlockRef.Explode

End Function


Function Func5013_ReplaceBlock(Thisdrawing As AcadDocument, OldBlockname As String, NewBlockname As String)
'Function tao list tat ca block co trong selectset

'Define OldBlock and NewBlock
Dim OldBlock As AcadBlock
Dim NewBlock As AcadBlock
Set OldBlock = Thisdrawing.Blocks(OldBlockname)
Set NewBlock = Thisdrawing.Blocks(NewBlockname)

'Delete All Entity of OldBlock
Dim EachEntity As AcadEntity
For Each EachEntity In NewBlock
EachEntity.Delete
Next

'Insert OldBlock into NewBlock
Dim ChildBlockRef As AcadBlockReference
Dim InsertPoint(0 To 2) As Double
Set ChildBlockRef = NewBlock.InsertBlock(InsertPoint, OldBlockname, 1, 1, 1, 0)

'Explode NewBlock in OldBlock
Dim ExplodeArr As Variant
ExplodeArr = ChildBlockRef.Explode

'Delete NewBlock
ChildBlockRef.Delete
OldBlock.Delete

'Rename NewBlock
NewBlock.Name = OldBlockname

End Function

Message 6 of 15

Sub HCS3000_UpdateSelectedBlockFromOtherDrawing()
'(VBA AutoCad) Update Selected Block From Other Drawing,[UB]

'Time
Dim BeginTime As Date
Dim ProcessTime As Date
Dim ProcessSecond As Integer
BeginTime = Now()
'Purge
Dim UpdateToDrawing As AcadDocument
Set UpdateToDrawing = Thisdrawing
UpdateToDrawing.PurgeAll

'Select Block for Update
Dim ObjSelectSet As AcadSelectionSet
Set ObjSelectSet = Thisdrawing.SelectionSets.Add("ObjSelectSet" & Now)
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 0: FD(0) = "INSERT"
'MsgBox
Dim MsgBoxResult As VbMsgBoxResult
Dim MsgPrompt As String
Dim MsgButton As VbMsgBoxStyle
Dim MsgTitle As String
MsgPrompt = "Yes: Automatic Sellect All Block in drawing" & vbNewLine & _
"No: Manual Select Block"
MsgButton = vbYesNoCancel + vbSystemModal
MsgTitle = "Select Block for update"
MsgBoxResult = MsgBox(MsgPrompt, MsgButton, MsgTitle)
Select Case MsgBoxResult
Case vbYes
ObjSelectSet.Select acSelectionSetAll, , , FT, FD
Case vbNo
ObjSelectSet.SelectOnScreen FT, FD
Case vbCancel
ObjSelectSet.Delete
Exit Sub
End Select
If ObjSelectSet.count = 0 Then
MsgBox "No Block for Update"
ObjSelectSet.Delete
Exit Sub
End If

'Creat UpdateBlocknameList
Dim UpdateBlocknameList As Variant
Dim NeedUpdateBlockCount As Integer
UpdateBlocknameList = HCF4001_CreatBlocknameArrFromSelectSet(Thisdrawing, ObjSelectSet)
If Func70IsEmptyArray(UpdateBlocknameList) = True Then
MsgBox "No Block for Update"
ObjSelectSet.Delete
Exit Sub
End If
ObjSelectSet.Delete
NeedUpdateBlockCount = UBound(UpdateBlocknameList) + 1

'Select file
Thisdrawing.SetVariable "users1", ""
Dim FilePath As String
Dim UpdateFromDrawing As AcadDocument
Set UpdateFromDrawing = HCF4000_OpenOtherDrawing
If UpdateFromDrawing Is Nothing Then
Exit Sub
Else
FilePath = UpdateFromDrawing.Fullname
End If

'Creat UFDBlocknameArr and UFDBlocknameList of UpdateFromDrawing
Dim UFDBlocknameArr As Variant
Dim UFDBlocknameList As String
Set ObjSelectSet = UpdateFromDrawing.SelectionSets.Add("ObjSelectSet" & Now)
ObjSelectSet.Select acSelectionSetAll, , , FT, FD
If ObjSelectSet.count = 0 Then
MsgBox "No Block for update"
UpdateFromDrawing.Close False
UpdateToDrawing.Activate
Exit Sub
End If
UFDBlocknameArr = HCF4001_CreatBlocknameArrFromSelectSet(UpdateFromDrawing, ObjSelectSet)
ObjSelectSet.Delete
If Func70IsEmptyArray(UFDBlocknameArr) = True Then
UpdateFromDrawing.Close False
UpdateToDrawing.Activate
MsgBox "No Block for update"
Exit Sub
End If
UFDBlocknameList = UFDBlocknameArr(UBound(UFDBlocknameArr))
UpdateFromDrawing.Close False
UpdateToDrawing.Activate

'Creat Common Blockname of UpdateFromDrawing and UpdateToDrawing
Dim CommonBlocknameArr() As Variant
Dim CommonBlocknameList As String
Dim EachBlockname As String
Dim SearchEachBlockname As String
Dim k As Integer
For i = LBound(UpdateBlocknameList) To UBound(UpdateBlocknameList)
EachBlockname = UpdateBlocknameList(i)
SearchEachBlockname = ";" & EachBlockname & ";"
If InStr(UFDBlocknameList, SearchEachBlockname) <> 0 Then
ReDim Preserve CommonBlocknameArr(0 To k)
CommonBlocknameArr(k) = EachBlockname
CommonBlocknameList = CommonBlocknameList & SearchEachBlockname
k = k + 1
End If
Next
If Func70IsEmptyArray(CommonBlocknameArr) = True Then
MsgBox "No Same Block for Update"
Exit Sub
End If

'Rename Block in Common Block List
Dim OldBlockName As String
Dim NewBlockname As String
For i = LBound(CommonBlocknameArr) To UBound(CommonBlocknameArr)
OldBlockName = CommonBlocknameArr(i)
Set EachBlock = Thisdrawing.Blocks(OldBlockName)
NewBlockname = OldBlockName & "_UB"
EachBlock.Name = NewBlockname
Next

'Insert UpdateFromDrawing into UpdateToDrawing 2
Dim InsertPoint(0 To 2) As Double
Dim InsertBlockScale As Integer: InsertBlockScale = 1
Dim RotateAngle As Double
Dim DeleteExplode As String: DeleteExplode = "Delete"
Dim ExternalBlockname As String: ExternalBlockname = "UpdateBlock" & Func31HourMinute
Call HCF4003_C_InsertExternalDrawing(Thisdrawing, FilePath, ExternalBlockname, InsertPoint, InsertBlockScale, RotateAngle, DeleteExplode)

'Replace Block
For i = UBound(CommonBlocknameArr) To LBound(CommonBlocknameArr) Step -1
OldBlockName = CommonBlocknameArr(i)
NewBlockname = OldBlockName & "_UB"
Call HCF4002_B_ReplaceBlock(Thisdrawing, OldBlockName, NewBlockname)
Next

'Delete OldBlockname
Dim EachEntity As AcadEntity
Dim EachBlockRef As AcadBlockReference
Dim ExplodeArr As Variant

For Each EachBlock In Thisdrawing.Blocks
For Each EachEntity In EachBlock
If EachEntity.ObjectName = "AcDbBlockReference" Then
Set EachBlockRef = EachEntity
EachBlockname = EachBlockRef.Name
SearchEachBlockname = ";" & EachBlockname & ";"
If InStr(CommonBlocknameList, SearchEachBlockname) <> 0 Then
ExplodeArr = EachBlockRef.Explode
EachBlockRef.Delete
End If
End If
Next
Next
'Replace Block
Dim UpdateCount As Integer
Dim OldBlock As AcadBlock
Dim NewBlock As AcadBlock
For i = UBound(CommonBlocknameArr) To LBound(CommonBlocknameArr) Step -1
OldBlockName = CommonBlocknameArr(i)
NewBlockname = OldBlockName & "_UB"
Set OldBlock = Thisdrawing.Blocks(OldBlockName)
Set NewBlock = Thisdrawing.Blocks(NewBlockname)
OldBlock.Delete
NewBlock.Name = OldBlockName
UpdateCount = UpdateCount + 1
Next

Thisdrawing.PurgeAll
Thisdrawing.Regen acAllViewports
ProcessTime = Now() - BeginTime
ProcessSecond = DateTime.Second(ProcessTime)

MsgBox "Updated " & UpdateCount & "/" & NeedUpdateBlockCount & " Blocks" & vbNewLine & _
"Process Time: " & ProcessSecond & " Second"
End Sub

Function HCF4001_CreatBlocknameArrFromSelectSet(Thisdrawing As AcadDocument, objSelectOnScreen As AcadSelectionSet) As Variant
'Function tao list tat ca blockname co trong selectset

Dim MotherSonBlocknameArr() As Variant
Dim i As Integer
Dim EachBlockReference As AcadBlockReference
Dim EachBlockname As String
Dim EachEntity As AcadEntity
Dim BlocknameList As String

'Define MotherSonBlocknameArr(0)
Dim CheckBlockname As String
For Each EachBlockReference In objSelectOnScreen
EachBlockname = EachBlockReference.Name
CheckBlockname = ";" & EachBlockname & ";"
If Func64IsNormalBlock(EachBlockReference) = True And InStr(BlocknameList, CheckBlockname) = 0 Then
ReDim Preserve MotherSonBlocknameArr(0 To i)
MotherSonBlocknameArr(i) = EachBlockname
BlocknameList = BlocknameList & CheckBlockname
i = i + 1
End If
Next

'Add SonBlock to MotherSonBlocknameArr
Dim MotherBlock As AcadBlock
Dim MotherBlockname As String
Dim SonBlockRef As AcadBlockReference
Dim SonBlockname As String
Dim j As Integer
Do
MotherBlockname = MotherSonBlocknameArr(j)
Set MotherBlock = Thisdrawing.Blocks(MotherBlockname)
For Each EachEntity In MotherBlock
If EachEntity.ObjectName = "AcDbBlockReference" Then
Set SonBlockRef = EachEntity
SonBlockname = SonBlockRef.Name
CheckBlockname = ";" & SonBlockname & ";"
If Func64IsNormalBlock(SonBlockRef) = True And InStr(BlocknameList, CheckBlockname) = 0 Then
i = UBound(MotherSonBlocknameArr) + 1
ReDim Preserve MotherSonBlocknameArr(0 To i)
MotherSonBlocknameArr(i) = SonBlockname
BlocknameList = BlocknameList & CheckBlockname
End If
End If
Next
j = j + 1
Loop While j <= UBound(MotherSonBlocknameArr)
If BlocknameList <> "" Then
ReDim Preserve MotherSonBlocknameArr(0 To UBound(MotherSonBlocknameArr) + 1)
MotherSonBlocknameArr(UBound(MotherSonBlocknameArr)) = BlocknameList
End If

HCF4001_CreatBlocknameArrFromSelectSet = MotherSonBlocknameArr

End Function


Function HCF4002_UpdateBlockFromOtherDrawing(UpdateFromBlocknameList As Variant, FilePath As String) As Integer

'Purge All
Thisdrawing.PurgeAll

'Creat Common Block of UpdateFromDrawing and UpdateToDrawing
Dim CommonBlockArr() As Variant
Dim CommonBlocknameList As String
Dim ThisdrawingBlocknameList As String: ThisdrawingBlocknameList = ";"
Dim EachBlockname As String
Dim EachBlock As AcadBlock
Dim SearchEachBlockname As String
Dim k As Integer
For Each EachBlock In Thisdrawing.Blocks
ThisdrawingBlocknameList = ThisdrawingBlocknameList & EachBlock.Name & ";"
Next

For i = LBound(UpdateFromBlocknameList) To UBound(UpdateFromBlocknameList)
EachBlockname = UpdateFromBlocknameList(i)
SearchEachBlockname = ";" & EachBlockname & ";"
If InStr(ThisdrawingBlocknameList, SearchEachBlockname) <> 0 Then
ReDim Preserve CommonBlockArr(0 To k)
CommonBlockArr(k) = EachBlockname
CommonBlocknameList = CommonBlocknameList & SearchEachBlockname
k = k + 1
End If
Next
If Func70IsEmptyArray(CommonBlockArr) = True Then
MsgBox "No common block for update"
Exit Function
End If

'Rename Block in Common Block List
Dim OldBlockName As String
Dim NewBlockname As String
Dim UpdateBlocknameArr() As Variant
ReDim UpdateBlocknameArr(0 To UBound(CommonBlockArr), 0 To 1)
For i = LBound(CommonBlockArr) To UBound(CommonBlockArr)
OldBlockName = CommonBlockArr(i)
Set EachBlock = Thisdrawing.Blocks(OldBlockName)
NewBlockname = OldBlockName & "_UB"
EachBlock.Name = NewBlockname
UpdateBlocknameArr(i, 0) = OldBlockName
UpdateBlocknameArr(i, 1) = NewBlockname
Next

'Import [UpdateFromDrawing] into [UpdateToDrawing]
Dim ScaleMode As String: ScaleMode = "NoScale"
Dim InsertPointMode As String: InsertPointMode = "Point00" '
Dim StrInsertPointX As Double
Dim StrInsertPointY As Double
Dim RotateAngle As Double
Dim DeleteExplode As String: DeleteExplode = "Delete"
'Define Pathname and blockname
Dim ExternalBlockname As String
Dim ExternalBlock As AcadBlock
ExternalBlockname = "UpdateBlock" & Func31HourMinute
Call HCF4003_InsertExternalDrawing(Thisdrawing, FilePath, ExternalBlockname, ScaleMode, InsertPointMode, StrInsertPointX, StrInsertPointY, RotateAngle, DeleteExplode)

'Creat List MotherBlock In UpdateFromBlocknameList
Dim MotherBlockInUpdateFromBlocknameList As Variant
MotherBlockInUpdateFromBlocknameList = HCF4002_A_MotherBlockInUpdateFromBlocknameList(UpdateFromBlocknameList, CommonBlocknameList)
'Replace Block
Dim UpdateCount As Integer
For i = UBound(UpdateBlocknameArr) To LBound(UpdateBlocknameArr) Step -1
OldBlockName = UpdateBlocknameArr(i, 0)
NewBlockname = UpdateBlocknameArr(i, 1)
Call HCF4002_B_ReplaceBlock(Thisdrawing, OldBlockName, NewBlockname, MotherBlockInUpdateFromBlocknameList)
UpdateCount = UpdateCount + 1
Next
Thisdrawing.PurgeAll
Thisdrawing.Regen acAllViewports
MsgBox "Updated " & UpdateCount & " Blocks"
End Function
Function HCF4002_A_MotherBlockInUpdateFromBlocknameList(UpdateFromBlocknameList As Variant, CommonBlocknameList As String) As Variant

Dim MotherBlockInUpdateFromBlocknameList() As Variant

Dim MotherBlock As AcadBlock
Dim MotherBlockname As String
Dim MotherBlocknameArr() As Variant
Dim SonBlocknameList As String
Dim SonBlocknameListArr() As Variant
Dim k As Integer
Dim EachEntity As AcadEntity
Dim EachBlockRef As AcadBlockReference
Dim SearchBlockname As String
Dim IsNotEmptyArr As Boolean

For i = LBound(UpdateFromBlocknameList) To UBound(UpdateFromBlocknameList)
SonBlocknameList = ";"
MotherBlockname = UpdateFromBlocknameList(i)
Set MotherBlock = Thisdrawing.Blocks(MotherBlockname)
For Each EachEntity In MotherBlock
If EachEntity.ObjectName = "AcDbBlockReference" Then
Set EachBlockRef = EachEntity
SearchBlockname = ";" & EachBlockRef.Name & ";"
If InStr(CommonBlocknameList, SearchBlockname) <> 0 Then
SonBlocknameList = SonBlocknameList & EachBlockRef.Name & ";"
End If
End If
Next
If SonBlocknameList <> ";" Then
ReDim Preserve MotherBlocknameArr(0 To k)
ReDim Preserve SonBlocknameListArr(0 To k)
MotherBlocknameArr(k) = MotherBlockname
SonBlocknameListArr(k) = SonBlocknameList
k = k + 1
IsNotEmptyArr = True
End If
Next
If IsNotEmptyArr = True Then
ReDim MotherBlockInUpdateFromBlocknameList(0 To k - 1, 0 To 1)
For i = 0 To k - 1
MotherBlockInUpdateFromBlocknameList(i, 0) = MotherBlocknameArr(i)
MotherBlockInUpdateFromBlocknameList(i, 1) = SonBlocknameListArr(i)
Next
End If

HCF4002_A_MotherBlockInUpdateFromBlocknameList = MotherBlockInUpdateFromBlocknameList

End Function
Function HCF4002_B_ReplaceBlock(Thisdrawing As AcadDocument, OldBlockName As String, NewBlockname As String)
'Function tao list tat ca block co trong selectset

'Define OldBlock and NewBlock
Dim OldBlock As AcadBlock
Dim NewBlock As AcadBlock
Set OldBlock = Thisdrawing.Blocks(OldBlockName)
Set NewBlock = Thisdrawing.Blocks(NewBlockname)

'Delete All Entity of OldBlock
Dim EachEntity As AcadEntity
For Each EachEntity In NewBlock
EachEntity.Delete
Next

'Insert OldBlock into NewBlock
Dim ChildBlockRef As AcadBlockReference
Dim InsertPoint(0 To 2) As Double
Set ChildBlockRef = NewBlock.InsertBlock(InsertPoint, OldBlockName, 1, 1, 1, 0)

'Explode NewBlock in OldBlock
Dim ExplodeArr As Variant
ExplodeArr = ChildBlockRef.Explode
ChildBlockRef.Delete

'Insert NewBlock into OldBlock
For Each EachEntity In OldBlock
EachEntity.Delete
Next
Set ChildBlockRef = OldBlock.InsertBlock(InsertPoint, NewBlockname, 1, 1, 1, 0)

End Function
Function HCF4003_InsertExternalDrawing(Thisdrawing As AcadDocument, FilePath As String, Blockname As String, ScaleMode As String, InsertPointMode As String, StrInsertPointX As Variant, StrInsertPointY As Variant, RotateAngle As Double, DeleteExplode As String)

'Define PageSize
Dim TitleBlock As AcadBlockReference
Set TitleBlock = HCF4004_GetPartPropertyBlockRef(Thisdrawing)
Dim PaperSize As String
PaperSize = HCF4005_GetAttValueOfPartPropertyBlockRef(Thisdrawing, TitleBlock, "}–ʃTƒCƒY")

'Define InsertBlockScale from Dimscale and ScaleMode
Dim InsertBlockScale As Integer
InsertBlockScale = HCF4003_A_DefineInsertBlockScale(Thisdrawing, ScaleMode)

'Define InsertPoint
Dim InsertPoint As Variant
InsertPoint = HCF4003_B_DefineInsertPoint(Thisdrawing, PaperSize, InsertPointMode, StrInsertPointX, StrInsertPointY, InsertBlockScale)

'Define InsertPoint from PageSize,InsertPointMode,DimScale
Call HCF4003_C_InsertExternalDrawing(Thisdrawing, FilePath, Blockname, InsertPoint, InsertBlockScale, RotateAngle, DeleteExplode)

End Function
Function HCF4000_OpenOtherDrawing() As AcadDocument
'Define Folder of Thisdrawing
Dim FolderPath As String
Dim ThisdrawingName As String
FolderPath = Thisdrawing.Fullname
ThisdrawingName = Thisdrawing.Name
FolderPath = WorksheetFunction.Substitute(FolderPath, ThisdrawingName, "")
FolderPath = WorksheetFunction.Substitute(FolderPath, "\", "/")
FolderPath = Chr(34) & FolderPath & Chr(34)

'1.Select file
Dim FilePath As String
Dim StrSendCommand As String
StrSendCommand = "(setvar " & """users1""" & "(getfiled " & """Select a DWG File""" & FolderPath & """dwg""" & "32)) "
Thisdrawing.SendCommand StrSendCommand
'Use the GetVariable method to retrieve this system variable to store the selected file name
FilePath = Thisdrawing.GetVariable("users1")

If FilePath = "" Then
Exit Function
End If
If FilePath = Thisdrawing.Fullname Then
MsgBox "The same file is selected." & vbNewLine & "Please select Other Drawing"
Exit Function
End If

'3.Open UpdateFromDrawing
Dim UpdateFromDrawing As AcadDocument
Dim TmpDrawing As AcadDocument
Dim FileIsOpening As Boolean
For Each TmpDrawing In Application.Documents
If TmpDrawing.Fullname = FilePath Then
Set UpdateFromDrawing = TmpDrawing
FileIsOpening = True
End If
Next
If FileIsOpening = False Then
Set UpdateFromDrawing = Application.Documents.Open(FilePath, True)
End If
UpdateFromDrawing.Activate
Set HCF4000_OpenOtherDrawing = UpdateFromDrawing
End Function
Function HCF4002_BA_ReplaceBlockRefInMotherBlock(OldBlockName As String, NewBlockname As String, MotherBlockInUpdateFromBlocknameList As Variant)

If Func70IsEmptyArray(MotherBlockInUpdateFromBlocknameList) = True Then Exit Function
'Replace OldBlock in MotherBlock
Dim SearchOldBlockname As String
Dim MotherBlockname As String
Dim SonBlocknameList As String
Dim MotherBlock As AcadBlock
Dim EachEntity As AcadEntity
Dim EachOldBlockRef As AcadBlockReference
Dim ExplodeArr As Variant

SearchOldBlockname = ";" & OldBlockName & ";"
For i = LBound(MotherBlockInUpdateFromBlocknameList) To UBound(MotherBlockInUpdateFromBlocknameList)
MotherBlockname = MotherBlockInUpdateFromBlocknameList(i, 0)
SonBlocknameList = MotherBlockInUpdateFromBlocknameList(i, 1)
If InStr(SonBlocknameList, SearchOldBlockname) <> 0 Then
Set MotherBlock = Thisdrawing.Blocks(MotherBlockname)
For Each EachEntity In MotherBlock
If EachEntity.ObjectName = "AcDbBlockReference" Then
Set EachOldBlockRef = EachEntity
If EachOldBlockRef.Name = OldBlockName Then
ExplodeArr = EachOldBlockRef.Explode
EachOldBlockRef.Delete
SonBlocknameList = Replace(SonBlocknameList, OldBlockName, NewBlockname)
MotherBlockInUpdateFromBlocknameList(i, 1) = SonBlocknameList
End If
End If
Next
End If
Next

End Function
Function HCF4003_A_DefineInsertBlockScale(Thisdrawing As AcadDocument, ScaleMode As String) As Integer
'Define InsertBlockScale from Dimscale and ScaleMode
Dim InsertBlockScale As Integer
Dim Dimscale As Integer
Dimscale = Thisdrawing.GetVariable("DIMSCALE")
Select Case ScaleMode
Case "Scale"
InsertBlockScale = Dimscale
Case "NoScale"
InsertBlockScale = 1
Case Else
InsertBlockScale = 1
End Select
HCF4003_A_DefineInsertBlockScale = InsertBlockScale
End Function
Function HCF4003_B_DefineInsertPoint(Thisdrawing As AcadDocument, PaperSize As String, InsertPointMode As String, StrInsertPointX As Variant, StrInsertPointY As Variant, InsertBlockScale As Integer) As Variant

'Define InsertPointMode from Excel
Select Case InsertPointMode
Case "Automatic"
If VarType(StrInsertPointX) <> vbDouble Or VarType(StrInsertPointY) <> vbDouble Then
InsertPointMode = "SelectPoint"
End If
Select Case PaperSize
Case "A4"
Case "A3"
Case "A2"
Case Else
InsertPointMode = "SelectPoint"
End Select
Case "SelectPoint"
Case "Point00"
Case "DrawingOutside"
If PaperSize = "" Then InsertPointMode = "SelectPoint"
Case Else
InsertPointMode = "SelectPoint"
End Select

'Define InsertPoint
Dim BasicInsertPoint(0 To 2) As Double
Dim AfterInsertPoint(0 To 2) As Double
Dim SelectPoint As Variant
Select Case InsertPointMode
Case "Automatic"
AfterInsertPoint(0) = CDbl(StrInsertPointX) * InsertBlockScale
AfterInsertPoint(1) = CDbl(StrInsertPointY) * InsertBlockScale
Case "SelectPoint"
On Error GoTo next01
SelectPoint = Thisdrawing.Utility.GetPoint(, "Select Insert Point:")
AfterInsertPoint(0) = SelectPoint(0)
AfterInsertPoint(1) = SelectPoint(1)
next01:
If Err Then GoTo next02
Case "DrawingOutside"
next02:
Select Case PaperSize
Case "A4"
AfterInsertPoint(0) = A4X11 * InsertBlockScale
Case "A3"
AfterInsertPoint(0) = A3X11 * InsertBlockScale
Case "A2"
AfterInsertPoint(0) = A2X11 * InsertBlockScale
End Select
Case "Point00"
AfterInsertPoint(0) = 0
AfterInsertPoint(1) = 0
End Select

HCF4003_B_DefineInsertPoint = AfterInsertPoint

End Function

Function HCF4003_C_InsertExternalDrawing(Thisdrawing As AcadDocument, Pathname As String, Blockname As String, InsertPoint As Variant, InsertBlockScale As Integer, RotateAngle As Double, DeleteExplodeMode As String)
'Mode(Delete,Explode,Block)
'Add External Reference
Dim ObjExternalReference As AcadExternalReference
Dim XScale As Integer
Dim YScale As Integer
Dim ZScale As Integer
Dim Overlay As Boolean: Overlay = False

'Define XScale,YScale,ZScale
XScale = InsertBlockScale
YScale = InsertBlockScale
ZScale = InsertBlockScale


'Attach ObjExternalReference
Set ObjExternalReference = Thisdrawing.ModelSpace.AttachExternalReference(Pathname, Blockname, InsertPoint, XScale, YScale, ZScale, RotateAngle, False)
Thisdrawing.Blocks.Item(ObjExternalReference.Name).Bind True

'Explode Block,DeleteBlock
Dim ObjSelectSet As AcadSelectionSet
Dim EachObj As AcadEntity
Dim ObjBlockRef As AcadBlockReference
Dim ObjBlock As AcadBlock
Set ObjSelectSet = Thisdrawing.SelectionSets.Add("ObjSelectSet" & 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>"
ObjSelectSet.Select acSelectionSetAll, , , FT, FD
Set ObjBlockRef = ObjSelectSet.Item(0)
ObjSelectSet.Delete
Select Case DeleteExplodeMode
Case "Delete"
ObjBlockRef.Delete
Set ObjBlock = Thisdrawing.Blocks(Blockname)
ObjBlock.Delete
Case "Explode"
'Explode
Call HCF4007_ExplodeBlockReference(Thisdrawing, ObjBlockRef)
Set ObjBlock = Thisdrawing.Blocks(Blockname)
ObjBlock.Delete
Case "DeleteBlockRef"
ObjBlockRef.Delete
Case Else
End Select

End Function
Function HCF4004_GetPartPropertyBlockRef(Thisdrawing As AcadDocument) As AcadBlockReference

'Call Function Unlock layer Frame
Call Func06UnlockLayer(Thisdrawing, FrameLayerName)
Dim ObjAttBlock As AcadSelectionSet
Set ObjAttBlock = Thisdrawing.SelectionSets.Add("objAttBlock" & 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) = PartPropertyBlock
FT(3) = -4: FD(3) = "AND>"
ObjAttBlock.Select acSelectionSetAll, , , FT, FD
If ObjAttBlock.count = 0 Then
ObjAttBlock.Delete
Exit Function
End If

Dim TitleBlock As AcadBlockReference
For Each TitleBlock In ObjAttBlock
Set HCF4004_GetPartPropertyBlockRef = TitleBlock
Next
ObjAttBlock.Delete
'Call Function Lock Layer Frame
Call Func07LockLayer(Thisdrawing, FrameLayerName)

End Function
Function HCF4005_GetAttValueOfPartPropertyBlockRef(Thisdrawing As AcadDocument, TitleBlock As AcadBlockReference, TagName As String) As String

'Call Function Unlock layer Frame
Call Func06UnlockLayer(Thisdrawing, FrameLayerName)

If TitleBlock Is Nothing Then
Exit Function
End If

Dim varAttributes As Variant
Dim AttTextString As String

varAttributes = TitleBlock.GetAttributes
For i = LBound(varAttributes) To UBound(varAttributes)
If varAttributes(i).TagString = TagName Then
AttTextString = varAttributes(i).TextString
End If
Next

'Call Function Lock Layer Frame
Call Func07LockLayer(Thisdrawing, FrameLayerName)
HCF4005_GetAttValueOfPartPropertyBlockRef = AttTextString

End Function
Function HCF4006_IsBlockInDrawing(Thisdrawing As AcadDocument, Blockname As String) As Boolean
Dim Block As AcadBlock
On Error Resume Next
Set Block = Thisdrawing.Blocks(Blockname)
If Err Then
HCF4006_IsBlockInDrawing = False
Else
HCF4006_IsBlockInDrawing = True
End If

End Function
Function HCF4007_ExplodeBlockReference(Thisdrawing As AcadDocument, Obj As AcadEntity)
Dim ObjHandle As String
Dim ObjHandent As String
ObjHandle = Obj.Handle
ObjHandent = "(handent " & Chr(34) & ObjHandle & Chr(34) & ")"
Thisdrawing.SendCommand "EXPLODE" & vbCr & ObjHandent & vbCr & vbCr
End Function
Function HCF4008_GetFilePath() As String
'Define Folder of Thisdrawing
Dim FolderPath As String
Dim ThisdrawingName As String
FolderPath = Thisdrawing.Fullname
ThisdrawingName = Thisdrawing.Name
FolderPath = WorksheetFunction.Substitute(FolderPath, ThisdrawingName, "")
FolderPath = WorksheetFunction.Substitute(FolderPath, "\", "/")
FolderPath = Chr(34) & FolderPath & Chr(34)

'1.Select file
Dim FilePath As String
Dim StrSendCommand As String
StrSendCommand = "(setvar " & """users1""" & "(getfiled " & """Select a DWG File""" & FolderPath & """dwg""" & "32)) "
Thisdrawing.SendCommand StrSendCommand
'Use the GetVariable method to retrieve this system variable to store the selected file name
FilePath = Thisdrawing.GetVariable("users1")

If FilePath = "" Then
Exit Function
End If
If FilePath = Thisdrawing.Fullname Then
Thisdrawing.SetVariable "users1", ""
MsgBox "The same file is selected." & vbNewLine & "Please select Other Drawing"
Exit Function
End If

'3.Open UpdateFromDrawing
Dim TmpDrawing As AcadDocument
For Each TmpDrawing In Application.Documents
If TmpDrawing.Fullname = FilePath Then
MsgBox "Please Close Selected File before Update"
TmpDrawing.Activate
Exit Function
End If
Next

HCF4008_GetFilePath = FilePath

End Function
Function HCF4009_CreatSonBlocknameArrOfMotherBlock(Thisdrawing As AcadDocument, ObjBlock As AcadBlock) As Variant
'Function tao list tat ca blockname co trong selectset

Dim SonBlocknameArr() As Variant
Dim i As Integer
Dim EachBlockReference As AcadBlockReference
Dim EachBlock As AcadBlock
Dim EachBlockname As String
Dim EachEntity As AcadEntity
Dim BlocknameList As String

'Define SonBlocknameArr(0)
Dim CheckBlockname As String
For Each EachEntity In ObjBlock
If EachEntity.ObjectName = "AcDbBlockReference" Then
Set EachBlockReference = EachEntity
EachBlockname = EachBlockReference.Name
CheckBlockname = ";" & EachBlockname & ";"
If Func64IsNormalBlock(EachBlockReference) = True And InStr(BlocknameList, CheckBlockname) = 0 Then
ReDim Preserve SonBlocknameArr(0 To i)
SonBlocknameArr(i) = EachBlockname
BlocknameList = BlocknameList & CheckBlockname
i = i + 1
End If
End If
Next
If Func70IsEmptyArray(SonBlocknameArr) = True Then Exit Function

'Add SonBlock to SonBlocknameArr
Dim MotherBlock As AcadBlock
Dim MotherBlockname As String
Dim SonBlockRef As AcadBlockReference
Dim SonBlock As AcadBlock
Dim SonBlockname As String
Dim Tmpblockref As AcadBlockReference
Dim j As Integer
Do
MotherBlockname = SonBlocknameArr(j)
Set MotherBlock = Thisdrawing.Blocks(MotherBlockname)
For Each EachEntity In MotherBlock
If EachEntity.ObjectName = "AcDbBlockReference" Then
Set SonBlockRef = EachEntity
SonBlockname = SonBlockRef.Name
CheckBlockname = ";" & SonBlockname & ";"
If Func64IsNormalBlock(SonBlockRef) = True And InStr(BlocknameList, CheckBlockname) = 0 Then
i = UBound(SonBlocknameArr) + 1
ReDim Preserve SonBlocknameArr(0 To i)
SonBlocknameArr(i) = SonBlockname
BlocknameList = BlocknameList & CheckBlockname
End If
End If
Next
j = j + 1
Loop While j <= UBound(SonBlocknameArr)

'Write BlocknameList
ReDim Preserve SonBlocknameArr(0 To UBound(SonBlocknameArr) + 1)
SonBlocknameArr(UBound(SonBlocknameArr)) = BlocknameList

HCF4009_CreatSonBlocknameArrOfMotherBlock = SonBlocknameArr

End Function

 

Message 7 of 15
buianhtuan.cdt
in reply to: leife

Function HCF4012_GetAllTitleBlockA1A2A3A4InDrawing(MyDrawing As AcadDocument) As Variant
'(ObjBlockRef,MinPoint,MaxPoint,BlockScale)
Dim ObjSelectSet As AcadSelectionSet
Set ObjSelectSet = MyDrawing.SelectionSets.Add("ObjSelectSet" & Now)
Dim FT(8) As Integer
Dim FD(8) As Variant
FT(0) = -4: FD(0) = "<AND"
FT(1) = 0: FD(1) = "INSERT"
FT(2) = -4: FD(2) = "<OR"
FT(3) = 2: FD(3) = A1TitleBlockname
FT(4) = 2: FD(4) = A2TitleBlockname
FT(5) = 2: FD(5) = A3TitleBlockname
FT(6) = 2: FD(6) = A4TitleBlockname
FT(7) = -4: FD(7) = "OR>"
FT(8) = -4: FD(8) = "AND>"

'MsgBox
Dim MsgBoxResult As VbMsgBoxResult
Dim MsgPrompt As String
Dim MsgButton As VbMsgBoxStyle
Dim MsgTitle As String
MsgPrompt = "Yes: Automatic Sellect All TitleBlock in drawing" & vbNewLine & _
"No: Manual Select TitleBlock"
MsgButton = vbYesNoCancel + vbSystemModal
MsgTitle = "Select TitleBlock"
MsgBoxResult = MsgBox(MsgPrompt, MsgButton, MsgTitle)
Select Case MsgBoxResult
Case vbYes
ObjSelectSet.Select acSelectionSetAll, , , FT, FD
Case vbNo
ObjSelectSet.SelectOnScreen FT, FD
Case vbCancel
ObjSelectSet.Delete
Exit Function
End Select

'Process
If ObjSelectSet.count = 0 Then
MsgBox "No TitleBlock"
ObjSelectSet.Delete
Exit Function
End If
Dim Result() As Variant
ReDim Result(0 To ObjSelectSet.count - 1, 0 To 3)
Dim EachBlockRef As AcadBlockReference
Dim MinPoint As Variant
Dim MaxPoint As Variant
Dim BlockScale As Double
Dim i As Integer
For Each EachBlockRef In ObjSelectSet
EachBlockRef.GetBoundingBox MinPoint, MaxPoint
BlockScale = EachBlockRef.XScaleFactor
BlockScale = Abs(BlockScale)
Set Result(i, 0) = EachBlockRef
Result(i, 1) = MinPoint
Result(i, 2) = MaxPoint
Result(i, 3) = BlockScale
i = i + 1
Next
ObjSelectSet.Delete

HCF4012_GetAllTitleBlockA1A2A3A4InDrawing = Result

End Function
Function HCF4013_GetAllObjInLimitOfTitleBlock(MyDrawing As AcadDocument, TitleBlockRef As AcadBlockReference) As Variant

'Define MinPoint,MaxPoint
Dim MinPoint As Variant
Dim MaxPoint As Variant
TitleBlockRef.GetBoundingBox MinPoint, MaxPoint

'Select All Obj Crossing MinPoint,MaxPoint
Dim ObjSelectSet As AcadSelectionSet
Set ObjSelectSet = MyDrawing.SelectionSets.Add("ObjSelectSet" & Now)
ObjSelectSet.Select acSelectionSetCrossing, MinPoint, MaxPoint

'Process
If ObjSelectSet.count = 0 Then
MsgBox "No Obj"
ObjSelectSet.Delete
Exit Function
End If
Dim Result() As AcadEntity
Dim EachEntity As AcadEntity
Dim i As Integer
For Each EachEntity In ObjSelectSet
ReDim Preserve Result(0 To i)
Set Result(i) = EachEntity
i = i + 1
Next
ObjSelectSet.Delete

HCF4013_GetAllObjInLimitOfTitleBlock = Result

End Function

Function HCF4014_CreatCopyToDrawing(CFDrawing As AcadDocument, AllObjArr As Variant) As AcadDocument

'Define JNo and SNo
Dim JNo As String
Dim SNo As String
Dim EachEntity As AcadEntity
Dim EachBlockRef As AcadBlockReference
Dim EachAttArr As Variant
For k = LBound(AllObjArr) To UBound(AllObjArr)
Set EachEntity = AllObjArr(k)
If EachEntity.ObjectName = "AcDbBlockReference" Then
Set EachBlockRef = EachEntity
If EachBlockRef.HasAttributes = True Then
EachAttArr = EachBlockRef.GetAttributes
For i = LBound(EachAttArr) To UBound(EachAttArr)
Select Case EachAttArr(i).TagString
Case JNoTagname
JNo = EachAttArr(i).TextString
Case SNoTagname
SNo = EachAttArr(i).TextString
End Select
Next
End If
End If
Next
If JNo = "" Or SNo = "" Then
MsgBox "Because JNo or SNo is Empty" & vbNewLine & "Can not define New Filename"
Exit Function
End If

'Define Filename From JNo and SNo
Dim CTFilename As String
CTFilename = JNo & "-" & SNo

'Define CTFullFilename From CTFilename and CFDrawing
Dim CTFullFilename As String
CTFullFilename = HCF4010_DefineFullFilename(CFDrawing, CTFilename)

'Creat CTDrawing
Dim CTDrawing As AcadDocument
Set CTDrawing = AcadApplication.Documents.Add(TemplateName)
CTDrawing.SaveAs CTFullFilename

Set HCF4014_CreatCopyToDrawing = CTDrawing

End Function
Function HCF4015_SetAttValue(MyDrawing As AcadDocument, Blockname As String, TagName As String, AttValue As Variant) As String

'Func lay gia tri cua AttValue
Dim ObjAttBlock As AcadSelectionSet
Set ObjAttBlock = MyDrawing.SelectionSets.Add("objAttBlock" & 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>"
ObjAttBlock.Select acSelectionSetAll, , , FT, FD

Dim varAttributes As Variant
Dim TitleBlock As AcadBlockReference
For Each TitleBlock In ObjAttBlock
varAttributes = TitleBlock.GetAttributes
Next
Dim i As Integer
For i = LBound(varAttributes) To UBound(varAttributes)
If varAttributes(i).TagString = TagName Then
varAttributes(i).TextString = AttValue
End If
Next
ObjAttBlock.Delete

End Function

Function HCF4016_SetCurrentLayerWhenCloseDrawing(MyDrawing As AcadDocument)

Dim CurrentLayer As AcadLayer
Dim EachLayer As AcadLayer
For Each EachLayer In MyDrawing.Layers
If EachLayer.Name = CloseCurrentLayername Then
Set CurrentLayer = EachLayer
End If
Next
MyDrawing.ActiveLayer = CurrentLayer

End Function

Function HCF4017_SetCurrentDimStyle(MyDrawing As AcadDocument) As Variant

Dim ObjSelectSet As AcadSelectionSet
Set ObjSelectSet = MyDrawing.SelectionSets.Add("ObjSelectSet" & Now)
Dim FT(3) As Integer
Dim FD(3) As Variant
FT(0) = -4: FD(0) = "<OR"
FT(1) = 0: FD(1) = "DIMENSION"
FT(2) = 0: FD(2) = "LEADER"
FT(3) = -4: FD(3) = "OR>"
ObjSelectSet.Select acSelectionSetAll, , , FT, FD
If ObjSelectSet.count = 0 Then
ObjSelectSet.Delete
Exit Function
End If
'Creat DimStyleArr
Dim DimStyleArr() As Variant
Dim EachDimStyle As AcadDimStyle
Dim i As Integer
ReDim DimStyleArr(0 To MyDrawing.DimStyles.count - 1, 0 To 1)
For Each EachDimStyle In MyDrawing.DimStyles
DimStyleArr(i, 0) = EachDimStyle.Name
DimStyleArr(i, 1) = 0
i = i + 1
Next
'Count DimStyle
Dim EachStylename As String
Dim EachCount As Integer
Dim EachEntity As AcadEntity
Dim EachDim As AcadDimension
Dim EachLeader As AcadLeader
Dim EachDimStyleName As String
For Each EachEntity In ObjSelectSet
Select Case EachEntity.ObjectName
Case "AcDbLeader"
Set EachLeader = EachEntity
EachDimStyleName = EachLeader.StyleName
Case Else
Set EachDim = EachEntity
EachDimStyleName = EachDim.StyleName
End Select
For i = 0 To UBound(DimStyleArr)
EachStylename = DimStyleArr(i, 0)
EachCount = DimStyleArr(i, 1)
If EachStylename = EachDimStyleName Then
EachCount = EachCount + 1
DimStyleArr(i, 1) = EachCount
End If
Next
Next
ObjSelectSet.Delete
'Define SubDimStylename
Dim MainDimName As String
Dim MainCount As Integer
MainDimName = DimStyleArr(0, 0)
MainCount = DimStyleArr(0, 1)
For i = 0 To UBound(DimStyleArr)
EachDimStyleName = DimStyleArr(i, 0)
EachCount = DimStyleArr(i, 1)
If EachCount > MainCount Then
MainCount = EachCount
MainDimName = EachDimStyleName
End If
Next
MainDimName = HCF4018_SplitString(MainDimName, "$", "Before")
Call HCF4019_RenameDimStyleName(MyDrawing, MainDimName, MainDimStylename)
'Rename MainDimStyle and Set Current
Dim MainDimStyle As AcadDimStyle
For Each EachDimStyle In MyDrawing.DimStyles
If EachDimStyle.Name = MainDimStylename Then
Set MainDimStyle = EachDimStyle
End If
Next
MyDrawing.ActiveDimStyle = MainDimStyle

End Function

Function HCF4018_SplitString(Str As String, Delimited As String, BeforeAfter As String) As String

Dim SplitArr As Variant
Dim Result As String
If InStr(Str, Delimited) <> 0 Then
SplitArr = Split(Str, Delimited)
Select Case BeforeAfter
Case "Before"
Result = SplitArr(LBound(SplitArr))
Case "After"
Result = SplitArr(UBound(SplitArr))
Case Else
Result = Str
End Select
Else
Result = Str
End If

HCF4018_SplitString = Result

End Function

Function HCF4019_RenameDimStyleName(MyDrawing As AcadDocument, OldName As String, NewName As String)

Dim EachDimStyle As AcadDimStyle
Dim EachDimStyleName As String
For Each EachDimStyle In MyDrawing.DimStyles
EachDimStyleName = EachDimStyle.Name
If InStr(EachDimStyleName, OldName) <> 0 Then
EachDimStyleName = Replace(EachDimStyleName, OldName, NewName)
EachDimStyle.Name = EachDimStyleName
End If
Next

End Function


Function HCF4020_SetDIMSCALEAllDimStyle(MyDrawing As AcadDocument, DimScale As Double)

'Backup Current DimStyle
Dim CurrentDimStyle As AcadDimStyle
Set CurrentDimStyle = MyDrawing.ActiveDimStyle
'Change DIMSCALE
Dim EachDimStyle As AcadDimStyle
Dim EachDimStyleName As String
For Each EachDimStyle In MyDrawing.DimStyles
MyDrawing.ActiveDimStyle = EachDimStyle
MyDrawing.SetVariable "DIMSCALE", DimScale
EachDimStyle.CopyFrom MyDrawing
Next
'Update Dimension and leader
Dim ObjSelectSet As AcadSelectionSet
Set ObjSelectSet = MyDrawing.SelectionSets.Add("ObjSelectSet" & Now)
Dim FT(3) As Integer
Dim FD(3) As Variant
FT(0) = -4: FD(0) = "<OR"
FT(1) = 0: FD(1) = "DIMENSION"
FT(2) = 0: FD(2) = "LEADER"
FT(3) = -4: FD(3) = "OR>"
ObjSelectSet.Select acSelectionSetAll, , , FT, FD
If ObjSelectSet.count = 0 Then
ObjSelectSet.Delete
Exit Function
End If
Dim EachEntity As AcadEntity
Dim EachDim As AcadDimension
Dim EachLeader As AcadLeader
Dim LeaderDimstylename As String
For Each EachEntity In ObjSelectSet
Select Case EachEntity.ObjectName
Case "AcDbLeader"
Set EachLeader = EachEntity
LeaderDimstylename = EachLeader.StyleName
EachLeader.StyleName = LeaderDimstylename
EachLeader.Update
If EachLeader.ScaleFactor <> DimScale Then EachLeader.ScaleFactor = DimScale
Case Else
Set EachDim = EachEntity
EachDim.Update
If EachDim.ScaleFactor <> DimScale Then EachDim.ScaleFactor = DimScale
End Select

Next
'Restore Current DimStyle
MyDrawing.ActiveDimStyle = CurrentDimStyle
End Function
Function HCF4021_IsDimension(Entity As AcadEntity) As Boolean

Dim ObjDim As AcadDimension
On Error Resume Next
Set ObjDim = Entity
If Err Then
HCF4021_IsDimension = False
Else
HCF4021_IsDimension = True
End If

End Function
Function HCF4022_IsLeader(Entity As AcadEntity) As Boolean

Dim ObjLeader As AcadLeader
On Error Resume Next
Set ObjLeader = Entity
If Err Then
HCF4022_IsLeader = False
Else
HCF4022_IsLeader = True
End If

End Function

Function HCF4023_DeleteAllDimLeaderInAllBlock(MyDrawing As AcadDocument)
Dim EachBlock As AcadBlock
Dim EachEntiy As AcadEntity
For Each EachBlock In MyDrawing.Blocks
If EachBlock.IsDynamicBlock = False And Left(EachBlock.Name, 1) <> "*" Then
For Each EachEntiy In EachBlock
If HCF4021_IsDimension(EachEntiy) = True Or HCF4022_IsLeader(EachEntiy) = True Then
EachEntiy.Delete
End If
Next
End If
Next
End Function

Function HCF4024_DeleteNoUseDimStyle(MyDrawing As AcadDocument)
Dim EachDimStyle As AcadDimStyle
On Error Resume Next
For Each EachDimStyle In MyDrawing.DimStyles
EachDimStyle.Delete
Next

End Function


Sub HCS3010_CopyToOtherDrawing()
'(VBA AutoCad) Copy to Other Drawing,[CTOD]

'Define CopyFrom
Dim CFDrawing As AcadDocument
Set CFDrawing = AcadApplication.ActiveDocument

'Select All TitleBlock A1,A2,A3
Dim TitleBlockArr As Variant
TitleBlockArr = HCF4012_GetAllTitleBlockA1A2A3A4InDrawing(CFDrawing)
If Func70IsEmptyArray(TitleBlockArr) = True Then Exit Sub

'Process
Dim EachTitleBlockRef As AcadBlockReference
Dim AllObjInTitleBlockArr As Variant
Dim MinPoint As Variant
Dim MaxPoint As Variant
Dim BlockScale As Double
Dim Point00(0 To 2) As Double
Dim EachEntity As AcadEntity
For i = 0 To UBound(TitleBlockArr)
'Select All Obj in Limit of TitleBlock
Set EachTitleBlockRef = TitleBlockArr(i, 0)
MinPoint = TitleBlockArr(i, 1)
MaxPoint = TitleBlockArr(i, 2)
BlockScale = TitleBlockArr(i, 3)
AllObjInTitleBlockArr = HCF4013_GetAllObjInLimitOfTitleBlock(CFDrawing, EachTitleBlockRef)
If Func70IsEmptyArray(AllObjInTitleBlockArr) = True Then Exit Sub
'Creat CopyToDrawing
Dim CTDrawing As AcadDocument
Set CTDrawing = HCF4014_CreatCopyToDrawing(CFDrawing, AllObjInTitleBlockArr)
If CTDrawing Is Nothing Then
GoTo NextStep01
End If
'Copy Obj to OtherDrawing
Dim AfterCopyObjArr As Variant
AfterCopyObjArr = CFDrawing.CopyObjects(AllObjInTitleBlockArr, CTDrawing.ModelSpace)
'Move AfterCopyObj to (0,0)
For k = LBound(AfterCopyObjArr) To UBound(AfterCopyObjArr)
Set EachEntity = AfterCopyObjArr(k)
EachEntity.Move MinPoint, Point00
Next
'Set LinetypeScale
Dim LTScale As Integer
LTScale = 8 * BlockScale
CTDrawing.SetVariable "LTSCALE", LTScale
'Set Limits
Dim UpperStr As String
Dim UpperX As Double: UpperX = MaxPoint(0) - MinPoint(0)
Dim UpperY As Double: UpperY = MaxPoint(1) - MinPoint(1)
UpperStr = UpperX & "," & UpperY
CTDrawing.SendCommand ("LIMITS" & Chr(13) & Chr(13) & UpperStr & Chr(13))
'Set DrawingScale
Dim DrawingScaleValue As String
DrawingScaleValue = CStr(BlockScale)
Call HCF4015_SetAttValue(CTDrawing, DrawingScaleBlockname, DrawingScaleTagName, DrawingScaleValue)
'Set CurrentLayer
Call HCF4016_SetCurrentLayerWhenCloseDrawing(CTDrawing)
'Set Current Dimension
Call HCF4017_SetCurrentDimStyle(CTDrawing)
'Set Dimscle
Call HCF4020_SetDIMSCALEAllDimStyle(CTDrawing, BlockScale)
'Delete All Dim,Leader in All Block
Call HCF4023_DeleteAllDimLeaderInAllBlock(CTDrawing)
'Delete No Use Dimension Style
Call HCF4024_DeleteNoUseDimStyle(CTDrawing)
'Purge and Close
CTDrawing.PurgeAll
AcadApplication.ZoomExtents
CTDrawing.Close True
NextStep01:
Next
End Sub
Function HCF4010_DefineFullFilename(Thisdrawing As AcadDocument, NewFilename As String) As String
'Define Folder of Thisdrawing
Dim FolderPath As String
Dim ThisdrawingName As String
Dim NewFullFilename As String
FolderPath = Thisdrawing.Fullname
ThisdrawingName = Thisdrawing.Name
FolderPath = WorksheetFunction.Substitute(FolderPath, ThisdrawingName, "")
NewFullFilename = FolderPath & NewFilename & ".dwg"

HCF4010_DefineFullFilename = NewFullFilename
End Function
Function HCF4011_Get2Point(Thisdrawing As AcadDocument, StrMsg1 As String, StrMsg2 As String) As Variant
'Get MinPoint and MaxPoint
'Set UCS is World
Dim Point00(0 To 2) As Double
Call FuncCadHome05SetUCSFromPoint(Point00)
Dim MinPoint As Variant
Dim MaxPoint As Variant
Dim Result(0 To 1) As Variant
'On Error GoTo next01
MinPoint = Thisdrawing.Utility.GetPoint(, StrMsg1)
MaxPoint = Thisdrawing.Utility.GetPoint(, StrMsg2)
next01:
If Err Then
MsgBox "Don't Select Point"
Exit Function
End If
Result(0) = MinPoint
Result(1) = MaxPoint
HCF4011_Get2Point = Result

End Function
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
'Settting A1,A2,A3 TitleBlockName
Public Const A1TitleBlockname As String = "TITLEBLOCK_A1"
Public Const A2TitleBlockname As String = "TITLEBLOCK_A2"
Public Const A3TitleBlockname As String = "TITLEBLOCK_A3"
Public Const A4TitleBlockname As String = "TITLEBLOCK_A4"

'Setting TagName
Public Const JNoTagname As String = "J_NO"
Public Const SNoTagname As String = "S_NO"
Public Const DrawingScaleTagName As String = "NOTE-2"
Public Const DrawingScaleBlockname As String = "ORIGINAL_DWG"

'Add New Drawing
Public Const TemplateName As String = "acadiso.dwt"

'Setting Layer
Public Const CloseCurrentLayername As String = "2-GAWA"

'Main DimStyle
Public Const MainDimStylename As String = "AFASTD"
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;(VBA AutoCad) Copy to Other Drawing,[CTOD]
(defun C:CTOD()
(command "-vbarun" "HCS3010_CopyToOtherDrawing")
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Function Func64IsNormalBlock(ObjBlockRef As AcadBlockReference) As Boolean
'Function kiem tra xem 1 block co phai la block binh thuong khong

If ObjBlockRef.IsDynamicBlock = False And ObjBlockRef.HasAttributes = False Then
Func64IsNormalBlock = True
End If
End Function

Message 8 of 15
buianhtuan.cdt
in reply to: leife

;(VBA AutoCad)Explode Dynamic Block BricsCad,[EDY]
(defun C:EDY()
(command "-vbarun" "HCS3085_BricsCad_ExplodeDynamicBlock")
)
Sub HCS3085_BricsCad_ExplodeDynamicBlock()
'(VBA AutoCad)Explode Dynamic Block BricsCad,[EDY]

'Select Dynamic Block Reference
Dim SelectOnScreen As AcadSelectionSet
Set SelectOnScreen = Thisdrawing.SelectionSets.Add("EachDynamicBlockRef" & Now)
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 0: FD(0) = "INSERT"
SelectOnScreen.SelectOnScreen FT, FD
If SelectOnScreen.Count = 0 Then
SelectOnScreen.Delete
Exit Sub
End If
'Explode DynamicBlock
Dim EachBlockRef As AcadBlockReference
Dim ExplodeArr As Variant
Dim EachEntity As AcadEntity
For Each EachBlockRef In SelectOnScreen
ExplodeArr = EachBlockRef.Explode
EachBlockRef.Delete
For i = LBound(ExplodeArr) To UBound(ExplodeArr)
Set EachEntity = ExplodeArr(i)
If EachEntity.Visible = False Then
EachEntity.Delete
End If
Next
Next
SelectOnScreen.Delete
End Sub

>................................................
................................................
................................................

Sub TB0501InsertOtherDrawing()

Application.ScreenUpdating = False
Application.EnableEvents = False
Dim WS As Worksheet
Set WS = Sheets("15.InsertBlock")

Dim Thisdrawing As AcadDocument
Set Thisdrawing = KhoidongAutoCad

'Read data from Excel
Dim InsertBlockRowNo As Integer: InsertBlockRowNo = 6
Dim FilePath As String
Dim ScaleMode As String
Dim InsertPointMode As String
Dim StrInsertPointX As Variant
Dim StrInsertPointY As Variant
Dim RotateAngle As Double
Dim DeleteExplode As String: DeleteExplode = "Explode"

FilePath = WS.Cells(InsertBlockRowNo, 5)
ScaleMode = WS.Cells(InsertBlockRowNo, 7)
InsertPointMode = WS.Cells(InsertBlockRowNo, 😎
StrInsertPointX = WS.Cells(InsertBlockRowNo, 9)
StrInsertPointY = WS.Cells(InsertBlockRowNo, 10)

'Define Pathname and blockname
Dim Blockname As String
Blockname = "InsertBlock" & Func31HourMinute

Call TB05Func05InsertDrawing(Thisdrawing, FilePath, Blockname, ScaleMode, InsertPointMode, StrInsertPointX, StrInsertPointY, RotateAngle, DeleteExplode)

MsgBox "Finished"
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

Function TB05Func03InsertOtherDrawing(Thisdrawing As AcadDocument, Pathname As String, Blockname As String, InsertPoint As Variant, InsertBlockScale As Integer, RotateAngle As Double, DeleteExplodeMode As String)
'Mode(Delete,Explode,Block)
'Add External Reference
Dim ObjExternalReference As AcadExternalReference
Dim Xscale As Integer
Dim Yscale As Integer
Dim Zscale As Integer
Dim Overlay As Boolean: Overlay = False

'Define XScale,YScale,ZScale
Xscale = InsertBlockScale
Yscale = InsertBlockScale
Zscale = InsertBlockScale

'Attach ObjExternalReference
Set ObjExternalReference = Thisdrawing.ModelSpace.AttachExternalReference(Pathname, Blockname, InsertPoint, Xscale, Yscale, Zscale, RotateAngle, False)
Thisdrawing.Blocks.Item(ObjExternalReference.Name).Bind True

'Explode Block,DeleteBlock
Dim ObjSelectSet As AcadSelectionSet
Dim EachObj As AcadEntity
Dim ObjBlockRef As AcadBlockReference
Dim ObjBlock As AcadBlock
Set ObjSelectSet = Thisdrawing.SelectionSets.ADD("ObjSelectSet" & 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>"
ObjSelectSet.Select acSelectionSetAll, , , FT, FD
Set ObjBlockRef = ObjSelectSet.Item(0)
ObjSelectSet.Delete
Select Case DeleteExplodeMode
Case "Delete"
ObjBlockRef.Delete
Set ObjBlock = Thisdrawing.Blocks(Blockname)
ObjBlock.Delete
Case "Explode"
'Explode
Call TB05Func04ExplodeEntityExplodeEntity(Thisdrawing, ObjBlockRef)
Set ObjBlock = Thisdrawing.Blocks(Blockname)
ObjBlock.Delete
Case Else
End Select

End Function
Function TB05Func04ExplodeEntityExplodeEntity(Thisdrawing As AcadDocument, Obj As AcadEntity)
Dim ObjHandle As String
Dim ObjHandent As String
ObjHandle = Obj.Handle
ObjHandent = "(handent " & Chr(34) & ObjHandle & Chr(34) & ")"
Thisdrawing.SendCommand "EXPLODE" & vbCr & ObjHandent & vbCr & vbCr
End Function
Function TB05Func05InsertDrawing(Thisdrawing As AcadDocument, FilePath As String, Blockname As String, ScaleMode As String, InsertPointMode As String, StrInsertPointX As Variant, StrInsertPointY As Variant, RotateAngle As Double, DeleteExplode As String)

'Define PageSize
Dim TitleBlock As AcadBlockReference
Set TitleBlock = Func30GetPartPropertyBlockRef(Thisdrawing)
Dim PaperSize As String
PaperSize = Func31GetAttValueOfPartPropertyBlockRef(Thisdrawing, TitleBlock, "}–ʃTƒCƒY")

'Define InsertBlockScale from Dimscale and ScaleMode
Dim InsertBlockScale As Integer
InsertBlockScale = TB05Func01DefineInsertBlockScale(Thisdrawing, ScaleMode)

'Define InsertPoint
Dim InsertPoint As Variant
InsertPoint = TB05Func02DefineInsertPoint(Thisdrawing, PaperSize, InsertPointMode, StrInsertPointX, StrInsertPointY, InsertBlockScale)

'Define InsertPoint from PageSize,InsertPointMode,DimScale
Call TB05Func03InsertOtherDrawing(Thisdrawing, FilePath, Blockname, InsertPoint, InsertBlockScale, RotateAngle, DeleteExplode)

End Function

 

Sub TB502AddDwgLibrary()

Application.ScreenUpdating = False
Application.EnableEvents = False
Dim WS As Worksheet
Set WS = Sheets("15.InsertBlock")

'Select file
Dim fnameList, fnameCurFile As Variant
Dim Countfiles As Integer
Countfiles = 0
fnameList = Application.GetOpenFilename(FileFilter:="Brics File (*.dwg),*.dwg", Title:="Choose Brics files", MultiSelect:=True)
If (vbBoolean = VarType(fnameList)) Then
MsgBox "No files selected"
Exit Sub
End If

Dim DongghiData As Integer
Dim StrPath As String
Dim StrFileName As String

For Each fnameCurFile In fnameList
Countfiles = Countfiles + 1
'’ljÁ‚©XV‚©”»–¾‚µ‚Ü‚·
StrPath = fnameCurFile
StrFileName = Func05CreatFilenameFromPath(StrPath, "FileName")
DongghiData = Func13SearchDetectRowNo(WS, 6, StrFileName)
If DongghiData = 0 Then
DongghiData = WS.Cells(Rows.Count, 5).End(xlUp).Row + 1
End If
'Write Data to Excel
WS.Cells(DongghiData, 5).Value = StrPath
WS.Cells(DongghiData, 6).Value = StrFileName
Next

Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox "Processed " & Countfiles & " files"

End Sub
Function TB05Func01DefineInsertBlockScale(Thisdrawing As AcadDocument, ScaleMode As String) As Integer
'Define InsertBlockScale from Dimscale and ScaleMode
Dim InsertBlockScale As Integer
Dim Dimscale As Integer
Dimscale = Thisdrawing.GetVariable("DIMSCALE")
Select Case ScaleMode
Case "Scale"
InsertBlockScale = Dimscale
Case "NoScale"
InsertBlockScale = 1
Case Else
InsertBlockScale = 1
End Select
TB05Func01DefineInsertBlockScale = InsertBlockScale
End Function
Function TB05Func02DefineInsertPoint(Thisdrawing As AcadDocument, PaperSize As String, InsertPointMode As String, StrInsertPointX As Variant, StrInsertPointY As Variant, InsertBlockScale As Integer) As Variant

'Define InsertPointMode from Excel
Select Case InsertPointMode
Case "Automatic"
If VarType(StrInsertPointX) <> vbDouble Or VarType(StrInsertPointY) <> vbDouble Then
InsertPointMode = "SelectPoint"
End If
Select Case PaperSize
Case "A4"
Case "A3"
Case "A2"
Case Else
InsertPointMode = "SelectPoint"
End Select
Case "SelectPoint"
Case "Point00"
Case "DrawingOutside"
If PaperSize = "" Then InsertPointMode = "SelectPoint"
Case Else
InsertPointMode = "SelectPoint"
End Select

'Define InsertPoint
Dim BasicInsertPoint(0 To 2) As Double
Dim AfterInsertPoint(0 To 2) As Double
Dim SelectPoint As Variant
Select Case InsertPointMode
Case "Automatic"
AfterInsertPoint(0) = CDbl(StrInsertPointX) * InsertBlockScale
AfterInsertPoint(1) = CDbl(StrInsertPointY) * InsertBlockScale
Case "SelectPoint"
On Error GoTo next01
SelectPoint = Thisdrawing.Utility.GetPoint(, "Select Insert Point:")
AfterInsertPoint(0) = SelectPoint(0)
AfterInsertPoint(1) = SelectPoint(1)
next01:
If err Then GoTo next02
Case "DrawingOutside"
next02:
Select Case PaperSize
Case "A4"
AfterInsertPoint(0) = A4X11 * InsertBlockScale
Case "A3"
AfterInsertPoint(0) = A3X11 * InsertBlockScale
Case "A2"
AfterInsertPoint(0) = A2X11 * InsertBlockScale
End Select
Case "Point00"
AfterInsertPoint(0) = 0
AfterInsertPoint(1) = 0
End Select

TB05Func02DefineInsertPoint = AfterInsertPoint

End Function

Message 9 of 15
buianhtuan.cdt
in reply to: leife

Sub HCS3083_QuickCreatBlockRef()
'(VBA AutoCad) Quick Creat Block,[QCB]

'Select Obj by SelectSet
Dim EntitySelect As AcadSelectionSet
Dim EachEntity As AcadEntity
Set EntitySelect = Thisdrawing.SelectionSets.Add("EntitySelect" & Now)
Thisdrawing.Utility.Prompt (vbCr & "Select objects to make block")
EntitySelect.SelectOnScreen
If EntitySelect.Count = 0 Then
EntitySelect.Delete
Exit Sub
End If

'Creat Array of obj
ReDim ObjArr(0 To EntitySelect.Count - 1) As Object
For i = 0 To EntitySelect.Count - 1
Set ObjArr(i) = EntitySelect.Item(i)
Next

'Select InsertPoint
Dim InsertPoint As Variant
InsertPoint = HCF4045_GetPoint(Thisdrawing, "Pick Insertion Point: ")
If Func70IsEmptyArray(InsertPoint) = True Then
EntitySelect.Delete
Exit Sub
End If

'Automatic Creat Blockname
Dim Blockname As String
Blockname = HCF4046_AutomaticCreatBlockname()

'Creat Block
Dim ObjBlock As AcadBlock
Set ObjBlock = Thisdrawing.Blocks.Add(InsertPoint, Blockname)
Thisdrawing.CopyObjects ObjArr, ObjBlock

'Insert New Block
Dim ObjBlockRef As AcadBlockReference
Set ObjBlockRef = Thisdrawing.ModelSpace.InsertBlock(InsertPoint, Blockname, 1, 1, 1, 0)

'Delete Old Entity
For Each EachEntity In EntitySelect
EachEntity.Delete
Next
EntitySelect.Delete
End Sub
Function HCF4045_GetPoint(Mydrawing As AcadDocument, StrMsg As String) As Variant

On Error GoTo ExitFunc
Dim Point As Variant
Point = Mydrawing.Utility.GetPoint(, vbCr & StrMsg)
HCF4045_GetPoint = Point

ExitFunc:
End Function

Function HCF4046_AutomaticCreatBlockname() As String

Dim Blockname As String
Dim StrHour As String
Dim StrMinute As String
Dim StrSecond As String
StrHour = DateTime.Hour(Now)
StrMinute = DateTime.Minute(Now)
StrSecond = DateTime.Second(Now)
StrHour = WorksheetFunction.text(StrHour, "00")
StrMinute = WorksheetFunction.text(StrMinute, "00")
StrSecond = WorksheetFunction.text(StrSecond, "00")
Blockname = "QCB" & StrHour & StrMinute & StrSecond
HCF4046_AutomaticCreatBlockname = Blockname

End Function
;(VBA AutoCad) Quick Creat Block,[QCB]
(defun C:QCB()
(command "-vbarun" "HCS3083_QuickCreatBlockRef")
)

Message 10 of 15
buianhtuan.cdt
in reply to: leife

(VBA AutoCad) DelectDimensionStyle,[DDS] DDS HCS3030_DeleteDimensionStyle
(VBA AutoCad) Delete Dim,Leader In All Blocks,[DDIB] DDIB HCS3040_DelectDimLeaderInAllBlocks
(VBA AutoCad) Hidden Dimension Style,[HDS] HDS HCS3050_HiddenDimensionStyle
(VBA AutoCad) Quick Creat Rectange,[QCR] QCR HCS3060_QuickCreatRectange
(VBA AutoCad) Move SelectSet From InsertPoint to InsertPoint or Center of Circle,[MBB] MBB HCS3070_MoveBlockToBlock
(VBA AutoCad) Copy SelectSet From InsertPoint to InsertPoint or Center of Circle,[CBB] CBB HCS3071_CopyBlockToBlock
VBA AutoCad) Purge,[QPU] QPU HCS3080_PurgeThisdrawing
(VBA AutoCad) Process When Close Drawing,[PWC] PWC HCS3101_ProcessWhenCloseDrawing
(VBA AutoCad) Quick Creat Block,[QCB] QCB HCS3083_QuickCreatBlockRef
(VBA DFK) Reset MP, MU to *,[RESETM] RESETM HCS3084_ResetMPMU
(VBA AutoCad)Explode Dynamic Block BricsCad,[EDY] EDY HCS3085_BricsCad_ExplodeDynamicBlock
(VBA AutoCad) KKS Part Balloon Search,[PBS] PBS HCS3086_KKS_PartBalloonSearch
(VBA AutoCad) Check Dimension Measurement,[CDM] CDM HCS3087_CheckDimensionMeasurement
(VBA AutoCad) DFK Balloon Number Arrange,[BNA] BNA HCS3088_DFK_BalloonNumberArrange
(VBA AutoCad) KKS Check Titleblock Scale,[CTBS] CTBS HCS3089_KKS_CheckTitleBlockScale
(VBA AutoCad) KKS DFK Add Change Qty of Chamfer or Hole,[DHQ] Dim Hole Qty DHQ HCS3090_AddChangeQty
(TB VBABoss) Delete Obj of SelectSet by Color,[DOBC] DOBC HCS3091_DeleteObjectByColor
(TB VBABoss) KKS Input Assy Property,[IAPP] IAPP HCS3092_KKS_InputAssyProperty
(VBA AutoCad) KKS Delete Delta Maker,[DDELTA] DDELTA HCS3093_KKS_DeleteDelta
(TB VBABoss)Delete Obj of SelectSet by Type,[DOBT] DOBT HCS3094_DeleteObjectByType
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;(TB VBABoss) Johnan Bolt Calculation,[HOZAI]
(defun C:HOZAI()
(command "-vbarun" "HCS3095_Johnan_BoltCalculation")
)

;(TB VBABoss)Delete Obj of SelectSet by Type,[DOBT]
(defun C:DOBT()
(command "-vbarun" "HCS3094_DeleteObjectByType")
)

;(VBA AutoCad) KKS Delete Delta Maker,[DDELTA]
(defun C:DDELTA()
(command "-vbarun" "HCS3093_KKS_DeleteDelta")
)

;(TB VBABoss) KKS Input Assy Property,[IAPP]
(defun C:IAPP()
(command "-vbarun" "HCS3092_KKS_InputAssyProperty")
)

;(TuanBui)Delete Obj of SelectSet by Color,[DOBC]
(defun C:DOBC()
(command "-vbarun" "HCS3091_DeleteObjectByColor")
)

;(VBA AutoCad) KKS DFK Add Change Qty of Chamfer or Hole,[DHQ] Dim Hole Qty
(defun C:DHQ()
(command "-vbarun" "HCS3090_AddChangeQty")
)

;(VBA AutoCad) KKS Check Titleblock Scale,[CTBS]
(defun C:CTBS()
(command "-vbarun" "HCS3089_KKS_CheckTitleBlockScale")
)

;(VBA AutoCad) DFK Balloon Number Arrange,[BNA]
(defun C:BNA()
(command "-vbarun" "HCS3088_DFK_BalloonNumberArrange")
)

;(VBA AutoCad) Check Dimension Measurement,[CDM]
(defun C:CDM()
(command "-vbarun" "HCS3087_CheckDimensionMeasurement")
)

;(VBA AutoCad) KKS Part Balloon Search,[PBS]
(defun C:PBS()
(command "-vbarun" "HCS3086_KKS_PartBalloonSearch")
)

;(VBA AutoCad)Explode Dynamic Block BricsCad,[EDY]
(defun C:EDY()
(command "-vbarun" "HCS3085_BricsCad_ExplodeDynamicBlock")
)

;(VBA DFK) Reset MP, MU to *,[RESETM]
(defun C:RESETM()
(command "-vbarun" "HCS3084_ResetMPMU")
)

;(VBA AutoCad) Quick Creat Block,[QCB]
(defun C:QCB()
(command "-vbarun" "HCS3083_QuickCreatBlockRef")
)

;(VBA AutoCad) Process When Open Drawing,[PWO]
(defun C:PWO()
(command "-vbarun" "HCS3100_ProcessWhenOpenDrawing")
)
;(VBA AutoCad) Process When Close Drawing,[PWC]
(defun C:PWC()
(command "-vbarun" "HCS3101_ProcessWhenCloseDrawing")
)

;(VBA AutoCad) Purge,[QPU]
(defun C:QPU()
(command "-vbarun" "HCS3080_PurgeThisdrawing")
)

;(VBA AutoCad) Move SelectSet From InsertPoint to InsertPoint or Center of Circle,[MBB]
(defun C:MBB()
(command "-vbarun" "HCS3070_MoveBlockToBlock")
)
;(VBA AutoCad) Copy SelectSet From InsertPoint to InsertPoint or Center of Circle,[CBB]
(defun C:CBB()
(command "-vbarun" "HCS3071_CopyBlockToBlock")
)

;(VBA AutoCad) Quick Creat Rectange,[QCR]
(defun C:QCR()
(command "-vbarun" "HCS3060_QuickCreatRectange")
)

;(VBA AutoCad) Hidden Dimension Style,[HDS]
(defun C:HDS()
(command "-vbarun" "HCS3050_HiddenDimensionStyle")
)

;(VBA AutoCad) Delete Dim,Leader In All Blocks,[DDIB]
(defun C:DDIB()
(command "-vbarun" "HCS3040_DelectDimLeaderInAllBlocks")
)

;(VBA AutoCad) DelectDimensionStyle,[DDS]
(defun C:DDS()
(command "-vbarun" "HCS3030_DeleteDimensionStyle")
)

;(VBA AutoCad) Copy to Other Drawing,[CTOD]
(defun C:CTOD()
(command "-vbarun" "HCS3010_CopyToOtherDrawing_version01")
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Function HCF4000_OpenOtherDrawing() As AcadDocument
'Define Folder of Thisdrawing
Dim FolderPath As String
Dim ThisdrawingName As String
FolderPath = Thisdrawing.Fullname
ThisdrawingName = Thisdrawing.Name
FolderPath = WorksheetFunction.Substitute(FolderPath, ThisdrawingName, "")
FolderPath = WorksheetFunction.Substitute(FolderPath, "\", "/")
FolderPath = Chr(34) & FolderPath & Chr(34)

'1.Select file
Dim FilePath As String
Dim StrSendCommand As String
StrSendCommand = "(setvar " & """users1""" & "(getfiled " & """Select a DWG File""" & FolderPath & """dwg""" & "32)) "
Thisdrawing.SendCommand StrSendCommand
'Use the GetVariable method to retrieve this system variable to store the selected file name
FilePath = Thisdrawing.GetVariable("users1")

If FilePath = "" Then
Exit Function
End If
If FilePath = Thisdrawing.Fullname Then
MsgBox "The same file is selected." & vbNewLine & "Please select Other Drawing"
Exit Function
End If

'3.Open UpdateFromDrawing
Dim UpdateFromDrawing As AcadDocument
Dim TmpDrawing As AcadDocument
Dim FileIsOpening As Boolean
For Each TmpDrawing In Application.Documents
If TmpDrawing.Fullname = FilePath Then
Set UpdateFromDrawing = TmpDrawing
FileIsOpening = True
End If
Next
If FileIsOpening = False Then
Set UpdateFromDrawing = Application.Documents.Open(FilePath, True)
End If
UpdateFromDrawing.Activate
Set HCF4000_OpenOtherDrawing = UpdateFromDrawing
End Function
Function HCF4002_BA_ReplaceBlockRefInMotherBlock(OldBlockName As String, NewBlockname As String, MotherBlockInUpdateFromBlocknameList As Variant)

If Func70IsEmptyArray(MotherBlockInUpdateFromBlocknameList) = True Then Exit Function
'Replace OldBlock in MotherBlock
Dim SearchOldBlockname As String
Dim MotherBlockname As String
Dim SonBlocknameList As String
Dim MotherBlock As AcadBlock
Dim EachEntity As AcadEntity
Dim EachOldBlockRef As AcadBlockReference
Dim ExplodeArr As Variant

SearchOldBlockname = ";" & OldBlockName & ";"
For i = LBound(MotherBlockInUpdateFromBlocknameList) To UBound(MotherBlockInUpdateFromBlocknameList)
MotherBlockname = MotherBlockInUpdateFromBlocknameList(i, 0)
SonBlocknameList = MotherBlockInUpdateFromBlocknameList(i, 1)
If InStr(SonBlocknameList, SearchOldBlockname) <> 0 Then
Set MotherBlock = Thisdrawing.Blocks(MotherBlockname)
For Each EachEntity In MotherBlock
If EachEntity.ObjectName = "AcDbBlockReference" Then
Set EachOldBlockRef = EachEntity
If EachOldBlockRef.Name = OldBlockName Then
ExplodeArr = EachOldBlockRef.Explode
EachOldBlockRef.Delete
SonBlocknameList = Replace(SonBlocknameList, OldBlockName, NewBlockname)
MotherBlockInUpdateFromBlocknameList(i, 1) = SonBlocknameList
End If
End If
Next
End If
Next

End Function
Function HCF4003_A_DefineInsertBlockScale(Thisdrawing As AcadDocument, ScaleMode As String) As Integer
'Define InsertBlockScale from Dimscale and ScaleMode
Dim InsertBlockScale As Integer
Dim Dimscale As Integer
Dimscale = Thisdrawing.GetVariable("DIMSCALE")
Select Case ScaleMode
Case "Scale"
InsertBlockScale = Dimscale
Case "NoScale"
InsertBlockScale = 1
Case Else
InsertBlockScale = 1
End Select
HCF4003_A_DefineInsertBlockScale = InsertBlockScale
End Function
Function HCF4003_B_DefineInsertPoint(Thisdrawing As AcadDocument, PaperSize As String, InsertPointMode As String, StrInsertPointX As Variant, StrInsertPointY As Variant, InsertBlockScale As Integer) As Variant

'Define InsertPointMode from Excel
Select Case InsertPointMode
Case "Automatic"
If VarType(StrInsertPointX) <> vbDouble Or VarType(StrInsertPointY) <> vbDouble Then
InsertPointMode = "SelectPoint"
End If
Select Case PaperSize
Case "A4"
Case "A3"
Case "A2"
Case Else
InsertPointMode = "SelectPoint"
End Select
Case "SelectPoint"
Case "Point00"
Case "DrawingOutside"
If PaperSize = "" Then InsertPointMode = "SelectPoint"
Case Else
InsertPointMode = "SelectPoint"
End Select

'Define InsertPoint
Dim BasicInsertPoint(0 To 2) As Double
Dim AfterInsertPoint(0 To 2) As Double
Dim SelectPoint As Variant
Select Case InsertPointMode
Case "Automatic"
AfterInsertPoint(0) = CDbl(StrInsertPointX) * InsertBlockScale
AfterInsertPoint(1) = CDbl(StrInsertPointY) * InsertBlockScale
Case "SelectPoint"
On Error GoTo next01
SelectPoint = Thisdrawing.Utility.GetPoint(, "Select Insert Point:")
AfterInsertPoint(0) = SelectPoint(0)
AfterInsertPoint(1) = SelectPoint(1)
next01:
If Err Then GoTo next02
Case "DrawingOutside"
next02:
Select Case PaperSize
Case "A4"
AfterInsertPoint(0) = A4X11 * InsertBlockScale
Case "A3"
AfterInsertPoint(0) = A3X11 * InsertBlockScale
Case "A2"
AfterInsertPoint(0) = A2X11 * InsertBlockScale
End Select
Case "Point00"
AfterInsertPoint(0) = 0
AfterInsertPoint(1) = 0
End Select

HCF4003_B_DefineInsertPoint = AfterInsertPoint

End Function

Function HCF4003_C_InsertExternalDrawing(Thisdrawing As AcadDocument, Pathname As String, Blockname As String, InsertPoint As Variant, InsertBlockScale As Integer, RotateAngle As Double, DeleteExplodeMode As String)
'Mode(Delete,Explode,Block)
'Add External Reference
Dim ObjExternalReference As AcadExternalReference
Dim XScale As Integer
Dim YScale As Integer
Dim ZScale As Integer
Dim Overlay As Boolean: Overlay = False

'Define XScale,YScale,ZScale
XScale = InsertBlockScale
YScale = InsertBlockScale
ZScale = InsertBlockScale


'Attach ObjExternalReference
Set ObjExternalReference = Thisdrawing.ModelSpace.AttachExternalReference(Pathname, Blockname, InsertPoint, XScale, YScale, ZScale, RotateAngle, False)
Thisdrawing.Blocks.Item(ObjExternalReference.Name).Bind True

'Explode Block,DeleteBlock
Dim ObjSelectSet As AcadSelectionSet
Dim EachObj As AcadEntity
Dim ObjBlockRef As AcadBlockReference
Dim ObjBlock As AcadBlock
Set ObjSelectSet = Thisdrawing.SelectionSets.Add("ObjSelectSet" & 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>"
ObjSelectSet.Select acSelectionSetAll, , , FT, FD
Set ObjBlockRef = ObjSelectSet.Item(0)
ObjSelectSet.Delete
Select Case DeleteExplodeMode
Case "Delete"
ObjBlockRef.Delete
Set ObjBlock = Thisdrawing.Blocks(Blockname)
ObjBlock.Delete
Case "Explode"
'Explode
Call HCF4007_ExplodeBlockReference(Thisdrawing, ObjBlockRef)
Set ObjBlock = Thisdrawing.Blocks(Blockname)
ObjBlock.Delete
Case "DeleteBlockRef"
ObjBlockRef.Delete
Case Else
End Select

End Function
Function HCF4004_GetPartPropertyBlockRef(Thisdrawing As AcadDocument) As AcadBlockReference

'Call Function Unlock layer Frame
Call Func06UnlockLayer(Thisdrawing, FrameLayerName)
Dim ObjAttBlock As AcadSelectionSet
Set ObjAttBlock = Thisdrawing.SelectionSets.Add("objAttBlock" & 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) = PartPropertyBlock
FT(3) = -4: FD(3) = "AND>"
ObjAttBlock.Select acSelectionSetAll, , , FT, FD
If ObjAttBlock.Count = 0 Then
ObjAttBlock.Delete
Exit Function
End If

Dim TitleBlock As AcadBlockReference
For Each TitleBlock In ObjAttBlock
Set HCF4004_GetPartPropertyBlockRef = TitleBlock
Next
ObjAttBlock.Delete
'Call Function Lock Layer Frame
Call Func07LockLayer(Thisdrawing, FrameLayerName)

End Function
Function HCF4005_GetAttValueOfPartPropertyBlockRef(Thisdrawing As AcadDocument, TitleBlock As AcadBlockReference, TagName As String) As String

'Call Function Unlock layer Frame
Call Func06UnlockLayer(Thisdrawing, FrameLayerName)

If TitleBlock Is Nothing Then
Exit Function
End If

Dim varAttributes As Variant
Dim AttTextString As String

varAttributes = TitleBlock.GetAttributes
For i = LBound(varAttributes) To UBound(varAttributes)
If varAttributes(i).TagString = TagName Then
AttTextString = varAttributes(i).TextString
End If
Next

'Call Function Lock Layer Frame
Call Func07LockLayer(Thisdrawing, FrameLayerName)
HCF4005_GetAttValueOfPartPropertyBlockRef = AttTextString

End Function
Function HCF4006_IsBlockInDrawing(Thisdrawing As AcadDocument, Blockname As String) As Boolean
Dim Block As AcadBlock
On Error Resume Next
Set Block = Thisdrawing.Blocks(Blockname)
If Err Then
HCF4006_IsBlockInDrawing = False
Else
HCF4006_IsBlockInDrawing = True
End If

End Function
Function HCF4007_ExplodeBlockReference(Thisdrawing As AcadDocument, Obj As AcadEntity)
Dim ObjHandle As String
Dim ObjHandent As String
ObjHandle = Obj.Handle
ObjHandent = "(handent " & Chr(34) & ObjHandle & Chr(34) & ")"
Thisdrawing.SendCommand "EXPLODE" & vbCr & ObjHandent & vbCr & vbCr
End Function
Function HCF4008_GetFilePath() As String
'Define Folder of Thisdrawing
Dim FolderPath As String
Dim ThisdrawingName As String
FolderPath = Thisdrawing.Fullname
ThisdrawingName = Thisdrawing.Name
FolderPath = WorksheetFunction.Substitute(FolderPath, ThisdrawingName, "")
FolderPath = WorksheetFunction.Substitute(FolderPath, "\", "/")
FolderPath = Chr(34) & FolderPath & Chr(34)

'1.Select file
Dim FilePath As String
Dim StrSendCommand As String
StrSendCommand = "(setvar " & """users1""" & "(getfiled " & """Select a DWG File""" & FolderPath & """dwg""" & "32)) "
Thisdrawing.SendCommand StrSendCommand
'Use the GetVariable method to retrieve this system variable to store the selected file name
FilePath = Thisdrawing.GetVariable("users1")

If FilePath = "" Then
Exit Function
End If
If FilePath = Thisdrawing.Fullname Then
Thisdrawing.SetVariable "users1", ""
MsgBox "The same file is selected." & vbNewLine & "Please select Other Drawing"
Exit Function
End If

'3.Open UpdateFromDrawing
Dim TmpDrawing As AcadDocument
For Each TmpDrawing In Application.Documents
If TmpDrawing.Fullname = FilePath Then
MsgBox "Please Close Selected File before Update"
TmpDrawing.Activate
Exit Function
End If
Next

HCF4008_GetFilePath = FilePath

End Function
Function HCF4009_CreatSonBlocknameArrOfMotherBlock(Thisdrawing As AcadDocument, ObjBlock As AcadBlock) As Variant
'Function tao list tat ca blockname co trong selectset

Dim SonBlocknameArr() As Variant
Dim i As Integer
Dim EachBlockReference As AcadBlockReference
Dim EachBlock As AcadBlock
Dim EachBlockname As String
Dim EachEntity As AcadEntity
Dim BlocknameList As String

'Define SonBlocknameArr(0)
Dim CheckBlockname As String
For Each EachEntity In ObjBlock
If EachEntity.ObjectName = "AcDbBlockReference" Then
Set EachBlockReference = EachEntity
EachBlockname = EachBlockReference.Name
CheckBlockname = ";" & EachBlockname & ";"
If Func64IsNormalBlock(EachBlockReference) = True And InStr(BlocknameList, CheckBlockname) = 0 Then
ReDim Preserve SonBlocknameArr(0 To i)
SonBlocknameArr(i) = EachBlockname
BlocknameList = BlocknameList & CheckBlockname
i = i + 1
End If
End If
Next
If Func70IsEmptyArray(SonBlocknameArr) = True Then Exit Function

'Add SonBlock to SonBlocknameArr
Dim MotherBlock As AcadBlock
Dim MotherBlockname As String
Dim SonBlockRef As AcadBlockReference
Dim SonBlock As AcadBlock
Dim SonBlockname As String
Dim Tmpblockref As AcadBlockReference
Dim j As Integer
Do
MotherBlockname = SonBlocknameArr(j)
Set MotherBlock = Thisdrawing.Blocks(MotherBlockname)
For Each EachEntity In MotherBlock
If EachEntity.ObjectName = "AcDbBlockReference" Then
Set SonBlockRef = EachEntity
SonBlockname = SonBlockRef.Name
CheckBlockname = ";" & SonBlockname & ";"
If Func64IsNormalBlock(SonBlockRef) = True And InStr(BlocknameList, CheckBlockname) = 0 Then
i = UBound(SonBlocknameArr) + 1
ReDim Preserve SonBlocknameArr(0 To i)
SonBlocknameArr(i) = SonBlockname
BlocknameList = BlocknameList & CheckBlockname
End If
End If
Next
j = j + 1
Loop While j <= UBound(SonBlocknameArr)

'Write BlocknameList
ReDim Preserve SonBlocknameArr(0 To UBound(SonBlocknameArr) + 1)
SonBlocknameArr(UBound(SonBlocknameArr)) = BlocknameList

HCF4009_CreatSonBlocknameArrOfMotherBlock = SonBlocknameArr

End Function

Function HCF4034_Get2Point(Mydrawing As AcadDocument, StrMsg1 As String, StrMsg2 As String) As Variant
'Result (PointA,PointB,Distance,Angle,Direction,MinX,MaxX,MinY,MaxY)
Dim Result(0 To 😎 As Variant

'Select PointA, PointB
Dim PointA As Variant
Dim PointB As Variant
On Error GoTo next01
PointA = Mydrawing.Utility.GetPoint(, vbCr & StrMsg1)
PointB = Mydrawing.Utility.GetPoint(PointA, vbCr & StrMsg2)
next01:
If Err Then
MsgBox "Err: No Selected Point"
HCF4034_Get2Point = False
Exit Function
End If

'Define Distance,Angle between 2 Point
Dim Distance As Double
Dim Angle As Double
Dim ObjLine As AcadLine
Set ObjLine = Mydrawing.ModelSpace.AddLine(PointA, PointB)
Distance = Round(ObjLine.Length, 3)
If Distance = 0 Then
MsgBox "Err: PointA=PointB"
HCF4034_Get2Point = False
ObjLine.Delete
Exit Function
End If
Angle = ObjLine.Angle

'Define MinPoint,MaxPoint
Dim MinPoint As Variant
Dim MaxPoint As Variant
ObjLine.GetBoundingBox MinPoint, MaxPoint

'Define Direction,MinX,MinY,MaxX,MaxY
Dim Direction As String
Dim pi As Double: pi = Round(4 * Atn(1), 3)
Select Case Round(Angle, 3)
Case 0
Direction = "X"
Case pi / 2
Direction = "Y"
Case pi
Direction = "X"
Case 3 * pi / 2
Direction = "Y"
Case 2 * pi
Direction = "X"
End Select

'Define MinX,MinY,MaxX,MaxY
Dim MinX As Double: MinX = MinPoint(0)
Dim MaxX As Double: MaxX = MaxPoint(0)
Dim MinY As Double: MinY = MinPoint(1)
Dim MaxY As Double: MaxY = MaxPoint(1)


Result(0) = MinPoint
Result(1) = MaxPoint
Result(2) = Distance
Result(3) = Angle
Result(4) = Direction
Result(5) = MinX
Result(6) = MaxX
Result(7) = MinY
Result(8) = MaxY

HCF4034_Get2Point = Result
ObjLine.Delete

End Function
Function HCF4035_SelectOnScreenByType(Mydrawing As AcadDocument, ObjType1 As String, ObjType2 As String, ObjType3 As String, ObjType4 As String, ObjType5 As String) As Variant

Dim objSelectOnScreen As AcadSelectionSet
Set objSelectOnScreen = Mydrawing.SelectionSets.Add("objSelectOnScreen" & Now)
Dim FT(6) As Integer
Dim FD(6) As Variant
FT(0) = -4: FD(0) = "<OR"
FT(1) = 0: FD(1) = ObjType1
FT(2) = 0: FD(2) = ObjType2
FT(3) = 0: FD(3) = ObjType3
FT(4) = 0: FD(4) = ObjType4
FT(5) = 0: FD(5) = ObjType5
FT(6) = -4: FD(6) = "OR>"
objSelectOnScreen.SelectOnScreen FT, FD
If objSelectOnScreen.Count = 0 Then
objSelectOnScreen.Delete
Exit Function
End If
Dim EachObj As AcadEntity
Dim ObjArr() As Variant
Dim i As Integer
For Each EachObj In objSelectOnScreen
ReDim Preserve ObjArr(0 To i)
Set ObjArr(i) = EachObj
i = i + 1
Next
objSelectOnScreen.Delete
HCF4035_SelectOnScreenByType = ObjArr
End Function
Function HCF4036X_DefineCenterOfObjArr(ObjArr As Variant)
Dim EachBlockRef As AcadBlockReference
Dim EachCircle As AcadCircle
Dim EachEntity As AcadEntity
For i = LBound(ObjArr) To UBound(ObjArr)
Set EachEntity = ObjArr(i)
Select Case EachEntity.ObjectName
Case "AcDbBlockReference"
Set EachBlockRef = EachEntity
Case "AcDbCircle"
Set EachCircle = EachEntity
End Select
Next
'Define ObjArrCenter
Dim ObjArrCenter As Variant
If Not EachBlockRef Is Nothing Then
ObjArrCenter = EachBlockRef.InsertionPoint
Else
If Not EachCircle Is Nothing Then
ObjArrCenter = EachCircle.Center
End If
End If
HCF4036X_DefineCenterOfObjArr = ObjArrCenter

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

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 = HCF4036X_DefineCenterOfObjArr(ToObjArr)
If Func70IsEmptyArray(ToObjArrCenter) = True Then Exit Function
'Move Obj
For i = LBound(MoveObjArr) To UBound(MoveObjArr)
Set EachEntity = MoveObjArr(i)
Set EachCopyEntiy = EachEntity.Copy
EachCopyEntiy.Move MoveObjArrCenter, ToObjArrCenter
Next
Loop While Func70IsEmptyArray(ToObjArrCenter) = False
End Select
End Function
Function HCF4030_DefineDimStyle(Mydrawing As AcadDocument) As String

'Select Dim or Leader to Define DimStyle
Dim ObjSelectSet As AcadSelectionSet
Set ObjSelectSet = Mydrawing.SelectionSets.Add("ObjSelectSet" & Now)
Dim FT(3) As Integer
Dim FD(3) As Variant
FT(0) = -4: FD(0) = "<OR"
FT(1) = 0: FD(1) = "DIMENSION"
FT(2) = 0: FD(2) = "LEADER"
FT(3) = -4: FD(3) = "OR>"
ObjSelectSet.SelectOnScreen FT, FD
If ObjSelectSet.Count = 0 Then
MsgBox "No Selected Dim or Leader"
ObjSelectSet.Delete
Exit Function
End If
'Define DimStyle
Dim EachEntity As AcadEntity
Dim EachDim As AcadDimension
Dim EachLeader As AcadLeader
Dim LeaderDimstylename As String
For Each EachEntity In ObjSelectSet
LeaderDimstylename = EachEntity.StyleName
Next
ObjSelectSet.Delete

'Convert AAAA$0 to AAAA
LeaderDimstylename = HCF4018_SplitString(LeaderDimstylename, "$", "Before")

HCF4030_DefineDimStyle = LeaderDimstylename

End Function
Function HCF4031_DefineDimStyleFromName(Mydrawing As AcadDocument, DimStylename As String) As AcadDimStyle

Dim EachDimStyle As AcadDimStyle
Dim EachDimStylename As String
Dim Result As AcadDimStyle
For Each EachDimStyle In Mydrawing.DimStyles
EachDimStylename = EachDimStyle.Name
If EachDimStylename = DimStylename Then
Set Result = EachDimStyle
End If
Next
If Not Result Is Nothing Then
Set HCF4031_DefineDimStyleFromName = Result
End If
End Function
Function HCF4032_DeleteDimStyleInAllBlock(Mydrawing As AcadDocument, DimStylename As String)
Dim EachBlock As AcadBlock
Dim EachEntity As AcadEntity
For Each EachBlock In Mydrawing.Blocks
If EachBlock.IsDynamicBlock = False And Left(EachBlock.Name, 1) <> "*" Then
For Each EachEntity In EachBlock
If HCF4021_IsDimension(EachEntity) = True Or HCF4022_IsLeader(EachEntity) = True Then
If InStr(EachEntity.StyleName, DimStylename) <> 0 Then
EachEntity.Delete
End If
End If
Next
End If
Next
End Function
Function HCF4033_DeleteDimStyleInModelSpace(Mydrawing As AcadDocument, DimStylename As String)

Dim EachEntity As AcadEntity
For Each EachEntity In Mydrawing.ModelSpace
If HCF4021_IsDimension(EachEntity) = True Or HCF4022_IsLeader(EachEntity) = True Then
If InStr(EachEntity.StyleName, DimStylename) <> 0 Then
EachEntity.Delete
End If
End If
Next
End Function

Function HCF4038_PurgeBlock(Mydrawing As AcadDocument)

Dim EachBlock As AcadBlock
Dim BeforeCount As Integer
Dim AfterCount As Integer
Dim Delta As Integer
Dim Delta0Count As Integer
On Error Resume Next
Do
BeforeCount = Mydrawing.Blocks.Count
For Each EachBlock In Mydrawing.Blocks
EachBlock.Delete
Next
AfterCount = Mydrawing.Blocks.Count
Delta = AfterCount - BeforeCount
If Delta = 0 Then Delta0Count = Delta0Count + 1
Loop While Delta0Count < 3

End Function

Function HCF4039_PurgeStyle(Mydrawing As AcadDocument, Style As String)

'Define StyleArr
Dim StyleArr As Variant
Select Case Style
Case "Linetype"
Set StyleArr = Mydrawing.Linetypes
Case "DimStyle"
Set StyleArr = Mydrawing.DimStyles
Case "Materials"
Set StyleArr = Mydrawing.Materials
Case "Groups"
Set StyleArr = Mydrawing.Groups
Case "TextStyles"
Set StyleArr = Mydrawing.TextStyles
End Select
If StyleArr Is Nothing Then
Exit Function
End If

'Process
Dim EachStyle As Variant
On Error Resume Next
Dim BeforeCount As Integer
Dim AfterCount As Integer
Dim Delta As Integer
Dim Delta0Count As Integer
Do
BeforeCount = StyleArr.Count
For Each EachStyle In StyleArr
EachStyle.Delete
Next
AfterCount = StyleArr.Count
Delta = AfterCount - BeforeCount
If Delta = 0 Then Delta0Count = Delta0Count + 1
Loop While Delta0Count < 2

End Function
Function HCF4040_PurgeMydrawing(Mydrawing As AcadDocument)
'Purge Blocks
Call HCF4038_PurgeBlock(Mydrawing)
Mydrawing.PurgeAll

'Purge
Call HCF4039_PurgeStyle(Mydrawing, "Linetype")
Call HCF4039_PurgeStyle(Mydrawing, "DimStyle")
Call HCF4039_PurgeStyle(Mydrawing, "Materials")
Call HCF4039_PurgeStyle(Mydrawing, "Groups")
Call HCF4039_PurgeStyle(Mydrawing, "TextStyles")

'Send Command
Mydrawing.SendCommand "-Purge" & vbCr & "A" & vbCr & vbCr & "N" & vbCr

End Function
Function HCF4041_ListFileInFolder(StrFolderPath As String, FileTypeArr As Variant) As Variant

'Define Folder
Dim FSO As Object
Dim f As Folder
Dim ListPath() As Variant
Set FSO = CreateObject("Scripting.FileSystemObject")
Set f = FSO.GetFolder(StrFolderPath)

'Creat ListPath
Dim File As File
Dim Filename As String
Dim FileType As String
Dim CheckFileType As Boolean
Dim TmpFileType As String
Dim k As Integer
For Each File In f.Files
Filename = File.Name
FileType = After_(Filename, ".")
'Check FileType
CheckFileType = False
If Func70IsEmptyArray(FileTypeArr) = True Then
CheckFileType = True
Else
For i = LBound(FileTypeArr) To UBound(FileTypeArr)
TmpFileType = FileTypeArr(i)
If StrComp(FileType, TmpFileType, vbTextCompare) = 0 Then
CheckFileType = True
GoTo NextStep1
End If
Next
End If
NextStep1:
'Write to Arr
If CheckFileType = True Then
ReDim Preserve ListPath(0 To k)
ListPath(k) = File.Path
k = k + 1
End If
Next

'Result
HCF4041_ListFileInFolder = ListPath

End Function
Function HCF4042_ConvertBackslash2Slash(PathArr As Variant) As Variant
'Convert\to/ in FilePath or FolderPath

Dim Result() As Variant
If Func70IsEmptyArray(PathArr) = True Then Exit Function
Dim BeforeStr As String
Dim AfterStr As String
ReDim Result(0 To UBound(PathArr))
For i = LBound(PathArr) To UBound(PathArr)
BeforeStr = PathArr(i)
AfterStr = Replace(BeforeStr, "\", "/")
Result(i) = AfterStr
Next

HCF4042_ConvertBackslash2Slash = Result

End Function
Function HCF4043_CheckUserVariable(Mydrawing As AcadDocument, Variable As String) As Boolean

On Error Resume Next
Dim VariableValue As String
VariableValue = Mydrawing.GetVariable(Variable)
If VariableValue = "True" Then HCF4043_CheckUserVariable = True

End Function


Function HCF4045_GetPoint(Mydrawing As AcadDocument, StrMsg As String) As Variant

On Error GoTo ExitFunc
Dim Point As Variant
Point = Mydrawing.Utility.GetPoint(, vbCr & StrMsg)
HCF4045_GetPoint = Point

ExitFunc:
End Function

Function HCF4046_AutomaticCreatBlockname() As String

Dim Blockname As String
Dim StrHour As String
Dim StrMinute As String
Dim StrSecond As String
StrHour = DateTime.Hour(Now)
StrMinute = DateTime.Minute(Now)
StrSecond = DateTime.Second(Now)
StrHour = WorksheetFunction.text(StrHour, "00")
StrMinute = WorksheetFunction.text(StrMinute, "00")
StrSecond = WorksheetFunction.text(StrSecond, "00")
Blockname = "QCB" & StrHour & StrMinute & StrSecond
HCF4046_AutomaticCreatBlockname = Blockname

End Function
Function HCF4047_Convert2Integer(InputValue As Variant) As Variant

Dim OutputValue As Variant
On Error Resume Next
OutputValue = CInt(InputValue)
If Err Then
OutputValue = False
Else
OutputValue = CInt(InputValue)
If OutputValue - InputValue <> 0 Then OutputValue = False
End If
HCF4047_Convert2Integer = OutputValue

End Function
Function HCF4048_Convert2Double(InputValue As Variant) As Variant

Dim OutputValue As Variant
On Error Resume Next
OutputValue = CDbl(InputValue)
If Err Then
OutputValue = False
Else
OutputValue = CDbl(InputValue)
End If
HCF4048_Convert2Double = OutputValue

End Function

Function HCF4049_GetString(Mydrawing As AcadDocument, HasSpace As Boolean, StrMsg As String, EmptyMode As Boolean) As Variant
On Error Resume Next
Dim Result As Variant
Dim StringValue As String
StringValue = Mydrawing.Utility.GetString(HasSpace, vbCr & StrMsg)
If StringValue = "" Then
If EmptyMode = False Then
Result = False
Else
Result = ""
End If
Else
Result = StringValue
End If
HCF4049_GetString = Result
End Function

Function HCF4050_GetDimMeasurementWithPrecision(ObjDim As AcadDimension) As Double

Dim DimMeasure As Double
Dim UnitPrecision As Integer
Dim L As Double
DimMeasure = ObjDim.Measurement
UnitPrecision = ObjDim.PrimaryUnitsPrecision
L = Round(DimMeasure, UnitPrecision)
HCF4050_GetDimMeasurementWithPrecision = L

End Function
Function HCF4051_GetAttValueOfBlockRef(ObjBlockRef As AcadBlockReference, TagName As String) As Variant

If ObjBlockRef Is Nothing Then
HCF4051_GetAttValueOfBlockRef = False
Exit Function
End If
If ObjBlockRef.HasAttributes = False Then
HCF4051_GetAttValueOfBlockRef = False
Exit Function
End If
Dim varAttributes As Variant
Dim AttTextString As String
varAttributes = ObjBlockRef.GetAttributes
For i = LBound(varAttributes) To UBound(varAttributes)
If varAttributes(i).TagString = TagName Then
AttTextString = varAttributes(i).TextString
End If
Next
HCF4051_GetAttValueOfBlockRef = AttTextString

End Function
Function HCF4052_SetAttValueOfBlockRef(ObjBlockRef As AcadBlockReference, TagName As String, NewAttValue As String) As Boolean

If ObjBlockRef Is Nothing Then
HCF4052_SetAttValueOfBlockRef = False
Exit Function
End If
If ObjBlockRef.HasAttributes = False Then
HCF4052_SetAttValueOfBlockRef = False
Exit Function
End If
Dim varAttributes As Variant
Dim SetFinished As Boolean
varAttributes = ObjBlockRef.GetAttributes
For i = LBound(varAttributes) To UBound(varAttributes)
If varAttributes(i).TagString = TagName Then
varAttributes(i).TextString = NewAttValue
SetFinished = True
End If
Next
HCF4052_SetAttValueOfBlockRef = SetFinished

End Function
Function HCF4053_RedimMang2Chieu(Arr As Variant, RowSize As Integer) As Variant

If Func70IsEmptyArray(Arr) = True Then Exit Function
Dim Result() As Variant
Dim ColumnSize As Integer
ColumnSize = UBound(Arr, 2)
ReDim Result(0 To RowSize, 0 To ColumnSize)
For i = 0 To UBound(Arr)
For k = 0 To ColumnSize
If HCF4054_IsAcadEntity(Arr(i, k)) = False Then
Result(i, k) = Arr(i, k)
Else
Set Result(i, k) = Arr(i, k)
End If
Next
Next
HCF4053_RedimMang2Chieu = Result

End Function
Function HCF4054_IsAcadEntity(Obj As Variant) As Boolean
On Error Resume Next
Dim Entity As AcadEntity
Set Entity = Obj
If Entity Is Nothing Then
HCF4054_IsAcadEntity = False
Else
HCF4054_IsAcadEntity = True
End If

End Function
Function HCF4055_Get1ColumnFromArr(Arr As Variant, ColumnNo As Integer) As Variant

If Func70IsEmptyArray(Arr) = True Then Exit Function
Dim Result() As Variant
Dim RowSize As Integer
Dim ColumnSize As Integer
RowSize = UBound(Arr, 1)
ColumnSize = UBound(Arr, 2)
If ColumnNo > ColumnSize Then Exit Function
ReDim Result(0 To RowSize)
For i = 0 To RowSize
If HCF4054_IsAcadEntity(Arr(i, ColumnNo)) = False Then
Result(i) = Arr(i, ColumnNo)
Else
Set Result(i) = Arr(i, ColumnNo)
End If
Next
HCF4055_Get1ColumnFromArr = Result

End Function
Function HCF4056_SortArrAtoZ_StringType(Arr As Variant) As Variant
' Sap xep cac phan tu cua mang theo thu tu tu A den Z

Dim TmpValue As String
Dim SmallValue As String
Dim LargeValue As String
Dim TmpArr As Variant
TmpArr = Arr

For i = LBound(TmpArr) To UBound(TmpArr)
SmallValue = TmpArr(i)
For k = i To UBound(TmpArr)
LargeValue = TmpArr(k)
If StrComp(SmallValue, LargeValue) = 1 Then
TmpValue = SmallValue
SmallValue = LargeValue
LargeValue = TmpValue
TmpArr(i) = SmallValue
TmpArr(k) = LargeValue
End If
Next
Next

HCF4056_SortArrAtoZ_StringType = TmpArr

End Function
Function HCF4057_SortArrAtoZ_NumberType(Arr As Variant) As Variant
' Sap xep cac phan tu cua mang theo thu tu tu A den Z

Dim TmpValue As Double
Dim SmallValue As Double
Dim LargeValue As Double
Dim TmpArr As Variant
TmpArr = Arr

For i = LBound(TmpArr) To UBound(TmpArr)
SmallValue = TmpArr(i)
For k = i To UBound(TmpArr)
LargeValue = TmpArr(k)
If SmallValue > LargeValue Then
TmpValue = SmallValue
SmallValue = LargeValue
LargeValue = TmpValue
TmpArr(i) = SmallValue
TmpArr(k) = LargeValue
End If
Next
Next

HCF4057_SortArrAtoZ_NumberType = TmpArr

End Function

Function HCF4058X_AddChangeQty_TextMText(Obj As AcadEntity, NewQty As String)
Dim OldString As String
Dim NewString As String
Dim OldQty As String
Dim DelimitedPosition As Integer
OldString = Obj.TextString
DelimitedPosition = InStr(OldString, "-")
If DelimitedPosition = 0 Then
NewString = NewQty & OldString
Else
OldQty = Left(OldString, DelimitedPosition)
NewString = Replace(OldString, OldQty, NewQty)
End If
Obj.TextString = NewString

End Function
Function HCF4059_GetObj(Mydrawing As AcadDocument, StrMsg As String) As Variant
On Error Resume Next
Dim Result(0 To 2) As Variant
Dim Obj As AcadEntity
Dim varPick As Variant
Thisdrawing.Utility.GetEntity Obj, varPick, vbCr & StrMsg
If Obj Is Nothing Then
Result(0) = False
Else
Result(0) = True
Set Result(1) = Obj
Result(2) = varPick
End If
HCF4059_GetObj = Result
End Function
Function HCF4058X_AddChangeQty_ObjDim(Obj As AcadDimension, NewQty As String)

'Get Old Value
Dim OldDimPrefix As String
Dim OldDimTextString As String
OldDimPrefix = Obj.TextPrefix
OldDimTextString = Obj.TextOverride

'Define - Position
Dim DelimitedPosition As Integer
Dim DelimitedIn As String
DelimitedPosition = InStr(OldDimPrefix, "-")
If DelimitedPosition <> 0 Then
DelimitedIn = "Prefix"
Else
DelimitedPosition = InStr(OldDimTextString, "-")
If DelimitedPosition <> 0 Then
DelimitedIn = "Override"
End If
End If

'Change Qty
Dim NewDimPrefix As String
Dim NewTextOverride As String
Dim OldQty As String
Select Case DelimitedIn
Case ""
Obj.TextPrefix = NewQty & OldDimPrefix
Case "Prefix"
OldQty = Left(OldDimPrefix, DelimitedPosition)
NewDimPrefix = Replace(OldDimPrefix, OldQty, NewQty)
Obj.TextPrefix = NewDimPrefix
Case "Override"
OldQty = Left(OldDimTextString, DelimitedPosition)
NewTextOverride = Replace(OldDimTextString, OldQty, NewQty)
Obj.TextOverride = NewTextOverride
End Select
'Error Overide "<>"
If Obj.TextOverride = "<>" Then Obj.TextOverride = ""

End Function
Function HCF4060_GetStringMiddle2Delimited(str As String, Delimited1 As String, Delimited2 As String) As String

Dim Result As String
Dim Delimited1Position As Integer
Dim Delimited2Position As Integer
Delimited1Position = InStr(str, Delimited1)
Delimited2Position = InStr(str, Delimited2)
If Delimited1Position * Delimited2Position = 0 Then Exit Function
Result = Mid(str, Delimited1Position + 1, Delimited2Position - Delimited1Position - 1)
HCF4060_GetStringMiddle2Delimited = Result

End Function
Function HCF4061_GetInteger(Mydrawing As AcadDocument, StrMsg As String) As Variant
On Error Resume Next
Dim Result As Variant
Dim GetInteger As Integer
GetInteger = Thisdrawing.Utility.GetInteger(vbCr & StrMsg)
If GetInteger = 0 Then
Result = False
Else
Result = GetInteger
End If
HCF4061_GetInteger = Result
End Function
Function HCF4062_DefineSmallerLarger(SmallValue As Variant, LargeValue As Variant)

Dim TmpValue As Variant
If SmallValue > LargeValue Then
TmpValue = SmallValue
SmallValue = LargeValue
LargeValue = TmpValue
End If

End Function

Function HCF4063_CircleABisConcentic(CircleA As AcadCircle, CircleB As AcadCircle) As Boolean

Dim CenterA As Variant
Dim CenterB As Variant
Dim XA As Double
Dim YA As Double
Dim XB As Double
Dim YB As Double
CenterA = CircleA.Center
CenterB = CircleB.Center
XA = Round(CenterA(0), 1)
YA = Round(CenterA(1), 1)
XB = Round(CenterB(0), 1)
YB = Round(CenterB(1), 1)
If XA = XB And YA = YB Then
HCF4063_CircleABisConcentic = True
Else
HCF4063_CircleABisConcentic = False
End If

End Function
Function HCF4064_CreatCenterPointArrFromCircleArr(CircleArr As Variant) As Variant

Dim CenterPointArr() As Variant
Dim EachCircle As AcadCircle
Dim TmpCircle As AcadCircle
Dim EachCenterPoint As Variant
Dim Concentic As Boolean
Dim TmpConcentic As Boolean
Dim f As Integer
If Func70IsEmptyArray(CircleArr) = True Then Exit Function
For i = LBound(CircleArr) To UBound(CircleArr)
Concentic = False
Set EachCircle = CircleArr(i)
EachCenterPoint = EachCircle.Center
If i = 0 Then
Concentic = False
Else
For k = 0 To i - 1
Set TmpCircle = CircleArr(k)
TmpConcentic = HCF4063_CircleABisConcentic(EachCircle, TmpCircle)
If TmpConcentic = True Then
Concentic = True
GoTo NextStep
End If
Next
End If
NextStep:
If Concentic = False Then
ReDim Preserve CenterPointArr(0 To f)
CenterPointArr(f) = EachCenterPoint
f = f + 1
End If
Next
HCF4064_CreatCenterPointArrFromCircleArr = CenterPointArr

End Function

Function HCF4065_SubstituteTextWithArr(StrText As Variant, SubstituteArr As Variant)
Dim Result As String: Result = StrText
Dim SubstituteStr As String
For i = LBound(SubstituteArr) To UBound(SubstituteArr)
SubstituteStr = SubstituteArr(i)
Result = WorksheetFunction.Substitute(Result, SubstituteStr, "")
Next
HCF4065_SubstituteTextWithArr = Result
End Function
Function HCF4066_RedimMang2ChieuCong1(Arr As Variant) As Variant

If Func70IsEmptyArray(Arr) = True Then Exit Function
Dim Result() As Variant
Dim ColumnSize As Integer
Dim RowSize As Integer
RowSize = UBound(Arr, 1) + 1
ColumnSize = UBound(Arr, 2)
ReDim Result(0 To RowSize, 0 To ColumnSize)
For i = 0 To UBound(Arr)
For k = 0 To ColumnSize
Result(i, k) = Arr(i, k)
Next
Next
HCF4066_RedimMang2ChieuCong1 = Result
End Function

Function HCF4067_ConvertNumberTiengNhat(StrText As Variant)

Dim Arr(0 To 9, 0 To 1) As String
Arr(0, 0) = "‚O": Arr(0, 1) = "0"
Arr(1, 0) = "‚P": Arr(1, 1) = "1"
Arr(2, 0) = "‚Q": Arr(2, 1) = "2"
Arr(3, 0) = "‚R": Arr(3, 1) = "3"
Arr(4, 0) = "‚S": Arr(4, 1) = "4"
Arr(5, 0) = "‚T": Arr(5, 1) = "5"
Arr(6, 0) = "‚U": Arr(6, 1) = "6"
Arr(7, 0) = "‚V": Arr(7, 1) = "7"
Arr(8, 0) = "‚W": Arr(8, 1) = "8"
Arr(9, 0) = "‚X": Arr(9, 1) = "9"

Dim Result As String: Result = StrText
Dim FromStr As String
Dim ToStr As String
For i = 0 To 9
FromStr = Arr(i, 0)
ToStr = Arr(i, 1)
Result = WorksheetFunction.Substitute(Result, FromStr, ToStr)
Next
HCF4067_ConvertNumberTiengNhat = Result
End Function
Function HCF4068_SortArrAtoZ_Arr2Chieu(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 Func70IsEmptyArray(Arr) = True Then Exit Function
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

HCF4068_SortArrAtoZ_Arr2Chieu = TmpArr

End Function
Function HCF4069_VisibleObjArr1Chieu(ObjArr As Variant, Visible As Boolean)
If Func70IsEmptyArray(ObjArr) = True Then Exit Function
Dim EachEntity As AcadEntity
For i = LBound(ObjArr) To UBound(ObjArr)
Set EachEntity = ObjArr(i)
EachEntity.Visible = Visible
Next
End Function

Function HCF4070_GhiObjArrVaoTotalObjArr_Type1Chieu(TotalObjArr As Variant, WriteObjArr As Variant)
'Check Input
Dim k As Integer
If Func70IsEmptyArray(WriteObjArr) = True Then Exit Function
If Func70IsEmptyArray(TotalObjArr) = True Then
TotalObjArr = WriteObjArr
Else
ReDim Preserve TotalObjArr(0 To UBound(TotalObjArr) + UBound(WriteObjArr) + 1)
For i = UBound(TotalObjArr) - UBound(WriteObjArr) To UBound(TotalObjArr)
Set TotalObjArr(i) = WriteObjArr(k)
k = k + 1
Next
End If
End Function

Function HCF4071_CreatDropListFromArr(Arr As Variant, ColumnNumber As Integer) As Variant
'Function dung de loc bo cac gia tri trung trong 1 cot de tao list chon

Dim TmpArr() As Variant
Dim TmpValue As Variant
Dim CheckHave As Boolean
Dim k As Integer
Dim j As Integer

'set gia tri rong ban dau cho mang
ReDim Preserve TmpArr(0)
TmpArr(0) = ""

For i = LBound(Arr) To UBound(Arr)
TmpValue = Arr(i, ColumnNumber)
CheckHave = False
If i = 0 Then
ReDim TmpArr(0)
TmpArr(0) = TmpValue
Else
For k = LBound(TmpArr) To UBound(TmpArr)
If TmpValue = TmpArr(k) Then
CheckHave = True
GoTo NextStep
End If
Next
NextStep:
If CheckHave = False Then
j = UBound(TmpArr) + 1
ReDim Preserve TmpArr(0 To j)
TmpArr(j) = TmpValue
End If
End If

Next
HCF4071_CreatDropListFromArr = TmpArr
End Function

Function HCF4072_StartExcelFromCad() As Workbook

Dim WB As Workbook
On Error Resume Next
Dim ExcelApp As Excel.Application
Set ExcelApp = GetObject(, "Excel.application")
If Err Then
Set ExcelApp = CreateObject("Excel.application")
End If

ExcelApp.Visible = True
ExcelApp.Application.WindowState = xlMaximized

Set WB = ExcelApp.Workbooks.Add
Set HCF4072_StartExcelFromCad = WB

End Function

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Sub HCS3030_DeleteDimensionStyle()
'(VBA AutoCad) DelectDimensionStyle,[DDS]

'Define DimStyle to Delete
Dim DeleteDimStyle As AcadDimStyle
Dim DeleteDimStylename As String
DeleteDimStylename = HCF4030_DefineDimStyle(Thisdrawing)
DeleteDimStylename = HCF4018_SplitString(DeleteDimStylename, "$", "Before")
If DeleteDimStylename = "" Then
Exit Sub
Else
Set DeleteDimStyle = HCF4031_DefineDimStyleFromName(Thisdrawing, DeleteDimStylename)
End If

'Define CurrentDimStyle
Dim CurrentDimStyle As AcadDimStyle
Set CurrentDimStyle = Thisdrawing.ActiveDimStyle

'Process when DeleteDimStyle=CurrentDimStyle
Dim EachDimStyle As AcadDimStyle
Dim EachDimStylename As String
If CurrentDimStyle.Name = DeleteDimStylename Then
For Each EachDimStyle In Thisdrawing.DimStyles
EachDimStylename = EachDimStyle.Name
If InStr(EachDimStylename, DeleteDimStylename) = 0 Then
Thisdrawing.ActiveDimStyle = EachDimStyle
GoTo NextStep01
End If
Next
End If
NextStep01:

'Convert Dim and Leader in Blocks
Call HCF4032_DeleteDimStyleInAllBlock(Thisdrawing, DeleteDimStylename)

'Convert Dim and Leader in Model Space
Call HCF4033_DeleteDimStyleInModelSpace(Thisdrawing, DeleteDimStylename)

'Delete No Use Dimension Style
Call HCF4024_DeleteNoUseDimStyle(Thisdrawing)

End Sub
Sub HCS3040_DelectDimLeaderInAllBlocks()
'(VBA AutoCad) Delete Dim,Leader In All Blocks,[DDIB]

'Delete All Dim,Leader in All Block
Call HCF4023_DeleteAllDimLeaderInAllBlock(Thisdrawing)
'Delete No Use Dimension Style
Call HCF4024_DeleteNoUseDimStyle(Thisdrawing)

End Sub
Sub HCS3050_HiddenDimensionStyle()
'(VBA AutoCad) Hidden Dimension Style,[HDS]

'Define DimStyle to Hidden
Dim HiddenDimStylename As String
HiddenDimStylename = HCF4030_DefineDimStyle(Thisdrawing)
HiddenDimStyle = HCF4018_SplitString(HiddenDimStylename, "$", "Before")
If HiddenDimStylename = "" Then
Exit Sub
End If

'Hidden Dim and Leader in Model Space
Dim HiddenCount As Integer
Dim ObjSelectSet As AcadSelectionSet
Set ObjSelectSet = Thisdrawing.SelectionSets.Add("ObjSelectSet" & Now)
Dim FT(3) As Integer
Dim FD(3) As Variant
FT(0) = -4: FD(0) = "<OR"
FT(1) = 0: FD(1) = "DIMENSION"
FT(2) = 0: FD(2) = "LEADER"
FT(3) = -4: FD(3) = "OR>"
ObjSelectSet.Select acSelectionSetAll, , , FT, FD
If ObjSelectSet.Count = 0 Then
ObjSelectSet.Delete
Exit Sub
End If
Dim EachEntity As AcadEntity
For Each EachEntity In ObjSelectSet
EachEntity.Visible = False
HiddenCount = HiddenCount + 1
Next
ObjSelectSet.Delete
'Result
MsgBox "Hidden " & HiddenCount & " Dimension And Leader"

End Sub
Sub HCS3060_QuickCreatRectange()
'(VBA AutoCad) Quick Creat Rectange,[QCR]
Thisdrawing.Utility.Prompt (vbCrLf & "Quick Creat Rectange" & vbCrLf)

'Set ORTHO ON
Thisdrawing.SetVariable "ORTHOMODE", 1
'Set UCS is world
Dim Point00(0 To 2) As Double
Call FuncCadHome05SetUCSFromPoint(Point00)
'Select 4 Point
'Result (PointA,PointB,Distance,Angle,Direction,MinX,MaxX,MinY,MaxY)
Dim Result12 As Variant
Dim Result34 As Variant
Dim Direction12 As String
Dim Direction34 As String
Dim Direction As String
Result12 = HCF4034_Get2Point(Thisdrawing, "Select Point X1", "Select Point X2")
If VarType(Result12) = vbBoolean Then Exit Sub
Result34 = HCF4034_Get2Point(Thisdrawing, "Select Point Y1", "Select Point Y2")
If VarType(Result34) = vbBoolean Then Exit Sub

'Define MinX,MaxX,MinY,MaxY
Dim MinX As Double
Dim MaxX As Double
Dim MinY As Double
Dim MaxY As Double
MinX = Result12(5)
MaxX = Result12(6)
MinY = Result34(7)
MaxY = Result34(8)


'Define MinPoint and MaxPoint of Rectange
Dim Point01(0 To 2) As Variant
Dim Point02(0 To 2) As Variant
Point01(0) = MinX
Point01(1) = MinY
Point01(2) = 0
Point02(0) = MaxX
Point02(1) = MaxY
Point02(2) = 0

'Creat Rectange Through MinPoint and MaxPoint
Dim Rectange As AcadLWPolyline
Set Rectange = Func66CreatRectangeThrough2Point(Point01, Point02)

End Sub

Sub HCS3070_MoveBlockToBlock()
'(VBA AutoCad) Move SelectSet From InsertPoint to InsertPoint or Center of Circle,[MBB]
Thisdrawing.Utility.Prompt (vbCrLf & "Move SelectSet From InsertPoint to InsertPoint or Center of Circle" & vbCrLf)

'Setting
Dim MoveCopy As String: MoveCopy = "Move"
'Process
Call HCF4037X_MoveBlockToBlock(Thisdrawing, MoveCopy)

End Sub
Sub HCS3071_CopyBlockToBlock()
'(VBA AutoCad) Copy SelectSet From InsertPoint to InsertPoint or Center of Circle,[CBB]
Thisdrawing.Utility.Prompt (vbCrLf & "Copy SelectSet From InsertPoint to InsertPoint or Center of Circle" & vbCrLf)

'Setting
Dim MoveCopy As String: MoveCopy = "Copy"
'Process
Call HCF4037X_MoveBlockToBlock(Thisdrawing, MoveCopy)

End Sub

Sub Sub4001_InsertTBLibrary()
'(VBA AutoCad) Insert TuanBui Library,[ITBL]

'Define Library FilePath
Dim Folder As String
Dim Filename As String
Dim FilePath As String
Folder = "C:\Users\buian\Desktop\TEST BRICS\02-INSERT NOTE"
Filename = "00-TBLIBRARY.dwg"
FilePath = Folder & "\" & Filename

'Check Exists file
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.fileExists(FilePath) Then 'kiem tra trong thu muc co ton tai file k
Set FSO = Nothing
Else
Set FSO = Nothing
MsgBox "Please check File Path"
Exit Sub
End If

'Insert
Dim ScaleMode As String: ScaleMode = "Scale"
'"Automatic","SelectPoint","Point00","DrawingOutside"
Dim InsertPointMode As String: InsertPointMode = "DrawingOutside"
Dim StrInsertPointX As Double
Dim StrInsertPointY As Double
Dim RotateAngle As Double
Dim DeleteExplode As String: DeleteExplode = "Explode"
'Define Pathname and blockname
Dim ExternalBlockname As String
ExternalBlockname = "UpdateBlock" & Func31HourMinute
Call HCF4003_InsertExternalDrawing(Thisdrawing, FilePath, ExternalBlockname, ScaleMode, InsertPointMode, StrInsertPointX, StrInsertPointY, RotateAngle, DeleteExplode)
End Sub


Sub Sub4002_A_InsertSurfaceTexture0()
'(VBA AutoCad) Insert Surface Texture Ra0,[RA0]

Dim BeginBlockname As String: BeginBlockname = "RA0_"
Call Func5012_InsertSurfaceTexture(BeginBlockname)

End Sub

Sub Sub4002_B_InsertSurfaceTexture25()
'(VBA AutoCad) Insert Surface Texture Ra25,[RA25]

Dim BeginBlockname As String: BeginBlockname = "RA25_"
Call Func5012_InsertSurfaceTexture(BeginBlockname)

End Sub
Sub Sub4002_C_InsertSurfaceTexture125()
'(VBA AutoCad) Insert Surface Texture Ra125,[RA125]

Dim BeginBlockname As String: BeginBlockname = "RA125_"
Call Func5012_InsertSurfaceTexture(BeginBlockname)

End Sub
Sub Sub4002_D_InsertSurfaceTexture63()
'(VBA AutoCad) Insert Surface Texture Ra63,[RA63]

Dim BeginBlockname As String: BeginBlockname = "RA63_"
Call Func5012_InsertSurfaceTexture(BeginBlockname)

End Sub
Sub Sub4002_E_InsertSurfaceTexture32()
'(VBA AutoCad) Insert Surface Texture Ra32,[RA32]

Dim BeginBlockname As String: BeginBlockname = "RA32_"
Call Func5012_InsertSurfaceTexture(BeginBlockname)

End Sub
Sub Sub4002_F_InsertSurfaceTexture16()
'(VBA AutoCad) Insert Surface Texture Ra16,[RA16]

Dim BeginBlockname As String: BeginBlockname = "RA16_"
Call Func5012_InsertSurfaceTexture(BeginBlockname)

End Sub

Sub HCS3080_PurgeThisdrawing()
'(VBA AutoCad) Purge,[QPU]

Call HCF4040_PurgeMydrawing(Thisdrawing)
MsgBox "Finish"

End Sub
Sub HCS3081_LoadLispFromVBA()
'(VBA AutoCad) Load Lisp By VBA

'Check VariableLoadLisp
If HCF4043_CheckUserVariable(Thisdrawing, VariableLoadLisp) = True Then Exit Sub

'Define FolderPath
Dim FolderPath As String
FolderPath = LispLibraryFolderPath

'Define FiletypeArr(lsp,dvb,vlx)
Dim FileTypeArr(0 To 2) As Variant
FileTypeArr(0) = "lsp"
FileTypeArr(1) = "vlx"
FileTypeArr(2) = "dvb"


'Creat FilePathArr
Dim FilePathArr As Variant
FilePathArr = HCF4041_ListFileInFolder(FolderPath, FileTypeArr)
If Func70IsEmptyArray(FilePathArr) = True Then Exit Sub

'Convert\to/
FilePathArr = HCF4042_ConvertBackslash2Slash(FilePathArr)

'Load Lisp
Dim LispPath As String
Dim StrCommand As String
For i = LBound(FilePathArr) To UBound(FilePathArr)
LispPath = FilePathArr(i)
StrCommand = "(load " & """" & LispPath & """" & ")" & vbCrLf
Thisdrawing.SendCommand StrCommand
Next
Thisdrawing.SetVariable "USERS1", "True"

End Sub
Sub HCS3083_QuickCreatBlockRef()
'(VBA AutoCad) Quick Creat Block,[QCB]

'Select Obj by SelectSet
Dim EntitySelect As AcadSelectionSet
Dim EachEntity As AcadEntity
Set EntitySelect = Thisdrawing.SelectionSets.Add("EntitySelect" & Now)
Thisdrawing.Utility.Prompt (vbCr & "Select objects to make block")
EntitySelect.SelectOnScreen
If EntitySelect.Count = 0 Then
EntitySelect.Delete
Exit Sub
End If

'Creat Array of obj
ReDim ObjArr(0 To EntitySelect.Count - 1) As Object
For i = 0 To EntitySelect.Count - 1
Set ObjArr(i) = EntitySelect.Item(i)
Next

'Select InsertPoint
Dim InsertPoint As Variant
InsertPoint = HCF4045_GetPoint(Thisdrawing, "Pick Insertion Point: ")
If Func70IsEmptyArray(InsertPoint) = True Then
EntitySelect.Delete
Exit Sub
End If

'Automatic Creat Blockname
Dim Blockname As String
Blockname = HCF4046_AutomaticCreatBlockname()

'Creat Block
Dim ObjBlock As AcadBlock
Set ObjBlock = Thisdrawing.Blocks.Add(InsertPoint, Blockname)
Thisdrawing.CopyObjects ObjArr, ObjBlock

'Insert New Block
Dim ObjBlockRef As AcadBlockReference
Set ObjBlockRef = Thisdrawing.ModelSpace.InsertBlock(InsertPoint, Blockname, 1, 1, 1, 0)

'Delete Old Entity
For Each EachEntity In EntitySelect
EachEntity.Delete
Next
EntitySelect.Delete
End Sub


Sub HCS3084_ResetMPMU()
'(VBA DFK) Reset MP, MU to *,[RESETM]

'Select PartListBlock
Dim SelectOnScreen As AcadSelectionSet
Set SelectOnScreen = Thisdrawing.SelectionSets.Add("PLBlockRef" & 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) = PLBlockname
FT(3) = -4: FD(3) = "AND>"
SelectOnScreen.SelectOnScreen FT, FD
If SelectOnScreen.Count = 0 Then
SelectOnScreen.Delete
Exit Sub
End If

'Process
Dim PLBlockRef As AcadBlockReference
Dim varAttributes As Variant
Dim PartNoValue As Variant
Dim QtyValue As Variant
Dim MPValue As Variant
Dim MUValue As Variant
Dim MateValue As Variant
Dim Change As Boolean
For Each PLBlockRef In SelectOnScreen
'Define PartNo,Qty
varAttributes = PLBlockRef.GetAttributes
For i = LBound(varAttributes) To UBound(varAttributes)
Select Case varAttributes(i).TagString
Case PLPartNoTagname
PartNoValue = varAttributes(i).TextString
Case PLQtyTagname
QtyValue = varAttributes(i).TextString
Case PLMateTagname
MateValue = varAttributes(i).TextString
End Select
Next
PartNoValue = HCF4047_Convert2Integer(PartNoValue)
QtyValue = HCF4047_Convert2Integer(QtyValue)
'Define MP,MU
If VarType(PartNoValue) <> vbBoolean Then
If VarType(QtyValue) = vbBoolean Then
QtyValue = "*"
MPValue = "*"
MUValue = "*"
Change = True
Else
Select Case QtyValue
Case 1
MPValue = ""
MUValue = "*"
Case Else
MPValue = "*"
MUValue = "*"
End Select
Change = True
End If
End If
If Left(MateValue, 1) <> "-" Then Change = False
'Write data
If Change = True Then
For i = LBound(varAttributes) To UBound(varAttributes)
Select Case varAttributes(i).TagString
Case PLQtyTagname
varAttributes(i).TextString = QtyValue
Case PLMPTagname
varAttributes(i).TextString = MPValue
Case PLMUTagname
varAttributes(i).TextString = MUValue
End Select
Next
PLBlockRef.Highlight True
End If
Next
SelectOnScreen.Delete

End Sub
Sub HCS3085_BricsCad_ExplodeDynamicBlock()
'(VBA AutoCad)Explode Dynamic Block BricsCad,[EDY]

'Select Dynamic Block Reference
Dim SelectOnScreen As AcadSelectionSet
Set SelectOnScreen = Thisdrawing.SelectionSets.Add("EachDynamicBlockRef" & Now)
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 0: FD(0) = "INSERT"
SelectOnScreen.SelectOnScreen FT, FD
If SelectOnScreen.Count = 0 Then
SelectOnScreen.Delete
Exit Sub
End If
'Explode DynamicBlock
Dim EachBlockRef As AcadBlockReference
Dim ExplodeArr As Variant
Dim EachEntity As AcadEntity
For Each EachBlockRef In SelectOnScreen
ExplodeArr = EachBlockRef.Explode
EachBlockRef.Delete
For i = LBound(ExplodeArr) To UBound(ExplodeArr)
Set EachEntity = ExplodeArr(i)
If EachEntity.Visible = False Then
EachEntity.Delete
End If
Next
Next
SelectOnScreen.Delete
End Sub
Sub HCS3086_KKS_PartBalloonSearch()
'(VBA AutoCad) KKS Part Balloon Search,[PBS]

'Setting
Dim PartBalloonEffectiveName As String
Dim TagString As String
PartBalloonEffectiveName = "BLN_PartsA"
TagString = "}”Ô"


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

'Select All
Dim objSelectAll As AcadSelectionSet
Set objSelectAll = Thisdrawing.SelectionSets.Add("objSelectAll" & Now)
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 0: FD(0) = "INSERT"
objSelectAll.Select acSelectionSetAll, , , FT, FD
If objSelectAll.Count = 0 Then
objSelectAll.Delete
Exit Sub
End If

'Creat SearchResultArr
Dim SearchResultArr() As Variant
Dim EachobjSelectAll As AcadBlockReference
Dim EachEffectiveName As String
Dim varAttributes As Variant
Dim TagValue As String
Dim TextValue As String
Dim k As Integer

For Each EachobjSelectAll In objSelectAll
EachEffectiveName = EachobjSelectAll.EffectiveName
If InStr(EachEffectiveName, PartBalloonEffectiveName) <> 0 Then
varAttributes = EachobjSelectAll.GetAttributes
For i = LBound(varAttributes) To UBound(varAttributes)
TagValue = varAttributes(i).TagString
TextValue = varAttributes(i).TextString
If TagValue = TagString And InStr(1, TextValue, SearchBalloonNo, vbTextCompare) <> 0 Then
ReDim Preserve SearchResultArr(0 To k)
Set SearchResultArr(k) = EachobjSelectAll
k = k + 1
End If
Next
End If
Next
objSelectAll.Delete
If Func70IsEmptyArray(SearchResultArr) = True 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
Sub HCS3087_CheckDimensionMeasurement()
'(VBA AutoCad) Check Dimension Measurement,[CDM]

'Select All Dimension
Dim SelectOnScreen As AcadSelectionSet
Set SelectOnScreen = Thisdrawing.SelectionSets.Add("EachDynamicBlockRef" & Now)
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 0: FD(0) = "DIMENSION"
SelectOnScreen.Select acSelectionSetAll, , , FT, FD
If SelectOnScreen.Count = 0 Then
SelectOnScreen.Delete
Exit Sub
End If

'Check Dimension Measurement
Dim CheckResult() As AcadDimension
Dim ObjDim As AcadDimension
Dim DimMeasurement As Double
Dim CheckInteger As Variant
Dim CheckDimMeasurement As Boolean
Dim k As Integer
For Each ObjDim In SelectOnScreen
DimMeasurement = HCF4050_GetDimMeasurementWithPrecision(ObjDim)
CheckInteger = DimMeasurement / 0.5
CheckInteger = HCF4047_Convert2Integer(CheckInteger)
If VarType(CheckInteger) = vbBoolean Then
ReDim Preserve CheckResult(0 To k)
Set CheckResult(k) = ObjDim
k = k + 1
End If
Next
SelectOnScreen.Delete
If Func70IsEmptyArray(CheckResult) = True Then
Exit Sub
End If

'Display Result
Dim ErrCount As Integer
ErrCount = UBound(CheckResult) + 1
For i = LBound(CheckResult) To UBound(CheckResult)
Set ObjDim = CheckResult(i)
ObjDim.Color = acMagenta
Next
MsgBox "Check Dimension Measurement: " & ErrCount

'Reset Dim Color
Dim response As VbMsgBoxResult
response = MsgBox("Reset Err Dimemsion Color", vbYesNo)
Select Case response
Case vbYes
Case vbNo
Exit Sub
End Select
For i = LBound(CheckResult) To UBound(CheckResult)
Set ObjDim = CheckResult(i)
ObjDim.Color = acByLayer
Next
End Sub

Sub HCS3088_DFK_BalloonNumberArrange()
'(VBA AutoCad) DFK Balloon Number Arrange,[BNA]

'Setting
Dim TagString As String
TagString = "ITEM"

'Select Balloon to Arrange
Thisdrawing.Utility.Prompt vbCr & "Select Balloon to Arrange Number"
Dim SelectOnScreen As AcadSelectionSet
Set SelectOnScreen = Thisdrawing.SelectionSets.Add("SelectOnScreen" & Now)
Dim FT(4) As Integer
Dim FD(4) As Variant
FT(0) = -4: FD(0) = "<OR"
FT(1) = 0: FD(1) = "INSERT"
FT(2) = 0: FD(2) = "TEXT"
FT(3) = 0: FD(3) = "MTEXT"
FT(4) = -4: FD(4) = "OR>"
SelectOnScreen.SelectOnScreen FT, FD
If SelectOnScreen.Count = 0 Then
SelectOnScreen.Delete
Exit Sub
End If

'Creat BalloonArr(ObjType,Obj,X,BalloonNumber)
Dim BalloonArr() As Variant
ReDim BalloonArr(0 To SelectOnScreen.Count - 1, 0 To 3)
Dim k As Integer
Dim EachText As AcadText
Dim EachMText As AcadMText
Dim EachBlockRef As AcadBlockReference
Dim EachEntity As AcadEntity
Dim EachType As String
Dim EachPoint As Variant
Dim EachX As Double
Dim EachBalloonNumber As Variant
For Each EachEntity In SelectOnScreen
Select Case EachEntity.ObjectName
Case "AcDbText"
Set EachText = EachEntity
EachType = "Text"
EachPoint = EachText.InsertionPoint
EachBalloonNumber = EachText.TextString
Case "AcDbMText"
Set EachMText = EachEntity
EachType = "MText"
EachPoint = EachMText.InsertionPoint
EachBalloonNumber = EachMText.TextString
Case "AcDbBlockReference"
Set EachBlockRef = EachEntity
EachType = "BlockRef"
EachPoint = EachBlockRef.InsertionPoint
EachBalloonNumber = HCF4051_GetAttValueOfBlockRef(EachBlockRef, TagString)
End Select
EachBalloonNumber = HCF4047_Convert2Integer(EachBalloonNumber)
EachX = EachPoint(0)
If VarType(EachBalloonNumber) = vbInteger Then
BalloonArr(k, 0) = EachType
Set BalloonArr(k, 1) = EachEntity
BalloonArr(k, 2) = EachX
BalloonArr(k, 3) = EachBalloonNumber
k = k + 1
End If
Next
SelectOnScreen.Delete
If k = 0 Then
MsgBox "No Balloon"
Exit Sub
Else
BalloonArr = HCF4053_RedimMang2Chieu(BalloonArr, k - 1)
End If

'Get XPositionArr and BalloonNumberArr
Dim XPositionArr() As Variant
Dim BalloonNumberArr() As Variant
XPositionArr = HCF4055_Get1ColumnFromArr(BalloonArr, 2)
BalloonNumberArr = HCF4055_Get1ColumnFromArr(BalloonArr, 3)
'Sort A to Z
XPositionArr = HCF4057_SortArrAtoZ_NumberType(XPositionArr)
BalloonNumberArr = HCF4057_SortArrAtoZ_NumberType(BalloonNumberArr)

'Change AttValue
Dim TmpX As Double
Dim Tmpstr As String
For k = LBound(BalloonArr) To UBound(BalloonArr)
EachType = BalloonArr(k, 0)
Set EachEntity = BalloonArr(k, 1)
EachX = BalloonArr(k, 2)
'Define BalloonNumber
For i = LBound(XPositionArr) To UBound(XPositionArr)
TmpX = XPositionArr(i)
If TmpX = EachX Then EachBalloonNumber = BalloonNumberArr(i)
Tmpstr = CStr(EachBalloonNumber)
Next
Select Case EachType
Case "Text"
Set EachText = EachEntity
EachText.TextString = EachBalloonNumber
Case "MText"
Set EachMText = EachEntity
EachMText.TextString = EachBalloonNumber
Case "BlockRef"
Set EachBlockRef = EachEntity
EachBalloonNumber = HCF4052_SetAttValueOfBlockRef(EachBlockRef, TagString, Tmpstr)
End Select
Next

End Sub
Sub HCS3089_KKS_CheckTitleBlockScale()
'(VBA AutoCad) KKS Check Titleblock Scale,[CTBS]

'Setting
Dim TagString As String
TagString = "kŽÚ"

'Get Dimscale
Dim Dimscale As Integer
Dimscale = Thisdrawing.GetVariable("DIMSCALE")

'Get Part Property Block
Dim TitleBlock As AcadBlockReference
Set TitleBlock = HCF4004_GetPartPropertyBlockRef(Thisdrawing)
If TitleBlock Is Nothing Then
MsgBox "No TitleBlock"
Exit Sub
End If

'Get Drawing Scale
Dim DrawingScaleStr As String
Dim DrawingScale As Double
Dim BeforeValue As Integer
Dim AfterValue As Integer
DrawingScaleStr = HCF4005_GetAttValueOfPartPropertyBlockRef(Thisdrawing, TitleBlock, TagString)
BeforeValue = Before_(DrawingScaleStr, "/")
AfterValue = After_(DrawingScaleStr, "/")
DrawingScale = 1 / (BeforeValue / AfterValue)

'Check DrawingScale
If DrawingScale = Dimscale Then
Else
MsgBox "Drawing Scale <> DIMSCALE"
End If
End Sub

Sub HCS3090_AddChangeQty()
'(VBA AutoCad) KKS DFK Add Change Qty of Chamfer or Hole,[DHQ] Dim Hole Qty

'Select Text or MText or Dimension
Dim SelectOnScreen As AcadSelectionSet
Set SelectOnScreen = Thisdrawing.SelectionSets.Add("SelectOnScreen" & Now)
Dim FT(4) As Integer
Dim FD(4) As Variant
FT(0) = -4: FD(0) = "<OR"
FT(1) = 0: FD(1) = "DIMENSION"
FT(2) = 0: FD(2) = "TEXT"
FT(3) = 0: FD(3) = "MTEXT"
FT(4) = -4: FD(4) = "OR>"
SelectOnScreen.SelectOnScreen FT, FD
If SelectOnScreen.Count = 0 Then
SelectOnScreen.Delete
Exit Sub
End If

'Get NewQty From User
Dim NewQty As String
Dim GetString As Variant
GetString = HCF4049_GetString(Thisdrawing, False, vbCr & "New Qty:", True)
If VarType(GetString) = vbBoolean Then Exit Sub
NewQty = GetString
If NewQty = "" Or NewQty = "0" Or NewQty = "1" Then
NewQty = ""
Else
NewQty = NewQty & "-"
End If
NewQty = LCase(NewQty)
'Process
Dim EachEntity As AcadEntity
Dim ObjText As AcadText
Dim ObjMText As AcadMText
Dim ObjDim As AcadDimension
For Each EachEntity In SelectOnScreen
Select Case EachEntity.ObjectName
Case "AcDbText"
Set ObjText = EachEntity
Call HCF4058X_AddChangeQty_TextMText(ObjText, NewQty)
Case "AcDbMText"
Set ObjMText = EachEntity
Call HCF4058X_AddChangeQty_TextMText(ObjMText, NewQty)
Case Else
Set ObjDim = EachEntity
Call HCF4058X_AddChangeQty_ObjDim(ObjDim, NewQty)
End Select
Next
End Sub
Sub HCS3091_DeleteObjectByColor()
'(TB VBABoss)Delete Obj of SelectSet by Color,[DOBC]

'Select Obj
Thisdrawing.Utility.Prompt vbCr & "Select Obj to delete:" & vbCr
Dim objSelect As AcadSelectionSet
Set objSelect = Thisdrawing.SelectionSets.Add("Select" & Now)
objSelect.SelectOnScreen
If objSelect.Count = 0 Then
objSelect.Delete
Exit Sub
End If

'Get Obj
Dim GetObj() As Variant
Dim Obj As AcadEntity
GetObj = HCF4059_GetObj(Thisdrawing, "Select Color to Delete:")
If GetObj(0) = False Then
objSelect.Delete
Exit Sub
Else
Set Obj = GetObj(1)
End If

'Define Color
Dim Color As String
Color = Obj.Color

'Delete Obj by Color
Dim EachobjSelect As AcadEntity
For Each EachobjSelect In objSelect
If EachobjSelect.Color = Color Then
EachobjSelect.Delete
End If
Next
objSelect.Delete

End Sub

Sub HCS3092_KKS_InputAssyProperty()
'(TB VBABoss) KKS Input Assy Property,[IAPP]

'Check Filename and ”N“x
Thisdrawing.Utility.Prompt vbCr & "ƒtƒ@ƒCƒ‹‚̃tƒH[ƒ}ƒbƒg:@»”Ô-‹@”Ô-**-*-**-**(•ª—Þ–¼Ì)_“ú•t " & vbNewLine & _
"”N“x: 2020" & vbCr
Dim NenDo As String: NenDo = "2020"

'Unlock Frame Layer
Call Func06UnlockLayer(Thisdrawing, FrameLayerName)

'Get AssyPropertyBlockRef
Dim ObjBlockRef As AcadBlockReference
Dim EachEntity As AcadEntity
Dim SelectOnScreen As AcadSelectionSet
Set SelectOnScreen = Thisdrawing.SelectionSets.Add("AssyProperty" & 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) = AssyPropertyBlock
FT(3) = -4: FD(3) = "AND>"
SelectOnScreen.Select acSelectionSetAll, , , FT, FD
If SelectOnScreen.Count = 0 Then
SelectOnScreen.Delete
Exit Sub
End If
For Each EachEntity In SelectOnScreen
Set ObjBlockRef = EachEntity
Next
SelectOnScreen.Delete
'Get Property From Filename
'3207-K4500-R9-1-00-00(ê—p•”•i)_0320.dwg
Dim Filename As String: Filename = Thisdrawing.Name
Filename = Replace(Filename, "i", "(")
Filename = Replace(Filename, "j", ")")
Filename = Replace(Filename, " ", "")
Filename = Replace(Filename, "@", "")

Dim SeiBan As String: SeiBan = Left(Filename, 4)
Dim KiBan As String: KiBan = Mid(Filename, 6, 5)
Dim KumiZuBan As String
Dim BunRuiMeiShou As String
KumiZuBan = Before_(Filename, "(")
KumiZuBan = Right(KumiZuBan, Len(KumiZuBan) - 5)
BunRuiMeiShou = HCF4060_GetStringMiddle2Delimited(Filename, "(", ")")

'Write to Att Block
Dim varAttributes As Variant
varAttributes = ObjBlockRef.GetAttributes
For i = LBound(varAttributes) To UBound(varAttributes)
Select Case varAttributes(i).TagString
Case "”N“x"
varAttributes(i).TextString = NenDo
Case "»”Ô"
varAttributes(i).TextString = SeiBan
Case "‹@”Ô"
varAttributes(i).TextString = KiBan
Case "‘g}”Ô"
varAttributes(i).TextString = KumiZuBan
Case "•ª—Þ–¼Ì"
varAttributes(i).TextString = BunRuiMeiShou
End Select
Next

'Lock Frame Layer
Call Func07LockLayer(Thisdrawing, FrameLayerName)

'Update Property

End Sub

Sub HCS3093_KKS_DeleteDelta()
'(VBA AutoCad) KKS Delete Delta Maker,[DDELTA]

'Select All
Dim objSelectAll As AcadSelectionSet
Set objSelectAll = Thisdrawing.SelectionSets.Add("objSelectAll" & Now)
Dim FTA(0) As Integer
Dim FDA(0) As Variant
FTA(0) = 0: FDA(0) = "INSERT"
objSelectAll.Select acSelectionSetAll, , , FTA, FDA
If objSelectAll.Count = 0 Then
objSelectAll.Delete
Exit Sub
End If

'Creat DeltaBlockRefArr
Dim DeltaBlockRefArr() As Variant
Dim EachBlockRef As AcadBlockReference
Dim EachBlockname As String
Dim k As Integer
For Each EachBlockRef In objSelectAll
EachBlockname = EachBlockRef.Name
If InStr(1, EachBlockname, "DELTA", vbTextCompare) <> 0 Then
ReDim Preserve DeltaBlockRefArr(0 To k)
Set DeltaBlockRefArr(k) = EachBlockRef
k = k + 1
End If
Next
objSelectAll.Delete
If k = 0 Then
MsgBox "No Delta Maker in Thisdrawing"
Exit Sub
End If

'Show Result
Dim MinPoint As Variant
Dim MaxPoint As Variant
Dim DeltaBlockRef As AcadBlockReference
Dim SelectOnScreen As AcadSelectionSet
Set SelectOnScreen = Thisdrawing.SelectionSets.Add("SelectOnScreen" & Now)
Dim EachEntity As AcadEntity
Dim FT(5) As Integer
Dim FD(5) As Variant
FT(0) = -4: FD(0) = "<OR"
FT(1) = 0: FD(1) = "INSERT"
FT(2) = 0: FD(2) = "TEXT"
FT(3) = 0: FD(3) = "MTEXT"
FT(4) = 0: FD(4) = "LINE"
FT(5) = -4: FD(5) = "OR>"

For i = LBound(DeltaBlockRefArr) To UBound(DeltaBlockRefArr)
'Zoom
Set DeltaBlockRef = DeltaBlockRefArr(i)
DeltaBlockRef.GetBoundingBox MinPoint, MaxPoint
Application.ZoomWindow MinPoint, MaxPoint
'Select Obj to Delete
SelectOnScreen.SelectOnScreen FT, FD
If SelectOnScreen.Count = 0 Then
SelectOnScreen.Delete
Exit Sub
End If
'Delete
SelectOnScreen.Erase
Next
SelectOnScreen.Delete

MsgBox "Finish"

End Sub
Sub HCS3094_DeleteObjectByType()
'(TB VBABoss)Delete Obj of SelectSet by Type,[DOBT]

'Select Obj
Thisdrawing.Utility.Prompt vbCr & "Select Obj to delete:" & vbCr
Dim objSelect As AcadSelectionSet
Set objSelect = Thisdrawing.SelectionSets.Add("Select" & Now)
objSelect.SelectOnScreen
If objSelect.Count = 0 Then
objSelect.Delete
Exit Sub
End If

'Get Obj
Dim GetObj() As Variant
Dim Obj As AcadEntity
GetObj = HCF4059_GetObj(Thisdrawing, "Select Type to Delete:")
If GetObj(0) = False Then
objSelect.Delete
Exit Sub
Else
Set Obj = GetObj(1)
End If

'Define Color
Dim ObjName As String
ObjName = Obj.ObjectName

'Delete Obj by Type
Dim EachobjSelect As AcadEntity
For Each EachobjSelect In objSelect
If EachobjSelect.ObjectName = ObjName Then
EachobjSelect.Delete
End If
Next
objSelect.Delete

End Sub
Sub HCS3095_Johnan_BoltCalculation()
'(TB VBABoss) Johnan Bolt Calculation,[HOZAI]

'Total
Dim TotalResultArr() As Variant
Dim EachResult As String
Dim TotalNo As Integer
Dim WriteToResult As Boolean

'Setting Qty Text Comment
Dim QtyTextComment(0 To 3) As String
QtyTextComment(0) = " "
QtyTextComment(1) = "x"
QtyTextComment(2) = "ƒ–Š"
QtyTextComment(3) = "~"

''Get Hozai From and Hozai To
' Dim HozaiNoFrom As Integer
' Dim HozaiNoTo As Integer
' Dim GetInteger As Variant
' GetInteger = HCF4061_GetInteger(Thisdrawing, "Hozai No From:")
' If VarType(GetInteger) = vbBoolean Then
' Exit Sub
' Else
' HozaiNoFrom = GetInteger
' End If
' GetInteger = HCF4061_GetInteger(Thisdrawing, "Hozai No To:")
' If VarType(GetInteger) = vbBoolean Then
' Exit Sub
' Else
' HozaiNoTo = GetInteger
' End If
' Call HCF4062_DefineSmallerLarger(HozaiNoFrom, HozaiNoTo)

'SelectSet Circle,Text,MText
Dim SelectOnScreen As AcadSelectionSet
Set SelectOnScreen = Thisdrawing.SelectionSets.Add("SelectOnScreen" & Now)
Dim FT(4) As Integer
Dim FD(4) As Variant
Dim SSCount As Integer
FT(0) = -4: FD(0) = "<OR"
FT(1) = 0: FD(1) = "CIRCLE"
FT(2) = 0: FD(2) = "TEXT"
FT(3) = 0: FD(3) = "MTEXT"
FT(4) = -4: FD(4) = "OR>"

'Creat CenterPointArr
Dim ObjVisibleArr() As Variant
Dim CenterPointArr As Variant
Dim CircleArr() As Variant
Dim EachEntity As AcadEntity
Dim EachCircle As AcadCircle
Dim R As Double
Dim k As Integer
Dim f As Integer
'Creat BallNoQtyArr(BallNo,BallQty,BallMsg)
Dim BallNoQtyArr() As Variant
Dim CenterPoint As Variant
Dim CenterPointX As Double
Dim CenterPointY As Double
Dim EachTextPoint As Variant
Dim EachTextString As String
Dim Distance As Double
Dim UQtyStr As String
'Define UQty
Dim UQty As Integer
'Define BallNoQtyArr(BallNo,BallQty,UQty,Msg)
Dim HaveErr As Boolean
Dim BallNo As Variant
Dim BallQty As Variant
Dim BallMsg As String
Dim EachMsg As String
'Msg
Dim Msg As String
'MsgBox
Dim TotalObjVisible() As Variant
Dim response As VbMsgBoxResult


Do
k = 0
f = 0
ReDim CircleArr(0)
ReDim ObjVisibleArr(0)
ReDim CenterPointArr(0)
UQtyStr = ""
HaveErr = False
SelectOnScreen.SelectOnScreen FT, FD
SSCount = SelectOnScreen.Count
If SelectOnScreen.Count = 0 Then
SelectOnScreen.Clear
GoTo ExitLoop
End If
'Creat CenterPointArr
For Each EachEntity In SelectOnScreen
If EachEntity.ObjectName = "AcDbCircle" Then
Set EachCircle = EachEntity
If EachCircle.radius > R Then R = EachCircle.radius
ReDim Preserve ObjVisibleArr(0 To f)
ReDim Preserve CircleArr(0 To k)
Set CircleArr(k) = EachCircle
Set ObjVisibleArr(f) = EachCircle
EachCircle.Visible = False
k = k + 1
f = f + 1
End If
Next
If k = 0 Then
SelectOnScreen.Clear
HaveErr = True
GoTo ProcessWhenErr
End If
CenterPointArr = HCF4064_CreatCenterPointArrFromCircleArr(CircleArr)

'Creat BallNoQtyArr(BallNo,BallQty,BallMsg)
ReDim BallNoQtyArr(0 To UBound(CenterPointArr), 0 To 3)
For i = LBound(CenterPointArr) To UBound(CenterPointArr)
CenterPoint = CenterPointArr(i)
CenterPointX = CenterPoint(0)
For Each EachEntity In SelectOnScreen
If EachEntity.Visible = True Then
EachTextPoint = Func19ObjectCenterPoint(EachEntity)
EachTextString = EachEntity.TextString
EachTextString = LCase(EachTextString)
EachTextString = Trim(EachTextString)
If InStr(1, EachTextString, QtyTextComment(2), vbTextCompare) <> 0 Then
UQtyStr = EachTextString
EachEntity.Visible = False
ReDim Preserve ObjVisibleArr(0 To f)
Set ObjVisibleArr(f) = EachEntity
f = f + 1
Else
If EachTextPoint(0) > CenterPointX - R And EachTextPoint(0) < CenterPointX + R Then
Distance = Func20LengthLineThrough2Point(CenterPoint, EachTextPoint)
If Distance < R Then
BallNoQtyArr(i, 0) = EachTextString
EachEntity.Visible = False
ReDim Preserve ObjVisibleArr(0 To f)
Set ObjVisibleArr(f) = EachEntity
f = f + 1
Else
BallNoQtyArr(i, 1) = EachTextString
EachEntity.Visible = False
ReDim Preserve ObjVisibleArr(0 To f)
Set ObjVisibleArr(f) = EachEntity
f = f + 1
End If
End If
End If
End If
Next
Next
'Define UQty
If UQtyStr = "" Then
UQty = 1
Else
UQtyStr = HCF4065_SubstituteTextWithArr(UQtyStr, QtyTextComment)
UQtyStr = HCF4067_ConvertNumberTiengNhat(UQtyStr)
UQty = CInt(UQtyStr)
End If
'Define BallNoQtyArr(BallNo,BallQty,UQty,Msg)
For i = LBound(BallNoQtyArr) To UBound(BallNoQtyArr)
'Define BallNo
BallNo = BallNoQtyArr(i, 0)
If BallNo = "" Then
HaveErr = True
GoTo ProcessWhenErr
End If
BallNo = HCF4065_SubstituteTextWithArr(BallNo, QtyTextComment)
BallNo = HCF4067_ConvertNumberTiengNhat(BallNo)
BallNoQtyArr(i, 0) = CInt(BallNo)
'Define BallQty
BallQty = BallNoQtyArr(i, 1)
If BallQty = "" Then
BallQty = 1
Else
BallQty = HCF4065_SubstituteTextWithArr(BallQty, QtyTextComment)
BallQty = HCF4067_ConvertNumberTiengNhat(BallQty)
BallQty = CInt(BallQty)
End If
BallNoQtyArr(i, 1) = BallQty
'Define EachMsg
Select Case UQty
Case 1
EachMsg = BallQty & "-" & "(" & BallNo & ")"
Case Else
Select Case BallQty
Case 1
EachMsg = UQty & "x" & "(" & BallNo & ")"
Case Else
EachMsg = UQty & "x" & BallQty & "-" & "(" & BallNo & ")"
End Select
End Select
BallNoQtyArr(i, 2) = EachMsg
'Define EachResult
EachResult = BallNo & "-" & UQty * BallQty
BallNoQtyArr(i, 3) = EachResult
Next
'Sort BallNoQtyArr
If UBound(BallNoQtyArr) >= 1 Then
BallNoQtyArr = HCF4068_SortArrAtoZ_Arr2Chieu(BallNoQtyArr, 0, "Number")
End If
'Msg
For i = LBound(BallNoQtyArr) To UBound(BallNoQtyArr)
EachMsg = BallNoQtyArr(i, 2)
If i = 0 Then
Msg = EachMsg
Else
Msg = Msg & vbNewLine & EachMsg
End If
Next
'Visible obj
Call HCF4069_VisibleObjArr1Chieu(ObjVisibleArr, True)

'MsgBox
response = MsgBox(Msg, vbYesNo)
Select Case response
Case vbYes
Call HCF4070_GhiObjArrVaoTotalObjArr_Type1Chieu(TotalObjVisible, ObjVisibleArr)
Call HCF4069_VisibleObjArr1Chieu(ObjVisibleArr, False)
WriteToResult = True
Case vbNo
WriteToResult = False
End Select
ProcessWhenErr:
If HaveErr = True Then
MsgBox "Check Balloon Number"
response = MsgBox("Continue or Reset?" & vbNewLine & "Yes (Continue)" & vbNewLine & "No (Reset)", vbYesNo)
Select Case response
Case vbYes
WriteToResult = False
Call HCF4069_VisibleObjArr1Chieu(ObjVisibleArr, True)
Case vbNo
SelectOnScreen.Delete
Call HCF4069_VisibleObjArr1Chieu(ObjVisibleArr, True)
Call HCF4069_VisibleObjArr1Chieu(TotalObjVisible, True)
Exit Sub
End Select
End If
'Write Result to Total Result
If WriteToResult = True Then
For i = LBound(BallNoQtyArr) To UBound(BallNoQtyArr)
EachResult = BallNoQtyArr(i, 3)
ReDim Preserve TotalResultArr(0 To TotalNo)
TotalResultArr(TotalNo) = EachResult
TotalNo = TotalNo + 1
Next
End If
SelectOnScreen.Clear
ExitLoop:
Loop While SSCount <> 0
SelectOnScreen.Delete

'Creat BallResultArr(BallNo,BallQty)
If Func70IsEmptyArray(TotalResultArr) = True Then Exit Sub
Dim BallResultArr() As Variant
ReDim BallResultArr(0 To UBound(TotalResultArr), 0 To 1)
For i = LBound(BallResultArr) To UBound(BallResultArr)
EachResult = TotalResultArr(i)
BallNo = Before_(EachResult, "-")
BallQty = After_(EachResult, "-")
BallResultArr(i, 0) = CInt(BallNo)
BallResultArr(i, 1) = CInt(BallQty)
Next

'FilterBallNo and sort a to z
Dim FilterArr As Variant
FilterArr = HCF4071_CreatDropListFromArr(BallResultArr, 0)
FilterArr = HCF4057_SortArrAtoZ_NumberType(FilterArr)

'Sum BallQty
Dim SumArr() As Variant
ReDim SumArr(0 To UBound(FilterArr), 0 To 1)
For i = LBound(SumArr) To UBound(SumArr)
BallNo = FilterArr(i)
BallQty = 0
For k = LBound(BallResultArr) To UBound(BallResultArr)
If BallResultArr(k, 0) = BallNo Then
BallQty = BallQty + BallResultArr(k, 1)
End If
Next
SumArr(i, 0) = BallNo
SumArr(i, 1) = BallQty
Next
'Write to Excel
Dim WB As Workbook
Dim WS As Worksheet
Set WB = HCF4072_StartExcelFromCad()
Set WS = WB.ActiveSheet
WS.Cells(1, 1).Value = "Balloon No"
WS.Cells(1, 2).Value = "Qty"
For i = LBound(SumArr) To UBound(SumArr)
WS.Cells(i + 2, 1).Value = SumArr(i, 0)
WS.Cells(i + 2, 2).Value = SumArr(i, 1)
Next

Call HCF4069_VisibleObjArr1Chieu(TotalObjVisible, True)
MsgBox "Finish"
End Sub

 

Message 11 of 15
buianhtuan.cdt
in reply to: leife


Option Explicit


Function TBF03_CheckGiaTriODauTien(WS As Worksheet, ActiveCellRow As Integer, CantMove As Boolean, ListLoaiTru As Variant)
Dim FirstColumnValue As String
FirstColumnValue = WS.Cells(ActiveCellRow, 1).Value
Dim IsInList As Boolean
IsInList = HCF4077_InStrWithList(ListLoaiTru, FirstColumnValue, vbTextCompare)
If FirstColumnValue = "" Or IsInList = True Then
CantMove = True
Exit Function
End If
End Function

Function TBF02_DefineColumnFromToStr(WS As Worksheet, ColumnFromStr As String, ColumnToStr As String)
ColumnFromStr = "A"
Dim ColumnTo As Integer
Call HCF4080_DefineColumnEndNo(WS, ColumnTo, 1)
ColumnToStr = HCF4081_ConvertColumnNumberToLetter(ColumnTo)
End Function
Function TBF06_OChonNamTrongVungDuLieu(WS As Worksheet, CantMove As Boolean)
Dim ColumnFrom As Integer: ColumnFrom = 1
Dim ColumnTo As Integer
Call HCF4080_DefineColumnEndNo(WS, ColumnTo, 1)
Dim RowFrom As Integer: RowFrom = 1
Dim EndRow As Integer
Call HCF4079_DefineRowEndNo(WS, EndRow, ColumnFrom)
Dim ActiveRow As Integer
Dim ActiveColumn As Integer
ActiveRow = ActiveCell.Row
ActiveColumn = ActiveCell.Column
If ActiveRow > EndRow Or ActiveColumn > ColumnTo Then CantMove = True

End Function

Function TBF04_DefineProjectRange(WS As Worksheet, ProjectRange As Range, ColumnFromStr As String, ColumnToStr As String, ActiveCellRow As Integer, CantMove As Boolean)
'Luu du lieu Project hien tai
Dim ProjectRowBegin As Integer
Dim ProjectRowEnd As Integer
ProjectRowBegin = ActiveCellRow - 1
ProjectRowEnd = ActiveCellRow + 1
If ProjectRowEnd < 1 Then
CantMove = True
Exit Function
End If
Set ProjectRange = WS.Range(ColumnFromStr & ProjectRowBegin & ":" & ColumnToStr & ProjectRowEnd)

End Function

Function TBF05_DefineUpDowRange(CantMove As Boolean, WS As Worksheet, UpDownMode As String, ActiveCellRow As Integer, ListLoaiTru As Variant)
'Xac dinh pham vi Project Up or Down
Dim UpdownRowBegin As Integer
Dim UpDownRowEnd As Integer
Select Case UpDownMode
Case "Up"
UpdownRowBegin = ActiveCellRow - 4
UpDownRowEnd = ActiveCellRow - 2
Case "Down"
UpdownRowBegin = ActiveCellRow + 2
UpDownRowEnd = ActiveCellRow + 4
End Select
If UpdownRowBegin < 1 Then
CantMove = True
Exit Function
End If

'Check ProjectUpDown co trung Group va Calculation k
Dim CheckUpDown As Boolean
CheckUpDown = TBF01_CheckProjectUpDown(WS, UpdownRowBegin, UpDownRowEnd, ListLoaiTru)
If CheckUpDown = True Then
CantMove = True
Exit Function
End If

End Function


Function TBF07_MoveProjectUp(ProjectRange As Range)

ProjectRange.Copy
Dim InsertPosition As Range
Dim FirstCell As Range
Dim AfterPosition As Range
Set FirstCell = ProjectRange.Cells(1, 1)
Set InsertPosition = FirstCell.Offset(-3, 0)
InsertPosition.Select
Selection.Insert Shift:=xlDown
ProjectRange.Delete Shift:=xlUp
Set AfterPosition = InsertPosition.Offset(-2, 0)
AfterPosition.Select

End Function
Function TBF08_MoveProjectDown(ProjectRange As Range)

ProjectRange.Copy
Dim InsertPosition As Range
Dim FirstCell As Range
Dim AfterPosition As Range
Set FirstCell = ProjectRange.Cells(1, 1)
Set InsertPosition = FirstCell.Offset(6, 0)
InsertPosition.Select
Selection.Insert Shift:=xlDown
ProjectRange.Delete Shift:=xlUp
Set AfterPosition = InsertPosition.Offset(-2, 0)
AfterPosition.Select
End Function

Sub TBS01_MoveProjectUpDown(UpDownMode As String)

'Setting
Dim WS As Worksheet
Set WS = ThisWorkbook.Sheets("DATA")
Application.ScreenUpdating = False
Application.EnableEvents = False

'Define ColumnFromStr and ColumnToStr
Dim ColumnFromStr As String
Dim ColumnToStr As String
Call TBF02_DefineColumnFromToStr(WS, ColumnFromStr, ColumnToStr)


Dim ListLoaiTru(0 To 1) As String
ListLoaiTru(0) = "Group"
ListLoaiTru(1) = "Calculation"


'Xac dinh vi tri con tro chuot
Dim ActiveCellRow As Integer
ActiveCellRow = ActiveCell.Row

'Kiem tra dieu kien de Move
Dim CantMove As Boolean
'Kiem tra xem con tro nam trong vung chon hay khong
Call TBF06_OChonNamTrongVungDuLieu(WS, CantMove)

'Kiem tra gia tri o dau tien
Call TBF03_CheckGiaTriODauTien(WS, ActiveCellRow, CantMove, ListLoaiTru)

'Luu du lieu Project hien tai
Dim ProjectRange As Range
Call TBF04_DefineProjectRange(WS, ProjectRange, ColumnFromStr, ColumnToStr, ActiveCellRow, CantMove)

'Check ProjectUpDown co trung Group va Calculation k
Call TBF05_DefineUpDowRange(CantMove, WS, UpDownMode, ActiveCellRow, ListLoaiTru)

If CantMove = True Then
MsgBox "Please Select Other Cells"
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
End If
'Luu du lieu Project Up or Down

'Move Up or Down
Select Case UpDownMode
Case "Up"
Call TBF07_MoveProjectUp(ProjectRange)
Case "Down"
Call TBF08_MoveProjectDown(ProjectRange)
End Select
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

Function TBF01_CheckProjectUpDown(WS As Worksheet, UpdownRowBegin As Integer, UpDownRowEnd As Integer, ListLoaiTru As Variant) As Boolean
Dim CheckStr As String
Dim CellValue As String
Dim i As Integer

For i = UpdownRowBegin To UpDownRowEnd
CellValue = WS.Cells(i, 1).Value
CheckStr = CheckStr & CellValue
Next
Dim IsInList As Boolean
IsInList = HCF4077_InStrWithList(ListLoaiTru, CheckStr, vbTextCompare)
TBF01_CheckProjectUpDown = IsInList

End Function

Function HCF4077_InStrWithList(ListText As Variant, SearchInText As String, InStrMode As VbCompareMethod) As Boolean

Dim SearchText As String
Dim i As Integer
For i = LBound(ListText) To UBound(ListText)
SearchText = ListText(i)
If InStr(1, SearchInText, SearchText, InStrMode) <> 0 Then
HCF4077_InStrWithList = True
Exit Function
End If
Next

End Function
Function HCF4079_DefineRowEndNo(WS As Worksheet, EndRow As Integer, ColumnNo As Integer)
EndRow = WS.Cells(Rows.Count, ColumnNo).End(xlUp).Row
End Function
Function HCF4080_DefineColumnEndNo(WS As Worksheet, EndColumn As Integer, RowNo As Integer)
EndColumn = WS.Cells(RowNo, Columns.Count).End(xlToLeft).Column
End Function
Function HCF4081_ConvertColumnNumberToLetter(iCol As Integer) As String
'Function chuyen doi ma so cot tu dang so sang dang chu
Dim aSplit As Variant
Dim convertNumberToLetter As String
aSplit = Split(Cells(1, iCol).Address, "$")
convertNumberToLetter = aSplit(1)
HCF4081_ConvertColumnNumberToLetter = convertNumberToLetter
End Function
Sub TBS02_MoveUp()
Call TBS01_MoveProjectUpDown("Up")
End Sub

Sub TBS03_MoveDown()
Call TBS01_MoveProjectUpDown("Down")
End Sub

 

Message 12 of 15
buianhtuan.cdt
in reply to: leife

Sub TBS04_DeleteProject()

'Setting
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim WS As Worksheet
Dim ActiveCellRow As Integer
Dim CantMove As Boolean
Dim ProjectRange As Range

Call TBF12_CheckDieuKien(WS, ActiveCellRow, ProjectRange, CantMove)
If CantMove = True Then
MsgBox "Please Select Other Cells"
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
End If

'Save Row width
Dim SaveRowHeightArr As Variant
Call TBF10_CreatSaveRowHeightArr(WS, SaveRowHeightArr, ActiveCellRow)

'Delete Range
Call TBF09_DeleteRange(ProjectRange)

'Restore Row width
Call TBF11_RestoreRowHeightArr(WS, SaveRowHeightArr, ActiveCellRow)


Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub
Sub TBS05_AddEmptyProject()

'Setting
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim WS As Worksheet
Dim ActiveCellRow As Integer
Dim CantMove As Boolean
Dim ProjectRange As Range

Call TBF12_CheckDieuKien(WS, ActiveCellRow, ProjectRange, CantMove)
If CantMove = True Then
MsgBox "Please Select Other Cells"
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
End If

'Save Row Height From BeginProject To EndRow
Dim RowHeightFromBeginProjectToEndRowArr As Variant
Call TBF13_RowHeightFromBeginProjectToEndRowArr(WS, RowHeightFromBeginProjectToEndRowArr, ActiveCellRow)

'Insert NewProject
Dim NewProject As Range
Call TBF14_AddEmptyProject(ProjectRange, NewProject)

'Restore Row Height
Call TBF15_AddEmpty_RestoreRowHeightArr(WS, RowHeightFromBeginProjectToEndRowArr, ActiveCellRow)

'Clear Contents and Color
NewProject.ClearContents

'Fill Color
Call TBF16_FillColor_NewProject(WS, NewProject)

Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub
Sub TBS06_GetOldInformation()

Application.ScreenUpdating = False
Application.EnableEvents = False
'Setting
Dim ColumnFrom As Integer: ColumnFrom = 2
Dim ColumnTo As Integer: ColumnTo = 37
Dim OldInformation() As Variant
Dim Information1 As String
Dim Information2 As String
Dim Information3 As String
Dim Information4 As String
Dim DayFrom As String
Dim DayTo As String
Dim ColorIndex As Integer
Dim Comment As String
Dim BiKouRan As String

'Check Condition
Dim WS As Worksheet
Dim ActiveCellRow As Integer
Dim CantMove As Boolean
Dim ProjectRange As Range
Call TBF12_CheckDieuKien(WS, ActiveCellRow, ProjectRange, CantMove)
If CantMove = True Then
MsgBox "Please Select Other Cells"
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
End If
'Get Information
Information1 = WS.Cells(ActiveCellRow, ColumnFrom).Value
Information2 = WS.Cells(ActiveCellRow, ColumnFrom + 1).Value
Information3 = WS.Cells(ActiveCellRow, ColumnFrom + 2).Value
Information4 = WS.Cells(ActiveCellRow, ColumnFrom + 3).Value
BiKouRan = WS.Cells(ActiveCellRow, ColumnTo).Value
'Get DayFrom, DayTo, ColorIndex
Call TBF17_DefineDayFrom_DayTo_ColorIndex(WS, DayFrom, DayTo, ColorIndex, ProjectRange, ActiveCellRow, Comment)

Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub


Function TBF09_DeleteRange(ProjectRange As Range)

ProjectRange.Copy
Dim FirstCell As Range
Dim AfterPosition As Range
Set FirstCell = ProjectRange.Cells(1, 1)
Set AfterPosition = FirstCell.Offset(-2, 0)
ProjectRange.Delete Shift:=xlUp
AfterPosition.Select

End Function
Function TBF10_CreatSaveRowHeightArr(WS As Worksheet, SaveRowHeightArr As Variant, ActiveCellRow As Integer)

Dim EndRow As Integer
Call HCF4079_DefineRowEndNo(WS, EndRow, 2)
EndRow = EndRow + 3
Dim FromRow As Integer
FromRow = ActiveCellRow + 2
If FromRow > EndRow Then Exit Function
ReDim SaveRowHeightArr(0 To EndRow - FromRow)
For i = FromRow To EndRow
SaveRowHeightArr(i - FromRow) = WS.Rows(i).RowHeight
Next

End Function

Function TBF11_RestoreRowHeightArr(WS As Worksheet, SaveRowHeightArr As Variant, ActiveCellRow As Integer)

Dim EndRow As Integer
Call HCF4079_DefineRowEndNo(WS, EndRow, 2)
EndRow = EndRow + 3
Dim FromRow As Integer
FromRow = ActiveCellRow - 1

For i = FromRow To EndRow
WS.Rows(i).RowHeight = SaveRowHeightArr(i - FromRow)
Next

End Function

Function TBF12_CheckDieuKien(WS As Worksheet, ActiveCellRow As Integer, ProjectRange As Range, CantMove As Boolean)

Set WS = ThisWorkbook.Sheets("DATA")


'Define ColumnFromStr and ColumnToStr
Dim ColumnFromStr As String
Dim ColumnToStr As String
Call TBF02_DefineColumnFromToStr(WS, ColumnFromStr, ColumnToStr)


Dim ListLoaiTru(0 To 1) As String
ListLoaiTru(0) = "Group"
ListLoaiTru(1) = "Calculation"

'Xac dinh vi tri con tro chuot
ActiveCellRow = ActiveCell.Row

'Kiem tra xem con tro nam trong vung chon hay khong
Call TBF06_OChonNamTrongVungDuLieu(WS, CantMove)

'Kiem tra gia tri o dau tien
Call TBF03_CheckGiaTriODauTien(WS, ActiveCellRow, CantMove, ListLoaiTru)

'Luu du lieu Project hien tai
Call TBF04_DefineProjectRange(WS, ProjectRange, ColumnFromStr, ColumnToStr, ActiveCellRow, CantMove)

If CantMove = True Then
Exit Function
End If

End Function
Function TBF13_RowHeightFromBeginProjectToEndRowArr(WS As Worksheet, RowHeightFromBeginProjectToEndRowArr As Variant, ActiveCellRow As Integer)

Dim EndRow As Integer
Call HCF4079_DefineRowEndNo(WS, EndRow, 2)
Dim FromRow As Integer
FromRow = ActiveCellRow - 1
If FromRow > EndRow Then Exit Function
ReDim RowHeightFromBeginProjectToEndRowArr(0 To EndRow - FromRow)
For i = FromRow To EndRow
RowHeightFromBeginProjectToEndRowArr(i - FromRow) = WS.Rows(i).RowHeight
Next

End Function
Function TBF15_AddEmpty_RestoreRowHeightArr(WS As Worksheet, SaveRowHeightArr As Variant, ActiveCellRow As Integer)

Dim EndRow As Integer
Call HCF4079_DefineRowEndNo(WS, EndRow, 2)
Dim FromRow As Integer
FromRow = ActiveCellRow + 2

For i = FromRow To EndRow
WS.Rows(i).RowHeight = SaveRowHeightArr(i - FromRow)
Next

End Function

Function TBF16_FillColor_NewProject(WS As Worksheet, NewProject As Range)
'Setting
Dim ColorRefRow As Integer: ColorRefRow = 2

'Define RowNo,ColumnNo
Dim BeginCell As Range
Dim EndCell As Range
Dim ColumnFromNo As Integer
Dim ColumnToNo As Integer
Dim RowFromNo As Integer
Dim RowToNo As Integer
Set BeginCell = NewProject.Cells(1, 1)
Set EndCell = NewProject.Cells(NewProject.Rows.Count, NewProject.Columns.Count)
RowFromNo = BeginCell.Row
RowToNo = EndCell.Row
ColumnFromNo = BeginCell.Column
ColumnToNo = EndCell.Column
'Match Color
Dim FillRange As Range
Dim RefColorIndex As Integer
Dim RefColorRange As Range
For i = ColumnFromNo To ColumnToNo
Set RefColorRange = WS.Cells(ColorRefRow, i)
RefColorIndex = RefColorRange.Interior.ColorIndex
Set BeginCell = WS.Cells(RowFromNo, i)
Set FillRange = BeginCell.Resize(3, 1)
FillRange.Interior.ColorIndex = RefColorIndex
Next
End Function
Function TBF17_DefineDayFrom_DayTo_ColorIndex(WS As Worksheet, DayFrom As String, DayTo As String, ColorIndex As Integer, ProjectRange As Range, ActiveCellRow As Integer, Comment As String)
'Setting
Dim ColorRefRow As Integer: ColorRefRow = 1

'Define RowNo,ColumnNo
Dim BeginCell As Range
Dim EndCell As Range
Dim ColumnFromNo As Integer
Dim ColumnToNo As Integer
Set BeginCell = ProjectRange.Cells(1, 1)
Set EndCell = ProjectRange.Cells(ProjectRange.Rows.Count, ProjectRange.Columns.Count)
ColumnFromNo = BeginCell.Column
ColumnToNo = EndCell.Column
'Define ColorInder,Comment,DayFrom
Dim CheckColor As Variant
Dim i As Integer
For i = ColumnFromNo + 4 To ColumnToNo - 1
CheckColor = TBF18_CheckSatSunDayOffColorIndex(WS, ActiveCellRow, i)
If VarType(CheckColor) = vbInteger Then
ColorIndex = CheckColor
Comment = WS.Cells(ActiveCellRow, i).Value
DayFrom = WS.Cells(ColorRefRow, i).Value2
GoTo ExitFor
End If
Next
ExitFor:

'Define DayTo
For i = ColumnToNo - 1 To ColumnFromNo + 4 Step -1
CheckColor = TBF18_CheckSatSunDayOffColorIndex(WS, ActiveCellRow, i)
If VarType(CheckColor) = vbInteger Then
DayTo = WS.Cells(ColorRefRow, i).Value
GoTo ExitFor2
End If
Next
ExitFor2:

End Function
Function TBF18_CheckSatSunDayOffColorIndex(WS As Worksheet, RowNo As Integer, ColumnNo As Integer) As Variant
Dim Color As Variant
Dim SatColorIndex As Integer: SatColorIndex = 6 'yellow
Dim SunColorIndex As Integer: SunColorIndex = 3 'red
Dim DayOffColorIndex As Integer: DayOffColorIndex = 7 'Magenta
Dim CheckRange As Range
Dim CheckColorIndex As Integer
Dim Result As Variant

Set CheckRange = WS.Cells(RowNo, ColumnNo)
CheckColorIndex = CheckRange.Interior.ColorIndex
Select Case CheckColorIndex
Case 0
Result = False
Case -4142
Result = False
Case SatColorIndex
Result = False
Case SunColorIndex
Result = False
Case DayOffColorIndex
Result = False
Case Else
Result = CheckColorIndex
End Select
TBF18_CheckSatSunDayOffColorIndex = Result
End Function

Function TBF14_AddEmptyProject(ProjectRange As Range, NewProject As Range)

ProjectRange.Copy
Dim InsertPosition As Range
Dim FirstCell As Range
Dim AfterPosition As Range
Set FirstCell = ProjectRange.Cells(1, 1)
Set InsertPosition = FirstCell.Offset(3, 0)
InsertPosition.Select
Selection.Insert Shift:=xlDown
Set AfterPosition = FirstCell.Offset(4, 0)
AfterPosition.Select
Application.CutCopyMode = False
Set NewProject = ProjectRange.Offset(3, 0)
End Function

Message 13 of 15
buianhtuan.cdt
in reply to: leife

;(TB VBABoss)Convertmm2Inch, [MM2I]
(defun C:MM2I()
(command "-vbarun" "HCS3098_Convertmm2Inch")
)
;(TB VBABoss)Change Entity in block to byBlock, [TC2BB]
(defun C:TC2BB()
(command "-vbarun" "HCS3096_Change2ByBlock_Tuan")
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Function HCF4073_ChangeBlock2ByBlockByLayerRenameBlock(ByLayerOrByBlock As String)

'1: Change ByLayer or Byblock
' Change to Bylayer: Linetype=Bylayer, Lineweight=bylayer,linetypescale=1,color=bylayer, normallayer in block to layer0
' Change to ByBlock: Linetype=Bylayer, Lineweight=bylayer,linetypescale=1,color=byblock, normallayer in block to layer0

'Setting
Dim ObjColor As AcColor
Dim BlockRefColor As AcColor
Select Case ByLayerOrByBlock
Case "ByLayer"
ObjColor = acByLayer
BlockRefColor = acByLayer
Case "ByBlock"
ObjColor = acByBlock
BlockRefColor = acMagenta
End Select
Dim ObjLayerName As String
Select Case ProjectName
Case "DFK"
ObjLayerName = DFK_NormalLayerName
Case "KKS"
ObjLayerName = NormalLayerName
End Select

'Select Block Reference by SelectSet
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) = "INSERT"
objSelectOnScreen.SelectOnScreen
If objSelectOnScreen.Count = 0 Then
MsgBox "No Selected Entity"
objSelectOnScreen.Delete
Exit Function
End If

'Change ByLayerOrByBlock of EachEntity of SelectSet
'Process when ByLayerOrByBlock <>""
Dim EachEntity As AcadEntity
Dim EachBlockReference As AcadBlockReference
For Each EachEntity In objSelectOnScreen
EachEntity.Layer = ObjLayerName
Call Func33SetLinetypeByLayer(EachEntity)
Call Func34SetLineweightByLayer(EachEntity)
Call Func35SetLinetypeScale(EachEntity)
EachEntity.Color = BlockRefColor
Next

'Creat MotherBlock and SonBlock of SelectSet
Dim MotherSonBlockArr() As Variant
MotherSonBlockArr = Func5000_CreatBlockArrFromSelectSet(objSelectOnScreen)

'Change NormalLayer to 0,Lineweight=bylayer,linetypescale=1
Dim EachBlock As AcadBlock
For i = LBound(MotherSonBlockArr) To UBound(MotherSonBlockArr)
Set EachBlock = MotherSonBlockArr(i)
For Each EachEntity In EachBlock
If EachEntity.Layer = ObjLayerName Then EachEntity.Layer = "0"
Call Func34SetLineweightByLayer(EachEntity)
Call Func35SetLinetypeScale(EachEntity)
Call Func33SetLinetypeByLayer(EachEntity)
EachEntity.Color = ObjColor
Next
Next
objSelectOnScreen.Delete
Thisdrawing.Regen (acActiveViewport)
End Function
Function HCF4074_Inputbox(StrTitle As String, StrPrompt As String, DefautValue As Variant, InputBoxType As Integer) As Variant
'InputBox(prompt[,title][,default][,xpos][,ypos][,helpfile,context])

'InputBoxType = 0 'Ham so
'InputBoxType = 1 'Integer
'InputBoxType = 2 'String
'InputBoxType = 4 'Boolean
'InputBoxType = 8 'Range
'InputBoxType = 16 'loi #N/A
'InputBoxType = 64 'Mang day so

Dim VarResult As Variant
VarResult = Excel.Application.InputBox(StrPrompt, StrTitle, DefautValue, , , , , InputBoxType)

'when cancel
'If VarType(VarResult) = vbBoolean Then VarResult = StrDefautValue
HCF4074_Inputbox = VarResult

End Function
Function HCF4075_CreatCircleObjArrInSelectSet(SelectSet As AcadSelectionSet, VisibleMode As Boolean) As Variant

Dim CircleArr() As Variant
Dim k As Integer
'Check Input
If SelectSet.Count = 0 Then Exit Function
Dim EachEntity As AcadEntity
For Each EachEntity In SelectSet
If EachEntity.ObjectName = "AcDbCircle" Then
ReDim Preserve CircleArr(0 To k)
Set CircleArr(k) = EachEntity
EachEntity.Visible = VisibleMode
k = k + 1
End If
Next
If k = 0 Then
HCF4075_CreatCircleObjArrInSelectSet = False
Else
HCF4075_CreatCircleObjArrInSelectSet = CircleArr
End If

End Function

Function HCF4076X_HCS3095_02_GetHozaiFromHozaiTo() As Variant
Dim Result(0 To 1) As Integer
Dim HozaiNoFrom As Integer
Dim HozaiNoTo As Integer
Dim GetInteger As Variant
GetInteger = HCF4061_GetInteger(Thisdrawing, "Hozai No From:")
If VarType(GetInteger) = vbBoolean Then
HCF4076X_HCS3095_02_GetHozaiFromHozaiTo = False
Exit Function
Else
HozaiNoFrom = GetInteger
End If
GetInteger = HCF4061_GetInteger(Thisdrawing, "Hozai No To:")
If VarType(GetInteger) = vbBoolean Then
HCF4076X_HCS3095_02_GetHozaiFromHozaiTo = False
Exit Function
Else
HozaiNoTo = GetInteger
End If
Call HCF4062_DefineSmallerLarger(HozaiNoFrom, HozaiNoTo)
Result(0) = HozaiNoFrom
Result(1) = HozaiNoTo
HCF4076X_HCS3095_02_GetHozaiFromHozaiTo = Result
End Function

Function HCF4076X_HCS3095_03_CreatResult(SelectOnScreen As AcadSelectionSet, CenterPointArr As Variant, R As Double, QtyTextComment As Variant, Uqty As Variant, HozaiNoFrom As Integer, HozaiNoTo As Integer) As Variant

Dim CenterPoint As Variant
Dim CenterPointX As Double
Dim EachEntity As AcadEntity
Dim Distance As Double
Dim EachTextPoint As Variant
Dim TextValue As Variant
Dim EachMsg As String
Dim BallType As String
Dim Result() As Variant

ReDim Result(0 To UBound(CenterPointArr), 0 To 3)
For i = LBound(CenterPointArr) To UBound(CenterPointArr)
CenterPoint = CenterPointArr(i)
CenterPointX = CenterPoint(0)
For Each EachEntity In SelectOnScreen
If EachEntity.Visible = True Then
EachTextPoint = Func19ObjectCenterPoint(EachEntity)
TextValue = EachEntity.TextString
TextValue = HCF4076X_HCS3095_04_ConvertText2Number(TextValue, QtyTextComment)
If EachTextPoint(0) > CenterPointX - R And EachTextPoint(0) < CenterPointX + R Then
Distance = Func20LengthLineThrough2Point(CenterPoint, EachTextPoint)
If Distance < R Then
Result(i, 0) = TextValue
Else
Result(i, 1) = TextValue
End If
EachEntity.Visible = False
End If
End If
Next
Next
'Define Result(BallNo,BallQty,UQty,Msg)
Dim BallNo As Variant
Dim BallQty As Variant
For i = LBound(Result) To UBound(Result)
'Define BallNo
BallNo = Result(i, 0)
BallQty = Result(i, 1)
If VarType(BallNo) = vbEmpty Then
HCF4076X_HCS3095_03_CreatResult = False
Call HCF4078_VisibleObjInSelectSet(SelectOnScreen, True)
Exit Function
Else
If VarType(BallQty) = vbEmpty Then
BallQty = 1
End If
End If
'Define EachMsg
Select Case Uqty
Case 1
EachMsg = BallQty & "-" & "(" & BallNo & ")"
Case Else
Select Case BallQty
Case 1
EachMsg = Uqty & "x" & "(" & BallNo & ")"
Case Else
EachMsg = Uqty & "x" & BallQty & "-" & "(" & BallNo & ")"
End Select
End Select
'Define BallType
BallType = HCF4076X_HCS3095_08_BallType(BallNo, HozaiNoFrom, HozaiNoTo)
Result(i, 1) = BallQty
Result(i, 2) = EachMsg
Result(i, 3) = BallType
Next
HCF4076X_HCS3095_03_CreatResult = Result

End Function
Function HCF4076X_HCS3095_04_ConvertText2Number(TextValue As Variant, QtyTextComment As Variant) As Variant
Dim Result As Variant
Result = LCase(TextValue)
Result = Trim(Result)
Result = HCF4065_SubstituteTextWithArr(Result, QtyTextComment)
Result = HCF4067_ConvertNumberTiengNhat(Result)
Result = CInt(Result)
HCF4076X_HCS3095_04_ConvertText2Number = Result
End Function
Function HCF4076X_HCS3095_05_CreatCenterPointArr(SelectOnScreen As AcadSelectionSet) As Variant

Dim CircleArr As Variant
Dim Result As Variant
CircleArr = HCF4075_CreatCircleObjArrInSelectSet(SelectOnScreen, False)
If VarType(CircleArr) = vbBoolean Then
Call HCF4078_VisibleObjInSelectSet(SelectOnScreen, True)
HCF4076X_HCS3095_05_CreatCenterPointArr = False
Exit Function
End If
Result = HCF4064_CreatCenterPointArrFromCircleArr(CircleArr)
HCF4076X_HCS3095_05_CreatCenterPointArr = Result

End Function
Function HCF4076X_HCS3095_07_DefineR(SelectOnScreen As AcadSelectionSet) As Double

Dim EachEntity As AcadEntity
Dim EachCircle As AcadCircle
Dim R As Double
For Each EachEntity In SelectOnScreen
If EachEntity.ObjectName = "AcDbCircle" Then
Set EachCircle = EachEntity
HCF4076X_HCS3095_07_DefineR = EachCircle.radius
Exit Function
End If
Next

End Function
Function HCF4076X_HCS3095_08_BallType(BallNo As Variant, HozaiNoFrom As Integer, HozaiNoTo As Integer) As String

Dim Result As String
If BallNo >= HozaiNoFrom And BallNo <= HozaiNoTo Then
Result = "Hozai"
Else
Result = "Part"
End If
HCF4076X_HCS3095_08_BallType = Result
End Function

Function HCF4076X_HCS3095_09_ShowEachResult(SelectSet As AcadSelectionSet, BallNoQtyArr As Variant, TotalObjVisible As Variant, Uqty As Variant) As Boolean

Dim Result As Boolean
Dim EachMsg As String
Dim Msg As String
For i = LBound(BallNoQtyArr) To UBound(BallNoQtyArr)
EachMsg = BallNoQtyArr(i, 2)
If i = 0 Then
Msg = EachMsg
Else
Msg = Msg & vbNewLine & EachMsg
End If
Next
'Show SelectSet
Call HCF4078_VisibleObjInSelectSet(SelectSet, True)
'MsgBox
Dim response As VbMsgBoxResult
Msg = Msg & vbNewLine & _
"Yes(Write Data) No(Dont write data) Cancel(Edit group qty)"
response = MsgBox(Msg, vbYesNoCancel)
Select Case response
Case vbYes
Call HCF4076X_HCS3095_10_GhiSelectSetVaoTotalObjVisible(TotalObjVisible, SelectSet)
Call HCF4078_VisibleObjInSelectSet(SelectSet, False)
Result = True
Case vbNo
Result = False
Case vbCancel
Dim InputBoxValue As Variant
InputBoxValue = HCF4074_Inputbox("Group Qty", "Check Qty of Group", Uqty, 1)
If VarType(InputBoxValue) <> vbBoolean Then
Uqty = InputBoxValue
Call HCF4078_VisibleObjInSelectSet(SelectSet, False)
Result = True
Else
Result = False
End If
End Select
HCF4076X_HCS3095_09_ShowEachResult = Result
End Function
Function HCF4076X_HCS3095_10_GhiSelectSetVaoTotalObjVisible(TotalObjVisible As Variant, SelectSet As AcadSelectionSet)
'Check Input
Dim k As Integer
Dim EachEntity As AcadEntity
If Func70IsEmptyArray(TotalObjVisible) = True Then
For Each EachEntity In SelectSet
ReDim Preserve TotalObjVisible(0 To k)
Set TotalObjVisible(k) = EachEntity
k = k + 1
Next
Else
k = UBound(TotalObjVisible) + 1
For Each EachEntity In SelectSet
ReDim Preserve TotalObjVisible(0 To k)
Set TotalObjVisible(k) = EachEntity
k = k + 1
Next
End If
End Function
Function HCF4076X_HCS3095_11_ProcessWhenErr(HaveErr As Boolean, WriteToResult As Boolean, TotalObjVisible As Variant, SelectSet As AcadSelectionSet) As Boolean
If HaveErr = False Then
HCF4076X_HCS3095_11_ProcessWhenErr = True
Exit Function
End If
MsgBox "Check Balloon Number"
Dim response As VbMsgBoxResult
Dim Result As Boolean
response = MsgBox("Continue or Reset?" & vbNewLine & "Yes (Continue)" & vbNewLine & "No (Reset)", vbYesNo)
Select Case response
Case vbYes
WriteToResult = False
Call HCF4078_VisibleObjInSelectSet(SelectSet, True)
Result = True
Case vbNo
Result = False
Call HCF4078_VisibleObjInSelectSet(SelectSet, True)
Call HCF4069_VisibleObjArr1Chieu(TotalObjVisible, True)
SelectSet.Delete
End Select
HCF4076X_HCS3095_11_ProcessWhenErr = Result
End Function

Function HCF4076X_HCS3095_12_DefineMainPart(BallNoQtyArr As Variant)
Dim BallNo As Integer
Dim BallType As String
Dim MainBallNo As Integer
For i = LBound(BallNoQtyArr) To UBound(BallNoQtyArr)
BallNo = BallNoQtyArr(i, 1)
BallType = BallNoQtyArr(i, 3)
If BallType = "Part" Then
If MainBallNo = 0 Then
MainBallNo = BallNo
Else
If BallNo <= MainBallNo Then MainBallNo = BallNo
End If
End If
Next
For i = LBound(BallNoQtyArr) To UBound(BallNoQtyArr)
BallNo = BallNoQtyArr(i, 1)
If BallNo = MainBallNo Then
BallNoQtyArr(i, 3) = "MainPart"
Exit Function
End If
Next
End Function
Function HCF4076X_HCS3095_13_CreatResultArr(BallNoQtyArr As Variant, Uqty As Variant, HozaiNoFrom As Integer, HozaiNoTo As Integer, ResultArr As Variant)
Dim BallNo As Variant
Dim BallQty As Variant
Dim BallType As String
'Define BallQty
For i = LBound(BallNoQtyArr) To UBound(BallNoQtyArr)
BallQty = BallNoQtyArr(i, 1)
BallType = BallNoQtyArr(i, 3)
Select Case BallType
Case "MainPart"
BallQty = Uqty * BallQty
Case "Part"
BallQty = Uqty * BallQty
Case "Hozai"
End Select
BallNoQtyArr(i, 1) = BallQty
Next
'Creat ResultArr
Dim EachResult() As Variant
Dim k As Integer

'Write EachResult MainPart
ReDim EachResult(0 To HozaiNoTo - HozaiNoFrom + 2)
For i = LBound(BallNoQtyArr) To UBound(BallNoQtyArr)
BallNo = BallNoQtyArr(i, 0)
BallQty = BallNoQtyArr(i, 1)
BallType = BallNoQtyArr(i, 3)
Select Case BallType
Case "MainPart"
EachResult(0) = BallNo
EachResult(1) = BallQty
Case "Part"
Case "Hozai"
k = BallNo - HozaiNoFrom + 2
EachResult(k) = BallQty
End Select
Next
If VarType(ResultArr) = vbEmpty Then
ReDim ResultArr(0)
ResultArr(0) = EachResult
Else
ReDim Preserve ResultArr(0 To UBound(ResultArr) + 1)
ResultArr(UBound(ResultArr)) = EachResult
End If

'Write EachResult Part
For i = LBound(BallNoQtyArr) To UBound(BallNoQtyArr)
ReDim EachResult(0 To HozaiNoTo - HozaiNoFrom + 2)
BallNo = BallNoQtyArr(i, 0)
BallQty = BallNoQtyArr(i, 1)
BallType = BallNoQtyArr(i, 3)
Select Case BallType
Case "MainPart"
Case "Part"
EachResult(0) = BallNo
EachResult(1) = BallQty
ReDim Preserve ResultArr(0 To UBound(ResultArr) + 1)
ResultArr(UBound(ResultArr)) = EachResult
Case "Hozai"
End Select
Next
End Function

Function HCF4076X_HCS3095_14_SortResultArrAtoZ(ResultArr As Variant)
' Sap xep cac phan tu cua mang theo thu tu tu A den Z

Dim SmallValue As Double
Dim LargeValue As Double
Dim EachResult As Variant
Dim TmpEachResult As Variant

If UBound(ResultArr) = 0 Then Exit Function

For i = LBound(ResultArr) To UBound(ResultArr)
For k = i + 1 To UBound(ResultArr)
EachResult = ResultArr(i)
SmallValue = EachResult(0)
TmpEachResult = ResultArr(k)
LargeValue = TmpEachResult(0)
If SmallValue > LargeValue Then
ResultArr(i) = TmpEachResult
ResultArr(k) = EachResult
End If
Next
Next

End Function
Function HCF4076X_HCS3095_15_WriteTitle2Excel(WS As Worksheet, HozaiNoFrom As Integer, HozaiNoTo As Integer)
' Sap xep cac phan tu cua mang theo thu tu tu A den Z

WS.Cells(1, 1).Value = "Part No"
WS.Cells(1, 2).Value = "Qty"
For i = HozaiNoFrom To HozaiNoTo
WS.Cells(1, i - HozaiNoFrom + 3).Value = i
Next

End Function
Function HCF4076X_HCS3095_16_WriteData2Excel(WS As Worksheet, ResultArr As Variant)
' Sap xep cac phan tu cua mang theo thu tu tu A den Z

Dim EachResult As Variant
Dim RowNo As Integer: RowNo = 2
Dim Value As Variant
For i = LBound(ResultArr) To UBound(ResultArr)
EachResult = ResultArr(i)
For k = LBound(EachResult) To UBound(EachResult)
Value = EachResult(k)
WS.Cells(RowNo, k + 1).Value = Value
Next
RowNo = RowNo + 1
Next

End Function
Function HCF4076X_HCS3095_17_WriteFormular2Excel(WS As Worksheet)
' Sap xep cac phan tu cua mang theo thu tu tu A den Z

Dim EndRow As Integer
Dim EndColumn As Integer
Dim EndColumnLetter As String
Dim FormularRowNo As Integer
Call HCF4079_DefineRowEndNo(WS, EndRow, 1)
Call HCF4080_DefineColumnEndNo(WS, EndColumn, 1)
FormularRowNo = EndRow + 2
EndColumnLetter = HCF4081_ConvertColumnNumberToLetter(EndColumn)

'Define Formular {=SUM($B$2:$B$4*C2:C4)}
Dim Formular As String
Dim FormularRange As String
Formular = "=SUM($B$2:$B$" & EndRow & "*C2:C" & EndRow & ")"
FormularRange = "C" & FormularRowNo & ":" & EndColumnLetter & FormularRowNo
WS.Range("B" & FormularRowNo).Value = "Sum"
WS.Range("C" & FormularRowNo).FormulaArray = Formular
WS.Range(FormularRange).FillRight

End Function
Function HCF4076X_HCS3095_01_DefineUQty(SelectSet As AcadSelectionSet, UQtyTextComment As Variant, VisibleMode As Boolean) As Variant
Dim EachEntity As AcadEntity
Dim EachText As AcadEntity
Dim EachTextString As String
Dim SearchStr As String
Dim Uqty As Variant
Dim IsInStr As Boolean
Dim UQtyObj As AcadEntity
For Each EachEntity In SelectSet
If EachEntity.Visible = True Then
If EachEntity.ObjectName = "AcDbText" Or EachEntity.ObjectName = "AcDbMText" Then
Set EachText = EachEntity
EachTextString = EachEntity.TextString
EachTextString = LCase(EachTextString)
EachTextString = Trim(EachTextString)
IsInStr = HCF4077_InStrWithList(UQtyTextComment, EachTextString, vbTextCompare)
If IsInStr = True Then
Set UQtyObj = EachEntity
Uqty = EachTextString
GoTo ExitFor
End If
End If
End If
Next
ExitFor:
'Define UQty
If IsInStr = False Then
Uqty = 1
Else
Uqty = HCF4065_SubstituteTextWithArr(Uqty, UQtyTextComment)
Uqty = HCF4067_ConvertNumberTiengNhat(Uqty)
Uqty = CInt(Uqty)
End If
If Not UQtyObj Is Nothing Then UQtyObj.Visible = VisibleMode
HCF4076X_HCS3095_01_DefineUQty = Uqty

End Function

 

Function HCF4077_InStrWithList(ListText As Variant, SearchInText As String, InStrMode As VbCompareMethod) As Boolean

Dim SearchText As String
For i = LBound(ListText) To UBound(ListText)
SearchText = ListText(i)
If InStr(1, SearchInText, SearchText, InStrMode) <> 0 Then
HCF4077_InStrWithList = True
Exit Function
End If
Next

End Function

Function HCF4078_VisibleObjInSelectSet(SelectSet As AcadSelectionSet, VisibleMode As Boolean)
If SelectSet.Count = 0 Then Exit Function
Dim EachEntity As AcadEntity
For Each EachEntity In SelectSet
EachEntity.Visible = VisibleMode
Next
End Function

Function HCF4079_DefineRowEndNo(WS As Worksheet, EndRow As Integer, ColumnNo As Integer)
EndRow = WS.Cells(Rows.Count, ColumnNo).End(xlUp).Row
End Function
Function HCF4080_DefineColumnEndNo(WS As Worksheet, EndColumn As Integer, RowNo As Integer)
EndColumn = WS.Cells(RowNo, Columns.Count).End(xlToLeft).Column
End Function
Function HCF4081_ConvertColumnNumberToLetter(iCol As Integer) As String
'Function chuyen doi ma so cot tu dang so sang dang chu
Dim aSplit As Variant
Dim convertNumberToLetter As String
aSplit = Split(Cells(1, iCol).Address, "$")
convertNumberToLetter = aSplit(1)
HCF4081_ConvertColumnNumberToLetter = convertNumberToLetter
End Function
Function HCF4082X_HCS3098_01_InputData(InputData As Variant)
'Function Creat List of Block in drawing with BlockName

'Select All BlockReference in drawing
Dim objSelectAll As AcadSelectionSet
Set objSelectAll = Thisdrawing.SelectionSets.Add("objSelectAll" & Now)
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 0: FD(0) = "INSERT"
objSelectAll.Select acSelectionSetAll, , , FT, FD
If objSelectAll.Count = 0 Then
objSelectAll.Delete
Exit Function
End If
ReDim InputData(0 To objSelectAll.Count - 1, 0 To 3)

Dim EachBlockRef As AcadBlockReference
Dim BlockScale As Double


Dim BlockType As String
Dim BlockNo As String
Dim PartListNo As String
Dim MateListNo As String
Dim CheckWrite As Boolean
Dim RowWrite As Integer

For Each EachBlockRef In objSelectAll
BlockScale = HCF4082X_HCS3098_02_BlockScale(EachBlockRef)
BlockHandle = EachBlockRef.Handle
Select Case EachBlockRef.EffectiveName
Case ListBlockName
PartListNo = HCF4051_GetAttValueOfBlockRef(EachBlockRef, PartNumberTagName)
MateListNo = HCF4051_GetAttValueOfBlockRef(EachBlockRef, MateNumberTagName)
If PartListNo <> "" Then
BlockType = "PartList"
BlockNo = PartListNo
CheckWrite = True
End If
If MateListNo <> "" Then
BlockType = "MateList"
BlockNo = MateListNo
CheckWrite = True
End If
Case PartBalloonName
BlockType = "PartBalloon"
BlockNo = HCF4051_GetAttValueOfBlockRef(EachBlockRef, BalloonNoTagName)
If BlockNo <> "" Then
CheckWrite = True
Else
CheckWrite = False
End If
Case MateBalloonName
BlockType = "MateBalloon"
BlockNo = HCF4051_GetAttValueOfBlockRef(EachBlockRef, BalloonNoTagName)
If BlockNo <> "" Then
CheckWrite = True
Else
CheckWrite = False
End If
Case Else
CheckWrite = False
End Select
If CheckWrite = True Then
InputData(RowWrite, 0) = BlockType
InputData(RowWrite, 1) = BlockNo
InputData(RowWrite, 2) = BlockScale
InputData(RowWrite, 3) = BlockHandle
RowWrite = RowWrite + 1
End If
Next
objSelectAll.Delete

End Function
Function HCF4083_DeleteEmptyInArr(Arr As Variant, CheckColumn As Integer) As Variant

If Func70IsEmptyArray(Arr) = True Then Exit Function
Dim TmpArr As Variant
Dim TmpValue As Variant
Dim RowNo As Integer
For i = LBound(Arr) To UBound(Arr)
TmpValue = Arr(i, CheckColumn)
If VarType(TmpValue) = vbEmpty Then RowNo = i - 1
Next
ReDim TmpArr(0 To RowNo, 0 To UBound(Arr, 2))
For i = LBound(Arr) To RowNo
For k = LBound(Arr, 2) To UBound(Arr, 2)
TmpArr(i, k) = Arr(i, k)
Next
Next
HCF4083_DeleteEmptyInArr = TmpArr

End Function

Function HCF4082X_HCS3098_02_BlockScale(ObjBlockRef As AcadBlockReference)

Dim BlockScale As Double
Dim BlockScaleX As Double
Dim BlockScaleY As Double
Dim BlockScaleZ As Double
BlockScaleX = Round(ObjBlockRef.XEffectiveScaleFactor, 1)
BlockScaleY = Round(ObjBlockRef.YEffectiveScaleFactor, 1)
BlockScaleZ = Round(ObjBlockRef.ZEffectiveScaleFactor, 1)
If BlockScaleZ < 0 Then
BlockScale = BlockScaleZ
Else
BlockScale = Abs(BlockScaleX)
End If
HCF4082X_HCS3098_02_BlockScale = BlockScale

End Function

Function HCF4084_Convertmm2Inch(mm As Double) As String

Dim InchThapPhan As Double: InchThapPhan = mm / 25.4
Dim InchPhanNguyen As Integer: InchPhanNguyen = Fix(InchThapPhan)
Dim InchPhanle As Double: InchPhanle = InchThapPhan - InchPhanNguyen
Dim PhanLe64 As String
PhanLe64 = WorksheetFunction.text(InchPhanle, "?/64")
Dim Truoc64 As Variant
Dim Sau64 As Variant
Truoc64 = Before_(PhanLe64, "/")
Sau64 = After_(PhanLe64, "/")
Dim TiepTuc As Variant
Do
Truoc64 = Truoc64 / 2
Sau64 = Sau64 / 2
TiepTuc = HCF4047_Convert2Integer(Truoc64)
Loop While VarType(TiepTuc) <> vbBoolean And Truoc64 <> 0
Truoc64 = Truoc64 * 2
Sau64 = Sau64 * 2

Dim ConvertResult As String
Dim Separator As String
Dim InchSign As String
Separator = " "
InchSign = ChrW(&H2033)
Select Case InchPhanNguyen
Case 0
Select Case Truoc64
Case 0
ConvertResult = 0 & InchSign
Case Else
ConvertResult = Truoc64 & "/" & Sau64 & InchSign
End Select
Case Else
Select Case Truoc64
Case 0
ConvertResult = InchPhanNguyen & InchSign
Case Else
ConvertResult = InchPhanNguyen & " " & Truoc64 & "/" & Sau64 & InchSign
End Select
End Select
HCF4084_Convertmm2Inch = ConvertResult

End Function
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Sub HCS3095_Johnan_BoltCalculation()
'(TB VBABoss) Johnan Bolt Calculation,[HOZAI]

'Total
Dim TotalResultArr() As Variant
Dim EachResult As String
Dim TotalNo As Integer
Dim WriteToResult As Boolean

'Setting UQtyTextComment
Dim UQtyTextComment(0 To 2) As String
UQtyTextComment(0) = "ƒ–Š"
UQtyTextComment(1) = "‰ÓŠ"
UQtyTextComment(2) = "ŒÂŠ"

'Setting Qty Text Comment
Dim QtyTextComment(0 To 3) As String
QtyTextComment(0) = " "
QtyTextComment(1) = "x"
QtyTextComment(3) = "~"

'Get Hozai From and Hozai To
Dim Var As Variant
Dim HozaiNoFrom As Integer
Dim HozaiNoTo As Integer
Var = HCF4076X_HCS3095_02_GetHozaiFromHozaiTo
If VarType(Var) = vbBoolean Then Exit Sub
HozaiNoFrom = Var(0)
HozaiNoTo = Var(1)

'SelectSet Circle,Text,MText
Dim SelectOnScreen As AcadSelectionSet
Set SelectOnScreen = Thisdrawing.SelectionSets.Add("SelectOnScreen" & Now)
Dim FT(4) As Integer
Dim FD(4) As Variant
Dim SSCount As Integer
FT(0) = -4: FD(0) = "<OR"
FT(1) = 0: FD(1) = "CIRCLE"
FT(2) = 0: FD(2) = "TEXT"
FT(3) = 0: FD(3) = "MTEXT"
FT(4) = -4: FD(4) = "OR>"

'Creat CenterPointArr
Dim ObjVisibleArr() As Variant
Dim CenterPointArr As Variant
Dim Uqty As Variant
Dim R As Double
Dim BallNoQtyArr As Variant
Dim HaveErr As Boolean
'MsgBox
Dim TotalObjVisible() As Variant
Dim ProcessWhenErr As Boolean

Do
'Reset value after loop
HaveErr = False
SelectOnScreen.Clear

SelectOnScreen.SelectOnScreen FT, FD
SSCount = SelectOnScreen.Count
If SSCount = 0 Then GoTo ExitLoop

'Creat CenterPointArr
CenterPointArr = HCF4076X_HCS3095_05_CreatCenterPointArr(SelectOnScreen)
If VarType(CenterPointArr) = vbBoolean Then
HaveErr = True
GoTo CaseErr
End If

'Define R
R = HCF4076X_HCS3095_07_DefineR(SelectOnScreen)

'Define Unit Qty
Uqty = HCF4076X_HCS3095_01_DefineUQty(SelectOnScreen, UQtyTextComment, False)

'Creat BallNoQtyArr(BallNo,BallQty,BallMsg)
BallNoQtyArr = HCF4076X_HCS3095_03_CreatResult(SelectOnScreen, CenterPointArr, R, QtyTextComment, Uqty, HozaiNoFrom, HozaiNoTo)
If VarType(BallNoQtyArr) = vbBoolean Then
HaveErr = True
GoTo CaseErr
End If

'Sort BallNoQtyArr
If UBound(BallNoQtyArr) >= 1 Then
BallNoQtyArr = HCF4068_SortArrAtoZ_Arr2Chieu(BallNoQtyArr, 0, "Number")
End If

'Msg
WriteToResult = HCF4076X_HCS3095_09_ShowEachResult(SelectOnScreen, BallNoQtyArr, TotalObjVisible, Uqty)
If WriteToResult = False Then GoTo ExitLoop

'Define Main Part
Call HCF4076X_HCS3095_12_DefineMainPart(BallNoQtyArr)

'Creat ResultArr
Dim ResultArr As Variant
Call HCF4076X_HCS3095_13_CreatResultArr(BallNoQtyArr, Uqty, HozaiNoFrom, HozaiNoTo, ResultArr)

CaseErr:
ProcessWhenErr = HCF4076X_HCS3095_11_ProcessWhenErr(HaveErr, WriteToResult, TotalObjVisible, SelectOnScreen)
If ProcessWhenErr = False Then Exit Sub
ExitLoop:
Loop While SSCount <> 0
SelectOnScreen.Delete

'Check ResultArr
If VarType(ResultArr) = vbEmpty Then Exit Sub

'Sort ResultArr
Call HCF4076X_HCS3095_14_SortResultArrAtoZ(ResultArr)

'Define WB,WS
Dim WB As Workbook
Dim WS As Worksheet
Set WB = HCF4072_StartExcelFromCad()
Set WS = WB.ActiveSheet

'Write Title to Excel
Call HCF4076X_HCS3095_15_WriteTitle2Excel(WS, HozaiNoFrom, HozaiNoTo)
'Write Data To Excel
Call HCF4076X_HCS3095_16_WriteData2Excel(WS, ResultArr)
'Write Formular to Excel
Call HCF4076X_HCS3095_17_WriteFormular2Excel(WS)

 

Call HCF4069_VisibleObjArr1Chieu(TotalObjVisible, True)

End Sub

Sub HCS3096_Change2ByBlock_Tuan()
'(TB VBABoss)Change Entity in block to byBlock, [TC2BB]

Call HCF4073_ChangeBlock2ByBlockByLayerRenameBlock("ByBlock")

End Sub
Sub HCS3097_Change2ByLayer_Tuan()
'(TB VBABoss)Change Entity in block to byLayer, [TC2BL]

Call HCF4073_ChangeBlock2ByBlockByLayerRenameBlock("ByLayer")

End Sub
Sub HCS3098_Convertmm2Inch()
'(TB VBABoss)Convertmm2Inch, [MM2I]


'Nhap khoang cach
Dim mm As Double
mm = Func49GetLFromDimension()

Dim Inch As String
Inch = HCF4084_Convertmm2Inch(mm)
MsgBox Inch

End Sub

 

Message 14 of 15
buianhtuan.cdt
in reply to: leife

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim a As Integer

If Not Intersect(Target, Range("B:B")) Is Nothing Then
    a = Target.Row
    Call TBF35_ShowUserForm(a)
End If

End Sub

 

Message 15 of 15
buianhtuan.cdt
in reply to: leife

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim a As Integer

If Not Intersect(Target, Range("B:B")) Is Nothing Then
    a = Target.Row
    Call TBF35_ShowUserForm(a)
End If

End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub ButtonChange_Click()
'Get Parameter
    Dim JinIn As Variant
    Dim Moku As Variant
    Dim Gai As Variant
    JinIn = GiaTri1.Value
    Moku = GiaTri2.Value
    Gai = GiaTri3.Value

'Convert Parameter
    If JinIn = "" Then
        JinIn = 0
    Else
        JinIn = CDbl(JinIn)
    End If
    If Moku = "" Then
        Moku = 0
    Else
        Moku = CDbl(Moku)
    End If
    If Gai = "" Then
        Gai = 0
    Else
        Gai = CDbl(Gai)
    End If
'Check Parameter
    If JinIn = 0 Or Moku = 0 Then
        MsgBox Msg01
        Exit Sub
    End If
'Write to Excel
    Dim NeedUpdate As String
    Dim SetupSheet As Worksheet
    Set SetupSheet = ThisWorkbook.Sheets(SetupSheetname)
    Dim RefColumnNo As Integer
    RefColumnNo = TBF29_ConvertColumnLetterToNumber(SetupSheet, GroupColorColumn)
    Dim DataColumnNo As Integer
    DataColumnNo = RefColumnNo + 6

'Old Data
    Dim OldValue1 As Double
    Dim OldValue2 As Double
    Dim OldValue3 As Double
    OldValue1 = SetupSheet.Cells(18, DataColumnNo).Value
    OldValue2 = SetupSheet.Cells(19, DataColumnNo).Value
    OldValue3 = SetupSheet.Cells(20, DataColumnNo).Value
'Write 2 Excel
    If JinIn = OldValue1 Then
        NeedUpdate = "No"
    Else
        NeedUpdate = "Yes"
        SetupSheet.Cells(18, DataColumnNo).Value = JinIn
    End If
    If Moku = OldValue2 And NeedUpdate = "No" Then
        NeedUpdate = "No"
    Else
        NeedUpdate = "Yes"
        SetupSheet.Cells(19, DataColumnNo).Value = Moku
    End If
    If Gai = OldValue3 And NeedUpdate = "No" Then
        NeedUpdate = "No"
    Else
        NeedUpdate = "Yes"
        SetupSheet.Cells(20, DataColumnNo).Value = Gai
    End If
    SetupSheet.Cells(21, DataColumnNo).Value = NeedUpdate
    Unload Me
End Sub

Private Sub ButtonClear_Click()
    GiaTri1.Value = ""
    GiaTri2.Value = ""
    GiaTri3.Value = ""
End Sub

Private Sub ButtonExit_Click()
'Write to Excel
    Dim SetupSheet As Worksheet
    Set SetupSheet = ThisWorkbook.Sheets(SetupSheetname)
    Dim RefColumnNo As Integer
    RefColumnNo = TBF29_ConvertColumnLetterToNumber(SetupSheet, GroupColorColumn)
    Dim DataColumnNo As Integer
    DataColumnNo = RefColumnNo + 6

    SetupSheet.Cells(21, DataColumnNo).Value = "No"
    Unload Me
End Sub
Private Sub GiaTri1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)

Dim CheckKeyPress As Boolean
CheckKeyPress = TBF37_CheckKeyPress(KeyAscii)
If CheckKeyPress = False Then
    KeyAscii = 0
    Beep
End If

End Sub
Private Sub GiaTri2_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)

Dim CheckKeyPress As Boolean
CheckKeyPress = TBF37_CheckKeyPress(KeyAscii)
If CheckKeyPress = False Then
    KeyAscii = 0
    Beep
End If

End Sub
Private Sub GiaTri3_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)

Dim CheckKeyPress As Boolean
CheckKeyPress = TBF37_CheckKeyPress(KeyAscii)
If CheckKeyPress = False Then
    KeyAscii = 0
    Beep
End If

End Sub

Private Sub UserForm_Initialize()

'Define SetupSheet
    Dim SetupSheet As Worksheet
    Set SetupSheet = ThisWorkbook.Sheets(SetupSheetname)
    Dim RefColumnNo As Integer
    RefColumnNo = TBF29_ConvertColumnLetterToNumber(SetupSheet, GroupColorColumn)
    Dim DataColumnNo As Integer
    DataColumnNo = RefColumnNo + 6
'Name of Parameter and UserFormTitle
    InPutData.Caption = SetupSheet.Cells(17, DataColumnNo).Value
    ThongSo1.Caption = Delimiter01
    ThongSo2.Caption = Tukhoa4
    ThongSo3.Caption = Delimiter02
    ThongSo4.Caption = Tukhoa5
'Old Data
    GiaTri1.Value = SetupSheet.Cells(18, DataColumnNo).Value
    GiaTri2.Value = SetupSheet.Cells(19, DataColumnNo).Value
    GiaTri3.Value = SetupSheet.Cells(20, DataColumnNo).Value
    
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode = vbFormControlMenu Then Cancel = True
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'For Calculation
Public Const GroupColorColumn As String = "AP"
Public Const Tukhoa2 As String = "Gr"
Public Const Tukhoa2A As String = "’“Ý"
Public Const Tukhoa3 As String = "‡Œv"
Public Const Tukhoa4 As String = "–Ú•W"
Public Const Tukhoa5 As String = "–¼"

Public Const Delimiter01 As String = "lˆõ"
Public Const Delimiter02 As String = "ŠO’"
Public Const Delimiter03 As String = "F"

'For MsgBox
Public Const Msg01 As String = "î•ñ‚ð‹L“ü‚µ‚ĉº‚³‚¢"
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function TBF33_Delete_CheckProjectCuoiCung(IsDongCuoiCung As Boolean, WS As Worksheet, ActiveCellRow As Integer, ListLoaiTru As Variant)

'Check ProjectUpDown co trung Group va Calculation k
Dim CheckUp As Boolean
Dim CheckDown As Boolean
Dim UpdownRowBegin As Integer
Dim UpDownRowEnd As Integer
'Case Up
    UpdownRowBegin = ActiveCellRow - 4
    UpDownRowEnd = ActiveCellRow - 2
    If UpdownRowBegin < 6 Then
        CantMove = True
        Exit Function
    End If
    CheckUp = TBF01_CheckProjectUpDown(WS, UpdownRowBegin, UpDownRowEnd, ListLoaiTru)
'Case Down
    UpdownRowBegin = ActiveCellRow + 2
    UpDownRowEnd = ActiveCellRow + 4
    CheckDown = TBF01_CheckProjectUpDown(WS, UpdownRowBegin, UpDownRowEnd, ListLoaiTru)
    
If CheckUp = True And CheckDown = True Then
    IsDongCuoiCung = True
    Exit Function
End If

End Function
Function TBF34_CheckTuKhoa(SearchInText As String) As Variant

If InStr(1, SearchInText, Tukhoa2, vbTextCompare) <> 0 Then
    TBF34_CheckTuKhoa = 2
    Exit Function
End If
If InStr(1, SearchInText, Tukhoa2A, vbTextCompare) <> 0 Then
    TBF34_CheckTuKhoa = 2
    Exit Function
End If
If InStr(1, SearchInText, Tukhoa3, vbTextCompare) <> 0 Then
    TBF34_CheckTuKhoa = 3
    Exit Function
End If
If InStr(1, SearchInText, Tukhoa4, vbTextCompare) <> 0 Then
    TBF34_CheckTuKhoa = 4
    Exit Function
End If
TBF34_CheckTuKhoa = False
    
End Function




Function TBF38A_CreatGroupArr(WS As Worksheet, SetupSheet As Worksheet, GroupArr() As Variant)
'Define Color
'(GroupName,Color,MeiRowNo,GouKeiRowNo,MokuHyouRowNo)
    Dim ColumnNo As Integer: ColumnNo = TBF29_ConvertColumnLetterToNumber(WS, GroupColorColumn)
    Dim GroupColorRange As Range
    Dim GroupName As String
    Dim Color As Long
    Dim MeiRowNo As Integer
    Dim GouKeiRowNo As Integer
    Dim MokuHyouRowNo As Integer
    Dim Mei As String
    Dim GouKei As String
    Dim MokuHyou As String
    For i = 2 To 6
        Set GroupColorRange = SetupSheet.Cells(i, ColumnNo)
        GroupName = GroupColorRange.Value
        Color = GroupColorRange.Interior.Color
        GroupArr(i, 0) = GroupName
        GroupArr(i, 1) = Color
    Next
'Define FromRow,EndRow
    Dim DataColumn As Integer: DataColumn = 2
    Dim DataRowFrom As Integer: DataRowFrom = 5
    Dim DataEndRow As Integer
    Call TBF43_DefineRowEndNo_ByColor(WS, DataEndRow, DataColumn)
        
'Define GroupRowNo
    Dim DataRange As Range
    Dim DataColor As Long
    Dim CheckTuKhoa As Variant
    Dim SearchText As String
    Dim TmpRowNo() As Integer
    Dim f As Integer
    For k = LBound(GroupArr) To UBound(GroupArr)
        ReDim TmpRowNo(0 To 2)
        f = 0
        Color = GroupArr(k, 1)
        For i = DataRowFrom To DataEndRow
            Set DataRange = WS.Cells(i, DataColumn)
            DataColor = DataRange.Interior.Color
            If DataColor = Color Then
                TmpRowNo(f) = i
                f = f + 1
            End If
        Next
        TmpRowNo = HCF4057_SortArrAtoZ_NumberType(TmpRowNo)
        GroupArr(k, 2) = TmpRowNo(0)
        GroupArr(k, 3) = TmpRowNo(1)
        GroupArr(k, 4) = TmpRowNo(2)
    Next

'Write to Excel
    For i = 2 To 6
        If GroupArr(i, 2) = 0 Then
            SetupSheet.Cells(i, ColumnNo + 1) = ""
        Else
            SetupSheet.Cells(i, ColumnNo + 1) = GroupArr(i, 2)
        End If
        SetupSheet.Cells(i, ColumnNo + 2) = GroupArr(i, 3)
        SetupSheet.Cells(i, ColumnNo + 3) = GroupArr(i, 4)
    Next
End Function
Function TBF38B_WriteGroupArr(GroupArr() As Variant)
'Define DataSheet and SetupSheet
    Dim SetupSheet As Worksheet
    Set SetupSheet = ThisWorkbook.Sheets(SetupSheetname)
    Dim ColumnNo As Integer: ColumnNo = TBF29_ConvertColumnLetterToNumber(SetupSheet, GroupColorColumn)

'Write to Excel
    For i = 2 To 6
        SetupSheet.Cells(i, ColumnNo + 1) = GroupArr(i, 2)
        SetupSheet.Cells(i, ColumnNo + 2) = GroupArr(i, 3)
        SetupSheet.Cells(i, ColumnNo + 3) = GroupArr(i, 4)
    Next
End Function


Function TBF38C_WriteRowFromRowTo2SetupSheet(SetupSheet As Worksheet, GroupArr() As Variant)
'Define RowFrom, RowTo
    Dim ColumnNo As Integer: ColumnNo = TBF29_ConvertColumnLetterToNumber(SetupSheet, GroupColorColumn) + 6
    Dim RowFrom As Integer
    Dim RowTo As Integer
    For i = 2 To 4
        RowFrom = GroupArr(i, 2) + 1
        RowTo = GroupArr(i, 3) - 1
        SetupSheet.Cells(2, ColumnNo).Value = RowFrom
        SetupSheet.Cells(3, ColumnNo).Value = RowTo
        ColumnNo = ColumnNo + 1
    Next
End Function

Function TBF35A_CheckAinGroupArr(a As Integer, SetupSheet As Worksheet, ColumnNo As Integer) As Variant
    Dim RowNo As Integer
    For i = 2 To 4
        RowNo = SetupSheet.Cells(i, ColumnNo + 1).Value
        If a = RowNo Then
            TBF35A_CheckAinGroupArr = i
            Exit Function
        End If
    Next
    TBF35A_CheckAinGroupArr = False
End Function
Function TBF35_ShowUserForm(a As Integer)
Application.ScreenUpdating = False
Application.EnableEvents = False

'Define DataSheet and SetupSheet
    Dim WS As Worksheet
    Dim SetupSheet As Worksheet
    Dim ColumnNo As Integer
    Call TBF39_DefineWS_SetupWS_ColumnNo(WS, SetupSheet, ColumnNo)
'Get OldData
    Call TBF38_WriteOldData

'Define GroupNo
    Dim GroupNo As Variant
    GroupNo = TBF35A_CheckAinGroupArr(a, SetupSheet, ColumnNo)
    If GroupNo = False Then
        Application.ScreenUpdating = True
        Application.EnableEvents = True
        Exit Function
    End If
    
'Get Parameter cho UserForm
    Call TBF35B_GetParameterForUserForm(SetupSheet, ColumnNo, GroupNo)
    
'Show UserForm
    InPutData.Show
    
'Update Parameter
    Dim NeedUpdate As String
    NeedUpdate = SetupSheet.Cells(21, ColumnNo + 6).Value
    If NeedUpdate = "No" Then
        Application.ScreenUpdating = True
        Application.EnableEvents = True
        Exit Function
    End If
    Call TBF40_UpdateParameterFromUserForm(SetupSheet, ColumnNo)

'Write Formular
    Call TBF41_SetFormular(SetupSheet)
'Write Result
    Call TBF42_CreatNote(WS, SetupSheet)

    
Application.ScreenUpdating = True
Application.EnableEvents = True

End Function
Function TBF38D_GetJinIn(WS As Worksheet, SetupSheet As Worksheet, ColumnNo As Integer, GroupArr As Variant)
    Dim JinIn As Variant
    Dim DataRowNo As Integer
    Dim WriteColumnNo As Integer
    WriteColumnNo = ColumnNo + 6
'Gr JinIn
    For i = 2 To 4
        DataRowNo = GroupArr(i, 2)
        JinIn = WS.Cells(DataRowNo, 3).Value
        JinIn = Trim(JinIn)
        JinIn = WorksheetFunction.Substitute(JinIn, Tukhoa5, "")
        If JinIn = "" Then JinIn = 0
        JinIn = CDbl(JinIn)
        SetupSheet.Cells(13, WriteColumnNo).Value = JinIn
        WriteColumnNo = WriteColumnNo + 1
    Next
    
'Copy to JinIn to MokuHyou
    For i = ColumnNo + 6 To ColumnNo + 8
        SetupSheet.Cells(7, i).Value = SetupSheet.Cells(13, i).Value
    Next
    
End Function
Function TBF38E_GetMokuHyouAndGaiChuu(WS As Worksheet, SetupSheet As Worksheet, ColumnNo As Integer, GroupArr As Variant)
    Dim MokuHyou As Variant
    Dim GaiChuu As Variant
    Dim Str As String
    Dim DataRowNo As Integer
    Dim WriteColumnNo As Integer
    WriteColumnNo = ColumnNo + 6
'Gr JinIn
    For i = 2 To 4
        DataRowNo = GroupArr(i, 4)
        Str = WS.Cells(DataRowNo, 2).Value
        GaiChuu = TBF36_Between(Str, Delimiter02, Delimiter01)
        GaiChuu = After_(GaiChuu, Delimiter03)
        GaiChuu = Trim(GaiChuu)
        If GaiChuu = "" Then GaiChuu = 0
        GaiChuu = CDbl(GaiChuu)
        MokuHyou = Before_(Str, Delimiter02)
        MokuHyou = After_(MokuHyou, Delimiter03)
        MokuHyou = Trim(MokuHyou)
        If MokuHyou = "" Then MokuHyou = 0
        MokuHyou = CDbl(MokuHyou)
       
        SetupSheet.Cells(11, WriteColumnNo).Value = MokuHyou
        SetupSheet.Cells(12, WriteColumnNo).Value = GaiChuu
        WriteColumnNo = WriteColumnNo + 1
    Next

    
End Function
Function Before_(Txt As Variant, Delimiter As String) As String
    Dim DelimiterPosition As Integer
    DelimiterPosition = InStr(Txt, Delimiter)
    If DelimiterPosition = 0 Then
        Before_ = ""
    Else
        Before_ = Left(Txt, DelimiterPosition - 1)
    End If
End Function
Function After_(Txt As Variant, Delimiter As String) As String
    Dim DelimiterPosition As Integer
    DelimiterPosition = InStr(Txt, Delimiter)
    If DelimiterPosition = 0 Then
        After_ = ""
    Else
        After_ = Right(Txt, Len(Txt) - DelimiterPosition)
    End If
End Function
Function TBF35B_GetParameterForUserForm(SetupSheet As Worksheet, ColumnNo As Integer, GroupNo As Variant)
    Dim UFTitle As String
    Dim UFJinIn As String
    Dim UFMokuHyou As String
    Dim UFGaiChuu As String
    Dim UFColumnNo As Integer
    Select Case GroupNo
        Case 2
            UFColumnNo = ColumnNo + 6
        Case 3
            UFColumnNo = ColumnNo + 7
        Case 4
            UFColumnNo = ColumnNo + 8
    End Select
    UFTitle = SetupSheet.Cells(1, UFColumnNo).Value
    UFJinIn = SetupSheet.Cells(13, UFColumnNo).Value
    UFMokuHyou = SetupSheet.Cells(11, UFColumnNo).Value
    UFGaiChuu = SetupSheet.Cells(12, UFColumnNo).Value
'Write 2 Excel
    SetupSheet.Cells(16, ColumnNo + 6).Value = UFColumnNo
    SetupSheet.Cells(17, ColumnNo + 6).Value = UFTitle
    SetupSheet.Cells(18, ColumnNo + 6).Value = UFJinIn
    SetupSheet.Cells(19, ColumnNo + 6).Value = UFMokuHyou
    SetupSheet.Cells(20, ColumnNo + 6).Value = UFGaiChuu
    
End Function

Function TBF36_Between(Txt As Variant, BeforeDelimiter As String, AfterDelimiter As String) As String
    Dim Between As String
    Between = Before_(Txt, AfterDelimiter)
    Between = After_(Between, BeforeDelimiter)
    TBF36_Between = Between
End Function

Function TBF37_CheckKeyPress(KeyCode As MSForms.ReturnInteger) As Boolean

TBF37_CheckKeyPress = True
Select Case KeyCode
    Case vbKey0
    Case vbKey1
    Case vbKey2
    Case vbKey3
    Case vbKey4
    Case vbKey5
    Case vbKey6
    Case vbKey7
    Case vbKey8
    Case vbKey9
'        Case vbKeyNumpad0
'        Case vbKeyNumpad1
'        Case vbKeyNumpad2
'        Case vbKeyNumpad3
'        Case vbKeyNumpad4
'        Case vbKeyNumpad5
'        Case vbKeyNumpad6
'        Case vbKeyNumpad7
'        Case vbKeyNumpad8
'        Case vbKeyNumpad9
'        Case vbKeyDecimal
    Case 46 '.
    Case Else
        TBF37_CheckKeyPress = False
End Select

End Function

Function TBF38_WriteOldData()
Application.ScreenUpdating = False
Application.EnableEvents = False

'Define DataSheet and SetupSheet
    Dim WS As Worksheet
    Dim SetupSheet As Worksheet
    Dim ColumnNo As Integer
    Call TBF39_DefineWS_SetupWS_ColumnNo(WS, SetupSheet, ColumnNo)
'Creat GroupArr
    '(GroupName,Color,MeiRowNo,GouKeiRowNo,MokuHyouRowNo)
    Dim GroupArr(2 To 6, 0 To 4) As Variant
    Call TBF38A_CreatGroupArr(WS, SetupSheet, GroupArr)

'Write GroupArr to SetupSheet
    Call TBF38B_WriteGroupArr(GroupArr)
'Write RowFrom, RowTo
    Call TBF38C_WriteRowFromRowTo2SetupSheet(SetupSheet, GroupArr)
'Write JinIn
    Call TBF38D_GetJinIn(WS, SetupSheet, ColumnNo, GroupArr)
'Write MokuHyou and GaiChuu
    Call TBF38E_GetMokuHyouAndGaiChuu(WS, SetupSheet, ColumnNo, GroupArr)
'Calculation GouKei,GaiChuu
    Call TBF38F_CalculationGouKeiGaiChuu(WS, SetupSheet, ColumnNo)
    
Application.ScreenUpdating = True
Application.EnableEvents = True

End Function
Function TBF39_DefineWS_SetupWS_ColumnNo(WS As Worksheet, SetupSheet As Worksheet, ColumnNo As Integer)
    Set WS = ThisWorkbook.ActiveSheet
    Set SetupSheet = ThisWorkbook.Sheets(SetupSheetname)
    ColumnNo = TBF29_ConvertColumnLetterToNumber(SetupSheet, GroupColorColumn)
End Function
Function TBF40_UpdateParameterFromUserForm(SetupSheet As Worksheet, ColumnNo As Integer)
    Dim WriteColumnNo As Integer
    Dim JinIn As Double
    Dim Moku As Double
    Dim Gai As Double
    
    WriteColumnNo = SetupSheet.Cells(16, ColumnNo + 6).Value
    JinIn = SetupSheet.Cells(18, ColumnNo + 6).Value
    Moku = SetupSheet.Cells(19, ColumnNo + 6).Value
    Gai = SetupSheet.Cells(20, ColumnNo + 6).Value
'Write to Excel
    SetupSheet.Cells(7, WriteColumnNo).Value = JinIn
    SetupSheet.Cells(13, WriteColumnNo).Value = JinIn
    SetupSheet.Cells(11, WriteColumnNo).Value = Moku
    SetupSheet.Cells(12, WriteColumnNo).Value = Gai
End Function

Function TBF38F_CalculationGouKeiGaiChuu(WS As Worksheet, SetupSheet As Worksheet, ColumnNo As Integer)
'Calculation GouKei,GaiChuu
    Dim RowFrom As Integer
    Dim RowTo As Integer
    Dim GouKei As Double
    Dim GaiChuu As Double
    Dim GouKeiRange As Range
    Dim GaiChuuRange As Range
    For i = ColumnNo + 6 To ColumnNo + 8
        RowFrom = SetupSheet.Cells(2, i)
        RowTo = SetupSheet.Cells(3, i)
        Set GouKeiRange = WS.Range(Cells(RowFrom, 4), Cells(RowTo, 4))
        Set GaiChuuRange = WS.Range(Cells(RowFrom, 5), Cells(RowTo, 5))
        GouKei = WorksheetFunction.Sum(GouKeiRange)
        GaiChuu = WorksheetFunction.Sum(GaiChuuRange)
        SetupSheet.Cells(5, i).Value = GouKei
        SetupSheet.Cells(6, i).Value = GaiChuu
    Next
End Function
Function TBF41_SetFormular(SUS As Worksheet)
    SUS.Range("AV4:AX4").Formula = "=LEFT($AU5,3)"
    SUS.Range("AV10:AX10").Formula = "=LEFT($AU11,3)"
    SUS.Range("AY4").Formula = "=MID($AU5,5,5)"
    SUS.Range("AZ4").Formula = "=RIGHT($AU5,5)"
    SUS.Range("AY10").Formula = "=MID($AU11,5,5)"
    SUS.Range("AZ10").Formula = "=RIGHT($AU11,5)"
    
    SUS.Range("AY5:AY7").Formula = "=SUM(AV5:AW5)"
    SUS.Range("AY11:AY13").Formula = "=SUM(AV11:AW11)"
    
    SUS.Range("AZ5:AZ7").Formula = "=SUM(AV5:AX5)"
    SUS.Range("AZ11:AZ13").Formula = "=SUM(AV11:AX11)"
    
    SUS.Range("AV8:AZ8").Formula = "=IFERROR(TEXT(ROUND((AV5-AV6)/AV7,1),""00.0""),0)"
    SUS.Range("AV14:AZ14").Formula = "=IFERROR(TEXT(ROUND((AV11-AV12)/AV13,1),""00.0""),0)"
    
    SUS.Range("AV9:AZ9").Formula = "=IFERROR(TEXT(ROUND(AV8/AV14,3)*100,""00.0""),0)"
    
    SUS.Range("BB5:BF5").Formula = "=CONCATENATE(AV4,AV5)"
    SUS.Range("BB6:BF6").Formula = "=CONCATENATE($AU6,AV6)"
    SUS.Range("BB7:BF8").Formula = "=SUBSTITUTE($AU7,""xx.x"",AV7)"
    SUS.Range("BB9:BF9").Formula = "=CONCATENATE(AV9,$AU9)"
    
    SUS.Range("BB11:BF11").Formula = "=CONCATENATE(AV10,AV11)"
    SUS.Range("BB12:BF12").Formula = "=CONCATENATE($AU12,AV12)"
    SUS.Range("BB13:BF14").Formula = "=SUBSTITUTE($AU13,""xx.x"",AV13)"
    
End Function
Function TBF42_CreatNote(WS As Worksheet, SUS As Worksheet)

'Creat AfterTextArr
    Dim AfterTextArr(5 To 14, 54 To 58) As String
    Dim RowNo As Integer
    Dim ColumnNo As Integer
    Dim BeforeText As String
    Dim AfterText As String
    Dim DefautLength As Integer
    Dim BeforeTextLength As Integer
    Dim SpaceQty As Integer
    For ColumnNo = 54 To 58
        For RowNo = 5 To 14
            If RowNo <> 10 Then
                DefautLength = SUS.Cells(RowNo, 60).Value
                BeforeText = SUS.Cells(RowNo, ColumnNo).Value
                BeforeTextLength = Len(BeforeText)
                SpaceQty = DefautLength - BeforeTextLength
                AfterText = BeforeText & Space(SpaceQty)
                AfterTextArr(RowNo, ColumnNo) = AfterText
            End If
        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 = 54 To 58
        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 - 52, 4) = GouKeiNote
        NoteArr(ColumnNo - 52, 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 HCF4057_SortArrAtoZ_NumberType(Arr As Variant) As Variant
' Sap xep cac phan tu cua mang theo thu tu tu A den Z

Dim TmpValue As Double
Dim SmallValue As Double
Dim LargeValue As Double
Dim TmpArr As Variant
TmpArr = Arr

For i = LBound(TmpArr) To UBound(TmpArr)
    SmallValue = TmpArr(i)
    For k = i To UBound(TmpArr)
        LargeValue = TmpArr(k)
        If SmallValue > LargeValue Then
            TmpValue = SmallValue
            SmallValue = LargeValue
            LargeValue = TmpValue
            TmpArr(i) = SmallValue
            TmpArr(k) = LargeValue
        End If
    Next
Next

HCF4057_SortArrAtoZ_NumberType = TmpArr

End Function
Function TBF43_DefineRowEndNo_ByColor(WS As Worksheet, EndRow As Integer, ColumnNo As Integer)
    Dim RowNo As Integer
    Dim ColorRange As Range
    Dim ColorNo As Long
    For RowNo = 200 To 1 Step -1
        Set ColorRange = WS.Cells(RowNo, ColumnNo)
        ColorNo = ColorRange.Interior.Color
        If ColorNo <> 16777215 Then
            EndRow = RowNo
            Exit Function
        End If
    Next
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Call TBF33_Delete_CheckProjectCuoiCung(IsDongCuoiCung, WS, ActiveCellRow, ListLoaiTru)
If IsDongCuoiCung = True Then
    MsgBox "ÅŒã‚̍s‚Ȃ̂ŁAíœ‚Å‚«‚Ü‚¹‚ñB"
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Exit Sub
End If
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub TBS10_CreatNote()
Application.ScreenUpdating = False
Application.EnableEvents = False

'Define DataSheet and SetupSheet
    Dim WS As Worksheet
    Dim SetupSheet As Worksheet
    Dim ColumnNo As Integer
    Call TBF39_DefineWS_SetupWS_ColumnNo(WS, SetupSheet, ColumnNo)
'Get OldData
    Call TBF38_WriteOldData
    
'Write Formular
    Call TBF41_SetFormular(SetupSheet)
'Write Result
    Call TBF42_CreatNote(WS, SetupSheet)

    
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

Can't find what you're looking for? Ask the community or share your knowledge.

Post to forums  

Autodesk Design & Make Report

”Boost