Do yêu cầu công việc của mình là thống kê sản lượng "TIÊU THỤ" của các khách hàng theo "SỐ DB". Mình có file excel thống kê sản lượng "TIÊU THỤ" (cột N) theo "MÃ DB" (cột E) và file cad có Layer "Text_Danh bo-GN". Mình muốn khi chọn các text theo Layer "Text_Danh bo-GN" thì sẽ xuất ra bảng tính excel có số liệu "TIÊU THỤ" ứng với các text đó (nếu tính tổng được thì rất tốt), cụ thể ở đây là text ở ô E6 (Vì bảng excel và cad của mình khá lớn nên mình chỉ liệt kê số liệu ít). Mong các bạn trên diễn đàn giúp đỡ! Xin chân thành cảm ơn rất nhiều! http://www.mediafire...CH_TIEU_THU.xls http://www.mediafire...U_cad2excel.dwg
Do yêu cầu công việc của mình là thống kê sản lượng "TIÊU THỤ" của các khách hàng theo "SỐ DB". Mình có file excel thống kê sản lượng "TIÊU THỤ" (cột N) theo "MÃ DB" (cột E) và file cad có Layer "Text_Danh bo-GN". Mình muốn khi chọn các text theo Layer "Text_Danh bo-GN" thì sẽ xuất ra bảng tính excel có số liệu "TIÊU THỤ" ứng với các text đó (nếu tính tổng được thì rất tốt), cụ thể ở đây là text ở ô E6 (Vì bảng excel và cad của mình khá lớn nên mình chỉ liệt kê số liệu ít). Mong các bạn trên diễn đàn giúp đỡ! Xin chân thành cảm ơn rất nhiều! http://www.mediafire...CH_TIEU_THU.xls http://www.mediafire...U_cad2excel.dwg
Hiện nay tôi cũng ít làm việc với autocad , cũng thử vọc 1 chút xem thế nào :
* Đầu tiên mở file cad lên , Ấn Alt+F11 , click vào Tab insert -Module:
Trong modue 1 : bạn copy toàn bộ code bên dưới vào module này
Mã:
Function getExcel(obj) As Variant
Dim ObjAppExcel As Object
On Error Resume Next
Set ObjAppExcel = GetObject(, "Excel.Application")
If Err Then
Err.Clear
Set ObjAppExcel = CreateObject("Excel.Application")
End If
If Err Then
getExcel = False: getExcel = Err.Description
Else
getExcel = True: Set obj = ObjAppExcel
End If
End Function
Mã:
Sub Gettext()
Dim sset As AcadSelectionSet, entity As AcadEntity
Dim gpcode%(0 To 6), gpdata(0 To 6), i&
Dim ArrResult()
On Error Resume Next
'Dinh nghia bo Loc selectionset : And(or(text,Mtext),LayerName)
gpcode(0) = -4: gpdata(0) = "<and"
gpcode(1) = -4: gpdata(1) = "<or"
gpcode(2) = 0: gpdata(2) = "Text"
gpcode(3) = 0: gpdata(3) = "Mtext"
gpcode(4) = -4: gpdata(4) = "or>"
gpcode(5) = 8: gpdata(5) = "Text_Danh Bo-GN"
gpcode(6) = -4: gpdata(6) = "and>"
'Chon doi tuong tren man hinh thoa man --> ghi ket qua vao mang ArrResult
With ThisDrawing
Set sset = .SelectionSets.Add("#")
sset.SelectOnScreen gpcode, gpdata
If sset.Count Then
ReDim ArrResult(1 To sset.Count, 1 To 1)
For Each entity In sset
i = i + 1
ArrResult(i, 1) = entity.TextString
Next
End If
.SelectionSets("#").Delete
End With
'Khoi tao doi tuong excel
Dim ExcelApp As Object, wB As Object
If getExcel(ExcelApp) Then
With ExcelApp
Set wB = .workbooks.Add
.Visible = True
With wB.ActiveSheet
.Range("A:A").EntireColumn.AutoFit
.Range("A1") = "MA DB"
.Range("A2").resize(i) = ArrResult
End With
End With
Else
MsgBox getExcel(ExcelApp)
End If
End Sub
** Quay trở về màn hình cad : bạn gõ lênh : VBARun --> chọn Macro nào có phần tên sau cùng là ...!Module1.Gettext --> click Run *** Chọn toàn bộ đối tượng trên màn hình , ấn enter : good luck !
Hiện nay tôi cũng ít làm việc với autocad , cũng thử vọc 1 chút xem thế nào :
* Đầu tiên mở file cad lên , Ấn Alt+F11 , click vào Tab insert -Module:
Trong modue 1 : bạn copy toàn bộ code bên dưới vào module này
Mã:
Function getExcel(obj) As Variant
Dim ObjAppExcel As Object
On Error Resume Next
Set ObjAppExcel = GetObject(, "Excel.Application")
If Err Then
Err.Clear
Set ObjAppExcel = CreateObject("Excel.Application")
End If
If Err Then
getExcel = False: getExcel = Err.Description
Else
getExcel = True: Set obj = ObjAppExcel
End If
End Function
Mã:
Sub Gettext()
Dim sset As AcadSelectionSet, entity As AcadEntity
Dim gpcode%(0 To 6), gpdata(0 To 6), i&
Dim ArrResult()
On Error Resume Next
'Dinh nghia bo Loc selectionset : And(or(text,Mtext),LayerName)
gpcode(0) = -4: gpdata(0) = "<and"
gpcode(1) = -4: gpdata(1) = "<or"
gpcode(2) = 0: gpdata(2) = "Text"
gpcode(3) = 0: gpdata(3) = "Mtext"
gpcode(4) = -4: gpdata(4) = "or>"
gpcode(5) = 8: gpdata(5) = "Text_Danh Bo-GN"
gpcode(6) = -4: gpdata(6) = "and>"
'Chon doi tuong tren man hinh thoa man --> ghi ket qua vao mang ArrResult
With ThisDrawing
Set sset = .SelectionSets.Add("#")
sset.SelectOnScreen gpcode, gpdata
If sset.Count Then
ReDim ArrResult(1 To sset.Count, 1 To 1)
For Each entity In sset
i = i + 1
ArrResult(i, 1) = entity.TextString
Next
End If
.SelectionSets("#").Delete
End With
'Khoi tao doi tuong excel
Dim ExcelApp As Object, wB As Object
If getExcel(ExcelApp) Then
With ExcelApp
Set wB = .workbooks.Add
.Visible = True
With wB.ActiveSheet
.Range("A:A").EntireColumn.AutoFit
.Range("A1") = "MA DB"
.Range("A2").resize(i) = ArrResult
End With
End With
Else
MsgBox getExcel(ExcelApp)
End If
End Sub
** Quay trở về màn hình cad : bạn gõ lênh : VBARun --> chọn Macro nào có phần tên sau cùng là ...!Module1.Gettext --> click Run *** Chọn toàn bộ đối tượng trên màn hình , ấn enter : good luck !
Khi Run code của bạn thì xuất kết quả chỉ hiển thị "Số DB", mình muốn kết quả xuất ra là "TIÊU THỤ" như trong bảng tính excel ứng với "Số DB". Cảm ơn bạn đã giúp đỡ!
