Đến nội dung


Hình ảnh
- - - - -

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


  • Please log in to reply
124 replies to this topic

#101 vtd_xd

vtd_xd

    biết vẽ circle

  • Members
  • PipPip
  • 38 Bài viết
Điểm đánh giá: 5 (bình thường)

Đã gửi 12 April 2012 - 01:36 PM

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
  • 0
Chuc vui ve

#102 tvxdgt

tvxdgt

    Chưa sử dụng CAD

  • Members
  • Pip
  • 3 Bài viết
Điểm đánh giá: 1 (bình thường)

Đã gửi 18 April 2012 - 04:49 PM


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
  • 1

#103 tvxdgt

tvxdgt

    Chưa sử dụng CAD

  • Members
  • Pip
  • 3 Bài viết
Điểm đánh giá: 1 (bình thường)

Đã gửi 18 April 2012 - 04:50 PM

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

  • 0

#104 phantuhuong

phantuhuong

    biết dimstyle

  • Moderator
  • PipPipPipPipPip
  • 383 Bài viết
Điểm đánh giá: 200 (khá)

Đã gửi 19 April 2012 - 12:02 PM

<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>
  • 0
Bồi dưỡng Excel & VBA cho các đơn vị ở Hà Nội và khu vực lân cận

Từng bước loại đồ Tàu ra khỏi cuộc sống!


#105 banbe0274

banbe0274

    biết vẽ pline

  • Members
  • PipPip
  • 66 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 23 April 2012 - 09:11 AM

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.c...2353_vidu10.rar
  • 0

#106 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 5454 Bài viết
Điểm đánh giá: 2626 (tuyệt vời)

Đã gửi 03 October 2012 - 09:40 AM

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!
  • 0

* Chỉ nên yêu cầu Lisp khi bạn làm việc đó mất cả ngày nhưng họ chỉ viết 1 giờ. Đừng nêu yêu cầu Lisp khi bạn chỉ làm 1 giờ nhưng bắt họ phải mất cả ngày.

* Nhờ viết lisp cũng như đi khám bệnh. Chỉ gởi căn cước và than sắp chết thì không bác sỹ nào cứu sống được.


#107 xuanb3

xuanb3

    Chưa sử dụng CAD

  • Members
  • Pip
  • 4 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 27 November 2013 - 12:41 PM

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.c...14_module_1.rar


  • 0

#108 xuanb3

xuanb3

    Chưa sử dụng CAD

  • Members
  • Pip
  • 4 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 27 November 2013 - 12:47 PM

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.c...14_module_2.rar


  • 0

#109 th_kid2001

th_kid2001

    Chưa sử dụng CAD

  • Members
  • Pip
  • 1 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 09 December 2013 - 12:37 PM

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
 

  • 0

#110 binh06d1

binh06d1

    biết pan

  • Members
  • Pip
  • 8 Bài viết
Điểm đánh giá: -3 (bình thường)

Đã gửi 09 December 2013 - 07:24 PM

viết giúp mình chương trình này, tìm trên mạng mà không web nào có 

http://hatangkythuat...V/NCKH/ND-3.HTM


  • -1

#111 binh06d1

binh06d1

    biết pan

  • Members
  • Pip
  • 8 Bài viết
Điểm đánh giá: -3 (bình thường)

Đã gửi 13 December 2013 - 07:16 PM

không ai giúp đỡ hết ah?


  • -1

#112 locpun1

locpun1

    Chưa sử dụng CAD

  • Members
  • Pip
  • 1 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 20 December 2013 - 05:27 PM

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á


  • 0

#113 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 5454 Bài viết
Điểm đánh giá: 2626 (tuyệt vời)

Đã gửi 27 December 2013 - 02:48 PM

Đâ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?


  • 0

* Chỉ nên yêu cầu Lisp khi bạn làm việc đó mất cả ngày nhưng họ chỉ viết 1 giờ. Đừng nêu yêu cầu Lisp khi bạn chỉ làm 1 giờ nhưng bắt họ phải mất cả ngày.

* Nhờ viết lisp cũng như đi khám bệnh. Chỉ gởi căn cước và than sắp chết thì không bác sỹ nào cứu sống được.


#114 NguyenNgocSon

NguyenNgocSon

    biết dimbaseline

  • Members
  • PipPipPipPipPip
  • 368 Bài viết
Điểm đánh giá: 39 (tàm tạm)

Đã gửi 27 December 2013 - 05:41 PM

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


  • 0

#115 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 5454 Bài viết
Điểm đánh giá: 2626 (tuyệt vời)

Đã gửi 27 December 2013 - 06:31 PM

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)?


  • 0

* Chỉ nên yêu cầu Lisp khi bạn làm việc đó mất cả ngày nhưng họ chỉ viết 1 giờ. Đừng nêu yêu cầu Lisp khi bạn chỉ làm 1 giờ nhưng bắt họ phải mất cả ngày.

* Nhờ viết lisp cũng như đi khám bệnh. Chỉ gởi căn cước và than sắp chết thì không bác sỹ nào cứu sống được.


#116 tan_xdct7

tan_xdct7

    biết pan

  • Members
  • Pip
  • 5 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 29 December 2013 - 10:27 AM

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 ạ


  • 0

#117 huunhantvxdts

huunhantvxdts

    biết dimbaseline

  • Members
  • PipPipPipPipPip
  • 366 Bài viết
Điểm đánh giá: 53 (tàm tạm)

Đã gửi 30 December 2013 - 08:17 AM

bạn nên đưa file đó lên đã chứ. chứ đoán mò khó lòng mọi người giúp được. 


  • 0

#118 thaihc

thaihc

    biết zoom

  • Members
  • Pip
  • 15 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 27 February 2015 - 10:28 PM

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.c...k_vinaconex.rar


  • 0

#119 huynhtrung209

huynhtrung209

    Chưa sử dụng CAD

  • Members
  • Pip
  • 4 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 16 March 2015 - 09:02 PM

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.c...d_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

Bài viết đã được chỉnh sửa nội dung bởi huynhtrung209: 16 March 2015 - 09:10 PM

  • 0

#120 huynhtrung209

huynhtrung209

    Chưa sử dụng CAD

  • Members
  • Pip
  • 4 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 16 March 2015 - 09:18 PM

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.c..._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
 

  • 0