Lisp In Nhiều Bản Vẽ (Kể Cả Layout)

[Lisp In Nhiều Bản Vẽ (Kể Cả Layout)]

đây là số sẻi của mình bạn cho mình nhé:562218 751FDC 365BF

[Mẹo Viết Vba Xuất Được Ra File .exe Đơn Giản]

Như chúng ta đã biết ưu điểm khi viết chương trình VBA chạy trên Cad hoặc Excel là chạy khá nhanh. Nhưng nó có một nhược điểm chí tử là tính bảo mật quá kém, chính vì vậy mà người lập trình không muốn sử dụng nó để viết nên các phần mềm có tính chất thương mại được. Do đó VB.net ra đời để bù vào vấn đề này. Nhưng mà với những người lười thì việc học VB.net quả là quá mệt,( bản thân VB cũng được viết để cho những người lười sử dụng để lập trình rồi bây giờ muốn chăm chỉ lại thì mệt quá). 

Tuy nhiên chúng ta vẫn còn 1 cách nữa để viết chương trình trên VBA sau đó Export ra dưới dạng ".frm" và chèn thêm đoạn mã ở đầu chương trình để tạo liên kết giữa VB6 và Autocad rồi xuất chương trình ra dưới dạng file .EXE :

- Lưu ý việc kết nối giữa Cad và VB6 bạn cần chọn thêm thư viện Cad cho VB6 bằng cách vào Poject -> Preferences.... nó sẽ hiện lên bảng. bạn di chuyển đến chỗ Auto.... để chọn thư viện "Aotocad 2007 type Library" . 

Dim moACAD As Object
Dim THISDRAWING  As Object


On Error Resume Next

Set moACAD = GetObject(, "AutoCAD.Application")
If Err.Number Then
    Err.Clear
    Set moACAD = CreateObject("AutoCAD.Application")
    If Err.Number Then
        MsgBox "bat cad len di. chuong trinh khong tu mo duoc Cad cua bam"
        Exit Sub
    Else
        moACAD.Visible = True
    End If
End If
'moACAD.Application.Documents.Add

Set THISDRAWING = moACAD.ActiveDocument

moACAD.WindowState = 3

[[Giúp Đỡ] Vẽ Đoạn Thẳng Cắt Đường Thẳng Cho Trước Tại 1 Điểm]

không có thủ thuật nhỏ cho cái đấy đâu bạn ạ. Mình cũng nghiên cứu kỹ ròi mới viết ra đc cái chương trình đấy vài lầm thử đi đường tắt tưởng làm xong đến nơi rồi nhưng cuối cùng lại hỏng

[[Giúp Đỡ] Vẽ Đoạn Thẳng Cắt Đường Thẳng Cho Trước Tại 1 Điểm]

dùng PM này thử xem:

 

http://xaydung360.vn/diendan/-chia-se-phan-mem-ngat-nhau-giua-line-va-pline-21659-1-1.html

[Ai Có Thể Tạo Macro Từ Vb6 Cho Cad?]

Xin chào cả Nhà!

Nhờ các cao thủ chỉ điểm cho làm sao để tạo 1 macro từ VB6 và chạy nó trong cad giống như trong đoạn mã trên excel như sau

Private Sub Command1_Click()

' Start Excel

Dim xlapp As Object 'Excel.Application

Set xlapp = CreateObject("Excel.Application")

 

' Make it visible...

xlapp.Visible = True

 

' Add a new workbook

Dim xlbook As Object 'Excel.Workbook

Set xlbook = xlapp.Workbooks.Add

 

' Add a module

Dim xlmodule As Object 'VBComponent

Set xlmodule = xlbook.VBProject.VBComponents.Add(1) 'vbext_ct_StdModule

 

' Add a macro to the module...

Dim strCode As String

strCode = _

"sub MyMacro()" & vbCr & _

" msgbox ""Inside generated macro!!!"" " & vbCr & _

"end sub"

xlmodule.CodeModule.AddFromString strCode

 

 

' Run the new macro!

xlapp.Run "MyMacro"

 

' ** Create a new toolbar with a button to fire macro...

' Add a new toolbar...

Dim cbs As Object 'CommandBars

Dim cb As Object 'CommandBar

Set cbs = xlapp.CommandBars

Set cb = cbs.Add("MyCommandBar", 1, , True) '1=msoBarTop

