Chuyển đến nội dung
Diễn đàn CADViet
lucton

Viết VBA theo yêu cầu.............

Các bài được khuyến nghị

Nhờ các bác viết giúp e code vba chèn bock vào bản vẽ với nội dung

- giả sử có file abc.dwg có các block mình cần chèn, file abc.dwg nằm bất kỳ thư mục nào

thanks all

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Dim Bang As AcadBlockReference
VT1(0) = Diembatdau(0) - 5: VT1(1) = Diembatdau(1): VT1(2) = Diembatdau(2)
Set Bang = ThisDrawing.ModelSpace.InsertBlock(VT1, "BB", 1, 1, 1, 0)

Ví dụ trên sẽ Insert block có tên BB tại vị trí VT1

Bạn viết luôn cho minh đầy đũ luôn được không à, chứ mình copy về chạy thử báo lỗi. Khi chỉ thêm thủ tục Sub() và end sub

  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Bạn viết luôn cho minh đầy đũ luôn được không à, chứ mình copy về chạy thử báo lỗi. Khi chỉ thêm thủ tục Sub() và end sub

sub block()
Dim Bang As AcadBlockReference
VT1(0) = Diembatdau(0) - 5: VT1(1) = Diembatdau(1): VT1(2) = Diembatdau(2)
Set Bang = ThisDrawing.ModelSpace.InsertBlock(VT1, "BB", 1, 1, 1, 0)
end sub

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

<pre class="Code">Ví dụ mẫu trong Help để bạn tham khảo nhé:

Sub Example_InsertBlock()' This example creates a block containing a circle.' It then inserts the block.' Create the block    Dim blockObj As AcadBlock    Dim insertionPnt(0 To 2) As Double    insertionPnt(0) = 0#: insertionPnt(1) = 0#: insertionPnt(2) = 0#    Set blockObj = ThisDrawing.Blocks.Add(insertionPnt, "CircleBlock")        ' Add a circle to the block    Dim circleObj As AcadCircle    Dim center(0 To 2) As Double    Dim radius As Double    center(0) = 0: center(1) = 0: center(2) = 0    radius = 1    Set circleObj = blockObj.AddCircle(center, radius)   	' Insert the block    Dim blockRefObj As AcadBlockReference    insertionPnt(0) = 2#: insertionPnt(1) = 2#: insertionPnt(2) = 0    Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock(insertionPnt, "CircleBlock", 1#, 1#, 1#, 0)        ZoomAllEnd Sub

</pre>

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Em nhờ Bác Hướng và Các Anh Chị trên diễn đàn Viết VBA giúp em.

Em có 1 file cad và 1 file excel 2 file này có có cùng số cột như nhau. Yêu cầu là làm sao khi sửa số thứ tự cột bên cad thì lập tức bên excel cũng tự động sửa theo.

 

http://www.cadviet.com/upfiles/3/72353_vidu10.rar

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Tôi không biết phải post ở đâu vì mù tịt VBA. Tôi có đọc được 1 đoạn code VBScript để writeline vào file như dưới đây:

Function WriteLineToFile

Const ForReading = 1, ForWriting = 2

Dim fso, f

Set fso = CreateObject("Scripting.FileSystemObject")

Set f = fso.OpenTextFile("c:\testfile.txt", ForWriting, True)

f.WriteLine "Hello world!"

f.WriteLine "VBScript is fun!"

Set f = fso.OpenTextFile("c:\testfile.txt", ForReading)

WriteLineToFile = f.ReadAll

End Function

Bác nào rành 2 ngôn ngữ có thể chuyển giùm tôi đoạn code trên sang LSP, xin cám ơn!

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

xin chào mọi người.mình có 1 chương trình vba viết để xuất tọa độ từ cad sang excel .nhưng mỗi khi thực hiện lệnh nó lại bắt đầu bằng stt là 1 ,có ai có thể sửa dùm mình là có thể nhập trực tiếp stt cho nó kohttp://www.cadviet.com/upfiles/3/52714_module_1.rar

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

