Public Sub Main()
On Error Resume Next
Set oAutocad = New clsAutocad
Set AutoCAD = oAutocad.ACADApp
Set Thisdrawing = oAutocad.Document
Dim lngCol As Long, lngRow As Long
Dim txt As AcadText
Dim pt(2) As Double
Dim s As String
Dim soThua As String
Dim oLayer As AcadLayer
On Error Resume Next
Set oLayer = Thisdrawing.Layers.Add("SoThua")
GetExcel
pt(2) = 0
For lngRow = 1 To exRang.Rows.Count
soThua = exRang(lngRow, 1)
pt(0) = Val(exRang(lngRow, 2))
pt(1) = Val(exRang(lngRow, 3))
Set txt = Thisdrawing.ModelSpace.AddText(soThua, pt, 1)
txt.Layer = "SoThua"
'Thisdrawing.Regen acActiveViewport
exRang(lngRow, 4) = timDiaDanh
txt.Delete
Next lngRow
thoat:
Set txt = Nothing
Set oLayer = Nothing
freeApp
End Sub
Private Function timDiaDanh() As String
Dim tenDiaDanh As String
Dim ssPoly As AcadSelectionSet
Dim ssSoThua As AcadSelectionSet
Dim ssTenDiaDanh As AcadSelectionSet
Dim fType(2) As Integer, fData(2)
Dim fT(2) As Integer, fD(2)
tenDiaDanh = ""
On Error Resume Next
Set ssPoly = Thisdrawing.SelectionSets("ssPoly")
If Err Then Set ssPoly = Thisdrawing.SelectionSets.Add("ssPoly")
ssPoly.Clear
fType(0) = 0: fData(0) = "POLYLINE,LWPolyline" '"TEXT"
fType(1) = 8: fData(1) = "polygon"
fType(2) = 67: fData(2) = 0
ssPoly.Select acSelectionSetAll, , , fType, fData
fType(0) = 0: fData(0) = "TEXT"
fType(1) = 8: fData(1) = "TenDiaDanh"
fT(0) = 0: fD(0) = "TEXT"
fT(1) = 8: fD(1) = "SoThua"
fT(2) = 67: fD(2) = 0
On Error Resume Next
Set ssTenDiaDanh = Thisdrawing.SelectionSets("ssTenDiaDanh")
If Err Then Set ssTenDiaDanh = Thisdrawing.SelectionSets.Add("ssTenDiaDanh")
ssTenDiaDanh.Clear
On Error Resume Next
Set ssSoThua = Thisdrawing.SelectionSets("ssSoThua")
If Err Then Set ssSoThua = Thisdrawing.SelectionSets.Add("ssSoThua")
ssSoThua.Clear
Dim ent As AcadText
Dim poly As AcadEntity
Dim dblCurCords() As Double
Dim dblNewCords() As Double
Dim iMaxCurArr, iMaxNewArr As Integer
Dim iCurArrIdx, iNewArrIdx, iCnt As Integer
For Each poly In ssPoly
If poly.ObjectName = "AcDbPolyline" Then
dblCurCords = poly.Coordinates
iMaxCurArr = UBound(dblCurCords)
iMaxNewArr = ((iMaxCurArr + 1) * 1.5) - 1
ReDim dblNewCords(iMaxNewArr) As Double
iCurArrIdx = 0: iCnt = 1
For iNewArrIdx = 0 To iMaxNewArr
If iCnt = 3 Then
dblNewCords(iNewArrIdx) = 0
iCnt = 1
Else
dblNewCords(iNewArrIdx) = dblCurCords(iCurArrIdx)
iCurArrIdx = iCurArrIdx + 1
iCnt = iCnt + 1
End If
Next
ssSoThua.Clear
ssSoThua.SelectByPolygon acSelectionSetWindowPolygon, dblNewCords, fT, fD
If ssSoThua.Count > 0 Then
ssTenDiaDanh.Clear
ssTenDiaDanh.SelectByPolygon acSelectionSetWindowPolygon, dblNewCords, fType, fData
Set ent = ssTenDiaDanh(0)
tenDiaDanh = ent.TextString
ssSoThua.Delete
Exit For
End If
End If
Next poly
Set ssPoly = Nothing
Set ssSoThua = Nothing
Set ssTenDiaDanh = Nothing
Set ent = Nothing
Set poly = Nothing
timDiaDanh = tenDiaDanh
End Function