cb.Visible = True

 

' Make it visible & add a button...

Dim cbc As Object 'CommandBarControl

Set cbc = cb.Controls.Add(1) '1=msoControlButton

 

' Assign our button to our macro

cbc.OnAction = "MyMacro"

 

' Set text...

cbc.Caption = "Call MyMacro()"

 

' Set Face image...

' 51 = white hand

' 25 = glasses

' 34 = ink dipper

' etc...

cbc.FaceId = 51

 

' Pause so you can inspect results...

MsgBox "All done, click me to continue...", vbMsgBoxSetForeground

 

' Remember to release module

Set xlmodule = Nothing

 

' Clean up

xlbook.Saved = True

xlapp.Quit

End Sub

[Nhờ Gợi Ý Lisp Bắt Điểm Trên 1 Đối Tượng.]

với line bạn có thể dùng tọa độ trung bình của 2 điểm để chọn đường đôi tượng A, tức là đường A có 2 giao điểm thì cộng lấy điểm middpoint giữa 2 giao điểm lại là nó chọn A mà. Chắc bạn lại dùng Command khi lập trình cho cad nên mới hỏi thế

[Nhờ Các Cao Thủ Chỉ Giáo Gỡ Rối Chương Trình. Break Đường Line Lao Vào Hình Chữ Nhật]

" Code đây mà

Sub A_TrimTuongCot()

On Error Resume Next

Dim ExcelApp As Object

Set ExcelApp = GetObject(, "Excel.Application")

If Err <> 0 Then

Err.Clear

Set ExcelApp = CreateObject("Excel.Application")

End If

ExcelApp.Visible = False

AppActivate ExcelApp.Caption

'ExcelApp.Workbooks.Add ' MO FILE TRANG"

ExcelApp.Workbooks.Add.SaveAs "e:\THO1.XLS"

'ExcelApp.Workbooks.Open "e:\THO.XLSX"

ExcelApp.worksheets("sheet1").Activate

'ExcelApp.range("a2").Value = "aaa"

'ExcelApp.cells(1, k).Value = "aaa"

ExcelApp.Visible = True

Dim MangTuong(0 To 100000) As Variant

Dim MangCot(0 To 100000) As Variant

Dim TapGiao As Variant

Dim MangGiao(0 To 10000000) As Variant

Set objmien = ThisDrawing.SelectionSets.Add("TenMien")

i = -1

j = -1

objmien.SelectOnScreen

' Lay Mang tuong

For Each tt In objmien

If tt.ObjectName = "AcDbLine" Then

i = i + 1

Set MangTuong(i) = tt

End If

Next tt

n = i

'Lay Mang cot

For Each tt In objmien

If tt.ObjectName <> "AcDbLine" Then

j = j + 1

Set MangCot(j) = tt

End If

Next tt

m = j

ThisDrawing.SelectionSets.Item("TenMien").Delete

 

'============================= TIM TOA DO GIAO DIEM==================================

 

 

Dim pa(0 To 2) As Double

Dim TapGiaotb(0 To 2) As Double

Dim diem1(1000000) As String

Dim diem2(1000000) As String

Dim diemtb(1000000) As String

Dim cmd(1000000) As String

nn = 0

sogiao = 0

For ii = 0 To n

stp = MangTuong(ii).StartPoint

EnP = MangTuong(ii).EndPoint

startp1 = stp(0) & "," & stp(1) & "," & stp(2)

For jj = 0 To m

TapGiao = MangTuong(ii).IntersectWith(MangCot(jj), acExtendNone)

Dim iii As Integer, kkk As Integer

iii = 0

'MsgBox nn

If VarType(TapGiao) <> vbEmpty Then

For iii = LBound(TapGiao) To UBound(TapGiao)

'MsgBox sogiao

MangGiao(nn) = Round(TapGiao(iii), 8)

MangGiao(nn + 1) = Round(TapGiao(iii + 1), 8)

MangGiao(nn + 2) = Round(TapGiao(iii + 2), 8)

ExcelApp.cells(sogiao + 1, 1).Value = MangGiao(nn)

ExcelApp.cells(sogiao + 1, 2).Value = MangGiao(nn + 1)

ExcelApp.cells(sogiao + 1, 3).Value = MangGiao(nn + 2)

ExcelApp.cells(sogiao + 1, 4).Value = sogiao