chào mọi người .mình có 1 đoạn vba dùng để xuất tọa độ từ cad sang excel.Nhưng mỗi lần thực hiện nó lại bắt đầu từ stt là 1,các bạn có cách nào chỉnh sửa để mình có thể nhập trực tiêp tên điểm vào ko và sau đó chương trình sẽ tự động tính theo tăng dầnhttp://www.cadviet.com/upfiles/3/52714_module_2.rar

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Nhờ các anh sửa giup em cái code này! Thank nhiều!

Sub chon()
On Error GoTo 0
Dim p, p1 As Variant
Dim x, x1 As Double
Dim chon As String


On Error GoTo thoat
chon1:
Do
p = ThisDrawing.Utility.GetPoint(, vbCrLf & "Chon 1: ")
x = p(0)
MsgBox x
Loop

On Error GoTo thoat
chon2:
Do
p1 = ThisDrawing.Utility.GetPoint(, vbCrLf & "Chon 2: ")
x1 = p1(0)
MsgBox x1
Loop

thoat:
chon = ThisDrawing.Utility.GetString(False, vbCrLf & " Chon lai ko? ")
If chon = "1" Then
GoTo chon1
ElseIf chon = "2" Then
GoTo chon2
Else
GoTo end_sub
End If

end_sub:
End Sub

 

Sub chon()
On Error GoTo 0
Dim p, p1 As Variant
Dim x, x1 As Double
Dim chon As String
 
 
On Error GoTo thoat
chon1:
Do
p = ThisDrawing.Utility.GetPoint(, vbCrLf & "Chon 1: ")
x = p(0)
MsgBox x
Loop
 
On Error GoTo thoat
chon2:
Do
p1 = ThisDrawing.Utility.GetPoint(, vbCrLf & "Chon 2: ")
x1 = p1(0)
MsgBox x1
Loop
 
thoat:
chon = ThisDrawing.Utility.GetString(False, vbCrLf & " Chon lai ko? ")
If chon = "1" Then
GoTo chon1
ElseIf chon = "2" Then
GoTo chon2
Else
GoTo end_sub
End If
 
end_sub:
End Sub
 
Sub chon()
On Error GoTo 0
Dim p, p1 As Variant
Dim x, x1 As Double
Dim chon As String
 
 
On Error GoTo thoat
chon1:
Do
p = ThisDrawing.Utility.GetPoint(, vbCrLf & "Chon 1: ")
x = p(0)
MsgBox x
Loop
 
On Error GoTo thoat
chon2:
Do
p1 = ThisDrawing.Utility.GetPoint(, vbCrLf & "Chon 2: ")
x1 = p1(0)
MsgBox x1
Loop
 
thoat:
chon = ThisDrawing.Utility.GetString(False, vbCrLf & " Chon lai ko? ")
If chon = "1" Then
GoTo chon1
ElseIf chon = "2" Then
GoTo chon2
Else
GoTo end_sub
End If
 
end_sub:
End Sub
 
Sub chon()
On Error GoTo 0
Dim p, p1 As Variant
Dim x, x1 As Double
Dim chon As String
 
 
On Error GoTo thoat
chon1:
Do
p = ThisDrawing.Utility.GetPoint(, vbCrLf & "Chon 1: ")
x = p(0)
MsgBox x
Loop
 
On Error GoTo thoat
chon2:
Do
p1 = ThisDrawing.Utility.GetPoint(, vbCrLf & "Chon 2: ")
x1 = p1(0)
MsgBox x1
Loop
 
thoat:
chon = ThisDrawing.Utility.GetString(False, vbCrLf & " Chon lai ko? ")
If chon = "1" Then
GoTo chon1
ElseIf chon = "2" Then
GoTo chon2
Else
GoTo end_sub
End If
 
end_sub:
End Sub
 

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