pa(0) = TapGiao(iii)

pa(1) = TapGiao(iii + 1)

pa(2) = TapGiao(iii + 2)

Set gg = ThisDrawing.ModelSpace.AddMText(pa, 500, sogiao)

gg.Height = 50

sogiao = sogiao + 1

iii = iii + 2

nn = nn + 3

Next iii

End If

TapGiaotb(0) = Round((MangGiao(nn - 6) + MangGiao(nn - 3)) / 2, 8)

TapGiaotb(1) = Round((MangGiao(nn - 5) + MangGiao(nn - 2)) / 2, 8)

TapGiaotb(2) = Round((MangGiao(nn - 4) + MangGiao(nn - 1)) / 2, 8)

diem1(sogiao) = MangGiao(nn - 6) & "," & MangGiao(nn - 5) & "," & MangGiao(nn - 4)

diemtb(sogiao) = TapGiaotb(0) & "," & TapGiaotb(1) & "," & TapGiaotb(2)

diem2(sogiao) = MangGiao(nn - 3) & "," & MangGiao(nn - 2) & "," & MangGiao(nn - 1)

ExcelApp.cells(sogiao, 5).Value = TapGiaotb(0)

ExcelApp.cells(sogiao, 6).Value = diemtb(sogiao)

'MsgBox DIEM1

'MsgBox DIEM2

'MsgBox diemtb

cmd(nn / 2) = ".break" & Chr(10) & diemtb(sogiao) & vbCr & "f" & vbCr & diem1(sogiao) & vbCr & diem2(sogiao) & vbCr

'MsgBox cmd

'ThisDrawing.SendCommand cmd

Next jj

'===================BREAK DOI TUONG========================================

Next ii

 

' =============== HET LAY TOA DO GIAO=============================

 

ExcelApp.cells(1, 50).Value = sogiao

For y = 1 To nn / 2

If cmd(y) <> "" Then

ThisDrawing.SendCommand cmd(y)

End If

Next y

Set ExcelApp = Nothing

End Sub

"

[Nhờ Các Cao Thủ Chỉ Giáo Gỡ Rối Chương Trình. Break Đường Line Lao Vào Hình Chữ Nhật]

Thank Gia_bach. Hiccc trên trang Web này nó không hiện "AcDbline" đấy bạn ạ. Tôi Down thử lại và kiểm tra rồi, vẫn có. Bạn cứ thử Down về kiểm tra lại xem. 

[Nhờ Các Cao Thủ Chỉ Giáo Gỡ Rối Chương Trình. Break Đường Line Lao Vào Hình Chữ Nhật]

Đây là Code VBA

Sub A_TrimTuongCot()

On Error Resume Next
Dim ExcelApp As Object
Set ExcelApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Err.Clear
Set ExcelApp = CreateObject("Excel.Application")
End If
ExcelApp.Visible = False
AppActivate ExcelApp.Caption
'ExcelApp.Workbooks.Add ' MO FILE TRANG"
ExcelApp.Workbooks.Add.SaveAs "e:\THO1.XLS"
'ExcelApp.Workbooks.Open "e:\THO.XLSX"
ExcelApp.worksheets("sheet1").Activate
'ExcelApp.range("a2").Value = "aaa"
'ExcelApp.cells(1, k).Value = "aaa"
ExcelApp.Visible = True
Dim MangTuong(0 To 100000) As Variant
Dim MangCot(0 To 100000) As Variant
Dim TapGiao As Variant
Dim MangGiao(0 To 10000000) As Variant
Set objmien = ThisDrawing.SelectionSets.Add("TenMien")
i = -1
j = -1
objmien.SelectOnScreen
' Lay Mang tuong
For Each tt In objmien
If tt.ObjectName = "AcDbLine" Then
i = i + 1
Set MangTuong(i) = tt
End If
Next tt
n = i
'Lay Mang cot
For Each tt In objmien
If tt.ObjectName <> "AcDbLine" Then
j = j + 1
Set MangCot(j) = tt
End If
Next tt
m = j
ThisDrawing.SelectionSets.Item("TenMien").Delete
'============================= TIM TOA DO GIAO DIEM==================================