có ai có phần mềm tự động hóa vẽ dầm bằng vba trong cad không cho mình xin tham khảo với,mình đang làm đồ án tốt nghiệp chuyên ngành tin xây dựng mà thiếu tài liệu tham khảo quá

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Đây là ví dụ trong help VBA (vẽ circle có tâm là điểm (2 2 0) bán kính là 4, sau đó zoom:

Sub Example_SendCommand()
' This example sends a command for evaluation to the AutoCAD command line
' of a particular drawing

' Create a Circle in the active drawing and
' zoom to display the entire circle
ThisDrawing.SendCommand "_Circle" & vbCr & "2,2,0" & vbCr & "4" & vbCr
ThisDrawing.SendCommand "_zoom" & vbCr & "a" & vbCr

' Refresh view
ThisDrawing.Regen acAllViewports

MsgBox "A circle command has been sent to the command line of the current drawing."
End Sub

 

Tôi muốn hỏi: điểm trong lisp thì ghi là '(2 2 0), còn VBA thì ghi là "2,2,0". Tập hợp chọn trong lisp, ví dụ ghi là <Select objects: 19>, vậy trong VBA ghi như thế nào?

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Mình chưa hiểu ý lắm. trong VBA dùng Sencommand ko được tiện như lisp. Việc lựa chọn các đối tượng phải qua bộ lọc và trả về kết quả thôi

Tức là có 1 tập chọn, bây giờ ví dụ dùng sendcommand để copy chúng thì cách ghi tập chọn đó như thế nào (tương tự như cách ghi point ở trên)?

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Chào các bác trong Gia đình Cadviet nhé !

Em là dân thi công, nhưng không may đợt này lại bị trên giao ngồi nhà làm nội nghiệp mà món này thì lâu rồi em cũng ít làm đến, mỏi quá các bác ạ. Vậy nên hôm nay mạo muội đến gõ cửa các bác, nhờ các bác giúp đỡ em tý ạ. Em vẫn nghe giang hồ đồn có một liên kết gì đó giữa Cad và Excel, cụ thể là em sẽ thao tác mọi vấn đề trên Cad, và muốn có file kết quả ở trên Excel (nhưng là vào những vị trí mình y/c) ví dụ đơn giản như mình đang tính khối lượng trong phần đào nền hoặc đắp nền vậy. em muốn có bảng tính diện tích và nếu có thể thì chạy luôn sang file khối lượng nựa có được không ạ? Các bác xem có cách nào giúp em với? lâu nay em toàn phải thao tác trên cad, dùng lệnh (di hoặc dli rồi alt tab) nên tốc độ làm hồ sơ của em chậm quá các bác ạ. Em gửi file mẫu lên các bác giúp em nhé ? Tuyến của em có 1 nút giao ngã 7 nữa, em đang bí quá mong các bác giúp đỡ ạ. Các bác xem nếu được thì alo cho em vào số 0975558683 hoặc email: maihaitan@gmail.com ạ, em cảm ơn các bác rất nhiều ạ

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Chào các anh trên forrum cadviet e có sưu tầm được list thống kê cốt thép nhưng không sử dụng được chức năng xuất sang Excel để E lọc KL thép theo từng loại đường kính của thép hoặc các bác viết giúp E một list lọc KL của từng loại đường kính thép của Bảng TKT này trên cad được không ạ (tức là không phải xuất sang Excel nữa)

Cám ơn các anh nhiều

List thống kê cốt thép: http://www.cadviet.com/upfiles/4/21117_tk_vinaconex.rar

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Xin chào A.C.E trên diễn đàn.

Mình có vấn đề như sau:

- Mình viết code VBA để xuất text từ cad sang excell. Nhưng không biết bị lỗi gì mà xuất mãi không đươc.

- Mình đưa đoạn code và file cad, file excell bên dưới. A.C.E xem và giúp mình nhe (ví dụ ở đây mình muốn xuất chữ jjj trong cad qua excell:

 

http://www.cadviet.com/upfiles/4/127038_file_cad_va_excell.rar

 

Sub changetexttoexcel()
On Error Resume Next
    Dim ssetObj As AcadSelectionSet
    Set ssetObj = ThisDrawing.SelectionSets("mysell")
    If Err <> 0 Then
    Err.Clear
    Set ssetObj = ThisDrawing.SelectionSets.Add("mysell")
    Else
    ssetObj.Clear
    End If
    ' Add to the selection set all the objects that lie within a fence
    Dim mode As Integer
    Dim pointsArray(0 To 5) As Double
    mode = acSelectionSetFence
    pointsArray(0) = 0: pointsArray(1) = 10: pointsArray(2) = 0
    pointsArray(3) = 30: pointsArray(4) = 20: pointsArray(5) = 0
    
    Dim gpCode(0) As Integer
    gpCode(0) = 0
    Dim dataValue(0) As Variant
    dataValue(0) = "text"
    ssetObj.SelectByPolygon mode, pointsArray, gpCode, dataValue
    Dim ent As AcadText
    For Each ent In ssetObj
    ent.color = acBlue
    Next ent
    
    
  Dim appex As Excel.Application
  Set appex = New Excel.Application
  appex.Visible = True
  Dim WB As Excel.Workbook
  Dim WS As Excel.Worksheet
  Set WB = appex.Workbooks.Open("D:\practicvb\practic\file excel\abc.xlsx")
  Set WS = WB.Worksheets(1)
  Dim i As Integer
  For i = 1 To ssetObj.Count Step 1
  
   WS.Cells(2, 0 + i) = ssetObj.Item(i).Text
   
   Next
   End Sub
Chỉnh sửa theo huynhtrung209

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Xin chào A.C.E trên diễn đàn.


Mình có vấn đề như sau:


- Mình viết code VBA để xuất text từ cad sang excell. Nhưng không biết bị lỗi gì mà xuất mãi không đươc.


- Mình đưa đoạn code và file cad, file excell bên dưới. A.C.E xem và giúp mình nhe (ví dụ ở đây mình muốn xuất chữ jjj trong cad qua excell:


http://www.cadviet.com/upfiles/4/127038_file_cad_excell_vba.rar


 


Sub changetexttoexcel()

On Error Resume Next

    Dim ssetObj As AcadSelectionSet

    Set ssetObj = ThisDrawing.SelectionSets("mysell")

    If Err <> 0 Then

    Err.Clear

    Set ssetObj = ThisDrawing.SelectionSets.Add("mysell")

    Else

    ssetObj.Clear

    End If

    ' Add to the selection set all the objects that lie within a fence

    Dim mode As Integer

    Dim pointsArray(0 To 5) As Double

    mode = acSelectionSetFence

    pointsArray(0) = 0: pointsArray(1) = 10: pointsArray(2) = 0

    pointsArray(3) = 30: pointsArray(4) = 20: pointsArray(5) = 0

    

    Dim gpCode(0) As Integer

    gpCode(0) = 0

    Dim dataValue(0) As Variant

    dataValue(0) = "text"

    ssetObj.SelectByPolygon mode, pointsArray, gpCode, dataValue

    Dim ent As AcadText

    For Each ent In ssetObj

    ent.color = acBlue

    Next ent

    

    

  Dim appex As Excel.Application

  Set appex = New Excel.Application

  appex.Visible = True

  Dim WB As Excel.Workbook

  Dim WS As Excel.Worksheet

  Set WB = appex.Workbooks.Open("D:\practicvb\practic\file excel\abc.xlsx")

  Set WS = WB.Worksheets(1)

  Dim i As Integer

  For i = 1 To ssetObj.Count Step 1

  

   WS.Cells(2, 0 + i) = ssetObj.Item(i).Text

   

   Next

   End Sub

 

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Dim ExcelApp As Object  '3.Khai bao doi tuong goc Excel
Dim Wkb As Object    '4.Khi bao doi tuong Workbook
Dim sht As Object    '5.Khai bao doi tuong Worksheets
Sub changetexttoexcel()
On Error Resume Next
    Dim ssetObj As AcadSelectionSet
    Set ssetObj = ThisDrawing.SelectionSets("mysell")
    If Err <> 0 Then
    Err.Clear
    Set ssetObj = ThisDrawing.SelectionSets.Add("mysell")
    Else
    ssetObj.Clear
    End If
    Dim gpCode(0) As Integer
    gpCode(0) = 0
    Dim dataValue(0) As Variant
    dataValue(0) = "text"
    ssetObj.SelectOnScreen gpCode, dataValue
    Dim ent As AcadText
    For Each ent In ssetObj
    ent.color = acBlue
    Next ent
    Call ConectExcel
  Set Wkb = ExcelApp.Workbooks.Open("D:\abc.xlsx")
  ExcelApp.Visible = True
  Set sht = Wkb.Worksheets(1)
  Dim i As Integer
  For i = 0 To ssetObj.Count - 1
  
   sht.Cells(i + 1, 2) = ssetObj.Item(i).TextString
   
   Next
   End Sub

'Thu thuc khoi dong Excel
Sub ConectExcel()
    On Error Resume Next
    Set ExcelApp = GetObject(, "Excel.Application")
    If Err <> 0 Then
        Err.Clear
        Set ExcelApp = CreateObject("Excel.Application")
        If Err <> 0 Then
            MsgBox "Impossible to initialize an Excel.", vbExclamation
            End
        End If
    End If
    AppActivate ExcelApp.Caption
End Sub

Thử code này nhé.

Nếu code của bạn có lẽ sai ở đây

  For i = 1 To ssetObj.Count Step 1
   WS.Cells(2, 0 + i) = ssetObj.Item(i).Text => ssetObj.Item(i).TextString
   Next
Chỉnh sửa theo NguyenNgocSon
  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Mình cần chuyển start point và hướng của một hình kín bất kỳ. Mình đã serch thì chỉ tìm được lisp chuyển cho polyline thôi. 

Thanks mod rất nhiều

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Mình nhờ các bạn pro vba giúp mình viết đoạn code giúp mình với

Mình có file excel xuăt từ sap2000 ra có các thanh đối xứng nhau qua trục z, x,y, mình muốn viếtt code lọc các thanh có có cùng có cùng tính chất giống nhau đối xứng qua các trục x,y, z vào 1 nhóm để tiện quản lý các thanh trong sap2000. nhờ các pro giúp với, file dính kèm là 1 file dữ liệu xuất từ sap2000 ra, và 1 file yêu cầu về nhóm các thanh có số thứ tự và toạ độ đối xứng được xếp vào 1 nhóm.http://www.cadviet.com/upfiles/4/61095_yeu_cau_code_2.rar

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Mời các bạn đưa ra các yêu cầu viết các hàm VBA trong Autocad để các thành viên đưa lên

 

Dear các bác, e đang vẽ 1 autocad quản lý rất nhiều các block dữ liệu bằng excel nên e muốn hỏi các bác cách xài VBA thế nào ( hàm ...) e k rành về VBA lắm. E đã định các địa chỉ bằng attribute sắp xếp theo cột ( 8,10 địa chỉ trong 1 cột). Các bác có kinh nghiệm chỉ e hàm viết để chạy với hay cho e 1 bản vẽ ví dụ để e tham khảo cũng dc. E cảm ơn

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Tạo một tài khoản hoặc đăng nhập để nhận xét

Bạn cần phải là một thành viên để lại một bình luận

Tạo tài khoản

Đăng ký một tài khoản mới trong cộng đồng của chúng tôi. Điều đó dễ mà.

Đăng ký tài khoản mới

Đăng nhập

Bạn có sẵn sàng để tạo một tài khoản ? Đăng nhập tại đây.

Đăng nhập ngay


×