Dim pa(0 To 2) As Double
Dim TapGiaotb(0 To 2) As Double
Dim diem1(1000000) As String
Dim diem2(1000000) As String
Dim diemtb(1000000) As String
Dim cmd(1000000) As String
nn = 0
sogiao = 0
For ii = 0 To n
stp = MangTuong(ii).StartPoint
EnP = MangTuong(ii).EndPoint
startp1 = stp(0) & "," & stp(1) & "," & stp(2)
For jj = 0 To m
TapGiao = MangTuong(ii).IntersectWith(MangCot(jj), acExtendNone)
Dim iii As Integer, kkk As Integer
iii = 0
'MsgBox nn
If VarType(TapGiao) <> vbEmpty Then
For iii = LBound(TapGiao) To UBound(TapGiao)
'MsgBox sogiao
MangGiao(nn) = Round(TapGiao(iii), 8)
MangGiao(nn + 1) = Round(TapGiao(iii + 1), 8)
MangGiao(nn + 2) = Round(TapGiao(iii + 2), 8)

ExcelApp.cells(sogiao + 1, 1).Value = MangGiao(nn)
ExcelApp.cells(sogiao + 1, 2).Value = MangGiao(nn + 1)
ExcelApp.cells(sogiao + 1, 3).Value = MangGiao(nn + 2)
ExcelApp.cells(sogiao + 1, 4).Value = sogiao


pa(0) = TapGiao(iii)
pa(1) = TapGiao(iii + 1)
pa(2) = TapGiao(iii + 2)

Set gg = ThisDrawing.ModelSpace.AddMText(pa, 500, sogiao)
gg.Height = 50

sogiao = sogiao + 1

iii = iii + 2

nn = nn + 3

Next iii

End If

TapGiaotb(0) = Round((MangGiao(nn - 6) + MangGiao(nn - 3)) / 2, 8)

TapGiaotb(1) = Round((MangGiao(nn - 5) + MangGiao(nn - 2)) / 2, 8)

TapGiaotb(2) = Round((MangGiao(nn - 4) + MangGiao(nn - 1)) / 2, 8)

diem1(sogiao) = MangGiao(nn - 6) & "," & MangGiao(nn - 5) & "," & MangGiao(nn - 4)

diemtb(sogiao) = TapGiaotb(0) & "," & TapGiaotb(1) & "," & TapGiaotb(2)

diem2(sogiao) = MangGiao(nn - 3) & "," & MangGiao(nn - 2) & "," & MangGiao(nn - 1)

ExcelApp.cells(sogiao, 5).Value = TapGiaotb(0)

ExcelApp.cells(sogiao, 6).Value = diemtb(sogiao)

'MsgBox DIEM1
'MsgBox DIEM2
'MsgBox diemtb

cmd(nn / 2) = ".break" & Chr(10) & diemtb(sogiao) & vbCr & "f" & vbCr & diem1(sogiao) & vbCr & diem2(sogiao) & vbCr

'MsgBox cmd

'ThisDrawing.SendCommand cmd





Next jj

'===================BREAK DOI TUONG========================================


Next ii
' =============== HET LAY TOA DO GIAO=============================

ExcelApp.cells(1, 50).Value = sogiao

For y = 1 To nn / 2
If cmd(y) <> "" Then

ThisDrawing.SendCommand cmd(y)

End If
Next y

Set ExcelApp = Nothing


End Sub

[Nhờ Các Cao Thủ Chỉ Giáo Gỡ Rối Chương Trình. Break Đường Line Lao Vào Hình Chữ Nhật]

Xin chào các cao thủ!

 Tôi có 1 đoạn mã chương trình với 1 tưởng có 1 đường Line xuyên qua các đường Rectang. Bây giờ làm sao để ngắt các đoạn giao giữa đường Line với Rectang này. Tôi viết trên VBA thấy đã ổn nhưng không hiểu tại sao vẫn xảy ra lỗi khi chạy. Tôi vẫn biết là không nên dùng Command trong VBA nhưng đây là trường hợp vạn bất đắc dĩ thôi, ai có giải pháp hay hơn chỉ giúp tôi với. Chương trình này tôi mở Excel để kiểm soát cho dễ mà vẫn không tìm ra lỗi được.

 

 

[Bản vẽ block cần cẩu, xe cẩu và ô tô các loại]

lỗi đường link hết rồi chủ thớt ơi

[Vẽ Line Or Polyline Trim]

DÂN DỰ TOÁN À?