gia_bach
-
Số lượng nội dung
1625 -
Đã tham gia
-
Lần ghé thăm cuối
-
Ngày trúng
123
Bài đăng được đăng bởi gia_bach
-
-
AutoLISP, khi mình nghĩ nó rất là đơn giản thì ... đúng vậy.
(defun C:DMTC (/ doc col) (defun mip:layer-status-restore () (foreach item *MIP_LAYER_LST* (if (not (vlax-erased-p (car item))) (vl-catch-all-apply '(lambda () (vla-put-lock (car item) (cdr (assoc "lock" (cdr item)))) (vla-put-freeze (car item) (cdr (assoc "freeze" (cdr item))) ) ) ) ) ) (setq *MIP_LAYER_LST* nil)) (defun mip:layer-status-save () (setq *MIP_LAYER_LST* nil) (vlax-for item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object)) ) (setq *MIP_LAYER_LST* (cons (list item (cons "freeze" (vla-get-freeze item)) (cons "lock" (vla-get-lock item)) ) *MIP_LAYER_LST* ) ) (vla-put-lock item :vlax-false) (if (= (vla-get-freeze item) :vlax-true) (vl-catch-all-apply '(lambda () (vla-put-freeze item :vlax-false)) ) ) ) ) (defun ChangeAllObjectsColor (Doc Color) (vlax-for Blk (vla-get-Blocks Doc) (if (= (vla-get-IsXref Blk) :vlax-false) (vlax-for Obj Blk (entmod (append (entget (vlax-vla-object->ename obj)) color)) ) ) )) (vl-load-com) (setq doc (vla-get-activedocument (vlax-get-acad-object))) (vla-startundomark doc) (mip:layer-status-save) (if (setq col (acad_truecolordlg 1)) (ChangeAllObjectsColor doc col) ) (mip:layer-status-restore) (vla-endundomark doc) (princ))
- 1
-
18 phút trước, ZIS3 đã nói:Việt Nam có bộ EnjiCAD dựa trên core IntelliCAD, ra cũng được tầm 5 năm rồi. Cho mấy anh amateur không cần dùng đến tools thì dùng cũng được. Mặc dù quảng cáo là hỗ trợ LISP / ARX / .NET / VBA nhưng thuê ai code lại bây giờ, kể cả code được nhưng chưa chắc đã chạy ổn.
Tranh thủ quảng cáo chút, từ ZWCAD đến BricsCAD, IntelliCAD, GtarsCAD ai có nhu cầu em cân hết nhé.
-
Vào lúc 12/5/2024 tại 10:48, cadok đã nói:Góc nhờ vả các cao thủ,
Chào các bạn, mình có bản vẽ có khoảng 40 block ATT, trong block ATT có một đối tượng cuối cùng là diện tích (S_m2). Hiện S_m2 này là một đối tượng Field, đã đc định dạng dấu thập phân là dấu "phảy" ví dụ 4,22
Bây h mình muốn nó là 4.22
Mình sửa bằng tay, phải dô trong Field mới sủa dc và lâu quá
Nhớ mấy cao thủ có cách giúp dùm, xin cảm ơn, mình có đính kèm file Cad
Vô "Additional Format ..." chọn "Period" như hình đính kèm.
- 1
-
47 phút trước, cuongtk2 đã nói:Trường hợp bạn chỉ dùng cho 1 đối tượng đơn lẻ, mình sẽ chỉnh sửa cho nó thành ChangeStartPoint với điểm mút gần với vị trí pick thành start point.
Nếu "chỉ một đối tượng đơn lẻ" thì dùng lệnh Pedit cho nhanh.
- 1
-
CPU Core-i5 10400 RAM: 16GB
- AutoCAD 2016: 3.3 s
- AutoCAD 2022: 2.0 s
- BricsCAD V21: 1.5 s
@cuongtk2 : thử thay thế (ACET-SS-TO-LIST bằng (repeat (setq i (sslength ss)) (setq ent (ssname ss (setq i (1- I))))
thì CAD 2016 có cải thiện tốc độ (2.5 giây), nhưng tốc độ trên CAD 2022 gần như không thay đổi.
- 1
-
1 giờ} trướ}c, Leeboow đã nói:Đúng là không có ý nghĩa thực tế nhiều. tuy nhiên khách hàng là thượng đế nên mình chỉ chiều theo ý họ thôi bác. hihi.
Chứ em cũng thấy nó vô nghĩa ^^
Nó liên quan đến "CAD standard".
22 phút trước, cuongtk2 đã nói:Với autolisp , bạn không thể làm ở hàng loạt bản vẽ một cách im lìm. Phải dùng .NET
ObjectDBX / VisualLISP xử được.
-
Hồi mới vào nghề, cứ block Atts là nổ (explode) ra, rồi sử dụng lisp cộng text mà làm, cứ thế cũng kiếm được chút cơm các bác ạ !
Giờ chắc lisp này đáp ứng đc y/cầu của thớt:
(defun c:PhanLoaiThep (/ lst ss ) ;; By : Gia_Bach, www.CadViet.com (defun Get_TrongLuong (ent / dk tl) ; DK TL (foreach att (vlax-invoke (vlax-Ename->Vla-Object ent) 'GetAttributes) (cond ( (= "DK" (vla-get-TagString Att) ) (setq dk (vla-get-TextString Att))) ( (= "TL" (vla-get-TagString Att) ) (setq tl (vla-get-TextString Att))) ( t nil) ) ) (if (and dk tl) (progn (if(= (substr dk 1 1) "`") (setq dk (substr dk 2))) (if(= (substr dk 1 3) "%%c") (setq dk (substr dk 4))) (cons dk (distof tl))) )) (if (setq ss (ssget(list (cons 0 "INSERT")(cons 66 1)(cons 2 "NGHIA_THKE")))) (progn (setq i -1) (while (setq ent (ssname ss (setq i (1+ i)))) (if (setq DkTl (Get_TrongLuong ent) ) (progn (setq dk (car dktl) tl (cdr dktl)) (if (setq asoc (assoc dk lst)) (setq lst (subst (cons dk (+ tl (cdr asoc)) ) asoc lst)) (setq lst (append lst (list dktl)) )) ) )) ; phan loai Thep dk <=10 =?, thep dk <=18 = ?, va thep dk>18=? (setq dk10 0 dk18 0 dk50 0) (foreach dktl lst (setq dk (distof (car dktl))) (cond ((<= dk 10) (setq dk10 (+ dk10 (cdr dktl)))) ((<= dk 18) (setq dk18 (+ dk18 (cdr dktl)))) (t (setq dk50 (+ dk50 (cdr dktl))) ))) (if (> dk10 0) (princ (strcat "\nD/kinh <=10, TL: "(rtos dk10)) ) ) (if (> dk18 0) (princ (strcat "\nD/kinh <=18, TL: "(rtos dk18)) ) ) (if (> dk50 0) (princ (strcat "\nD/kinh >18, TL: "(rtos dk50)) ) ) ) ) (princ))
- 1
- 2
-
Dùng lệnh có sẵn của CAD: PASTEORIG
- 1
- 1
-
Vào lúc 1/1/2024 tại 13:22, tronganh210494@gmail.com đã nói:Tất nhiên là có ạ, đây là file e lưu trước đó lúc chưa update thêm vào lisp và chưa đặt password ạ. Giờ update lại nhiều quá thì mất nhiều thời gian nên e mới lên đây nhờ lấy lại pass ạ. E cảm ơn bác.
OK, pass xem inbox nhé.
- 2
-
7 giờ trước, tronganh210494@gmail.com đã nói:Chào các bác.
Tình hình là lần trước e có cài password cho file VBA autocad mà nay muốn sửa mà quên mất không nhớ đặt là gì.
Các bác giúp e xóa password được không ạ.
E xin cảm ơn ạ!Có gì chứng minh file này là của bạn không?
- 3
-
Đây là một cách:
(defun c:AI () (PROMPT"\nSelect texts to change to -ARIAL") (if (and (setq ss (ssget)) (CreateTextStyle "-ARIAL" "arial.ttf" 0 1) ) (progn ;(setq ss (ssget)) ;(command "-style" "-ARIAL" "Arial" "0" "1" "0" "" "") (setq c 0) (if ss (setq e (ssname ss c))) (while e (setq e (entget e)) (if (= (cdr (assoc 0 e)) "TEXT") (progn (setq txt "-ARIAL") (setq e (subst (cons 7 txt) (assoc 7 e) e)) (entmod e) )) (setq c (1+ c)) (setq e (ssname ss c)) ))) (Princ))
- 1
- 1
-
Vào lúc 29/8/2023 tại 14:45, united đã nói:Em tạo style bằng:
(command "-style" "-ARIAL" "Arial" "0" "1" "0" "" "")
Kết quả thu được là stype -ARIAL với Font Name "Arial CYR"
Anh cho em hỏi làm sao để thu được Font Name "Arial"?
Em cảm ơn anh!
Thử chạy lisp này:
(CreateTextStyle "-ARIAL" "arial.ttf" 0 0.9)
(defun CreateTextStyle (StyleName Font Height WidthFactor / doc txtStyles Obj Font_Path TypeFace Bold Italic charSet PitchandFamily) (vl-load-com) (setq doc (vla-get-activedocument (vlax-get-acad-object)) txtStyles (vla-get-textstyles doc) ) (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-item (list txtStyles StyleName))) (setq Obj (vla-add txtStyles StyleName)) (setq Obj (vla-Item txtStyles StyleName))) (if Obj (progn (if (= (strcase (vl-filename-extension Font)) (strcase ".ttf")) (if (not (setq Font_Path (findfile (strcat (getenv "WINDIR") "\\fonts\\" Font)))) (setq Font_Path (findfile Font)) ) ) (if Font_Path (progn (setq DestinationTypeFace (vl-filename-base Font)) (vla-GetFont Obj 'typeFace 'Bold 'Italic 'charSet 'PitchandFamily) (vla-put-fontfile Obj Font_Path) (vla-SetFont Obj DestinationTypeFace Bold Italic charSet PitchandFamily) (vla-put-height Obj Height) (vla-put-width Obj WidthFactor) ) (progn (alert "Couldn't find font path, exiting!") ;(exit) ) ) ) ) Obj )
- 1
-
Sử dụng hàm Quick UnFormat của chú Lee nè.
(defun c:unformat ( / *error* enx idx rgx sel str ) (cond ( (or (vl-catch-all-error-p (setq rgx (vl-catch-all-apply 'vlax-get-or-create-object '("vbscript.regexp")))) (null rgx) ) (princ "\nUnable to interface with RegExp object.") ) ( (setq sel (ssget "_:L" '((0 . "MTEXT")))) (repeat (setq idx (sslength sel)) (setq enx (entget (ssname sel (setq idx (1- idx)))) str (assoc 1 enx) ) (entmod (subst (cons 1 (LM:quickunformat rgx (cdr str))) str enx)) ) ) ) (princ) ) ;; Quick Unformat - Lee Mac ;; Returns a string with all MText formatting codes removed. ;; rgx - [vla] Regular Expressions (RegExp) Object ;; str - [str] String to process (defun LM:quickunformat ( rgx str ) (if (null (vl-catch-all-error-p (setq str (vl-catch-all-apply '(lambda nil (vlax-put-property rgx 'global actrue) (vlax-put-property rgx 'multiline actrue) (vlax-put-property rgx 'ignorecase acfalse) (foreach pair '( ("\032" . "\\\\\\\\") (" " . "\\\\P|\\n|\\t") ("$1" . "\\\\(\\\\[ACcFfHKkLlOopQTW])|\\\\[ACcFfHKkLlOopQTW][^\\\\;]*;|\\\\[ACcFfKkHLlOopQTW]") ("$1$2/$3" . "([^\\\\])\\\\S([^;]*)[/#\\^]([^;]*);") ("$1$2" . "\\\\(\\\\S)|[\\\\](})|}") ("$1" . "[\\\\]({)|{") ("\\$1$2$3" . "(\\\\[ACcFfHKkLlOoPpQSTW])|({)|(})") ("\\\\" . "\032") ) (vlax-put-property rgx 'pattern (cdr pair)) (setq str (vlax-invoke rgx 'replace str (car pair))) ) ) ) ) ) ) str ) ) (vl-load-com)
- 1
-
Có thể là do trước đây bạn sài bản 32 bit (win 7), nay sài win 10 thông thường là bản 64bit, nên VBA có 1 số hàm không chạy được.
Cad 2020 chỉ có bản 64bit.
-
Đúng là giá của AutoCAD quá cao, để giảm chi phí một số cty (bao gồm cả cty Viet Nam) chuyển qua sử dụng các phiên bản CAD khác như: BricsCAD, GstarCAD, ZWCAD, IntelliCAD, ...
Các bản CAD này đáp ứng được các yêu cầu cơ bản của 1 phần mềm vẽ kỹ thuật và có thể chạy trên các máy tính cấu hình thấp.
Tuy nhiên với các dự án lớn hay 3D (file từ vài chục đến trên 100 Mb), thì AutoCAD chạy vẫn mượt hơn (một phần do yêu cầu cấu hình máy tính cao).Về mặt lập trình, các CAD này cũng hỗ trợ các ngôn ngữ như LISP, VBA, .NET ...
Đặc biệt với .NET, chúng ta có thể tái sử dụng code viết cho AutoCAD để compile cho các CAD này.https://www.dropbox.com/s/e3l7k9tcwx11a3v/MultiVersion.mp4
-
9 giờ trước, quyenpv đã nói:Có thể tự chọn điểm vẽ và hướng vẽ không anh
update:
- chọn điểm vẽ.
- hướng vẽ: có thể sử dụng hàm GetNumberFromUser
hoặc yêu cầu user pick thêm 1 điểm và tính góc qua 2 điểm này.
code nhiều, thử nhiều lần sẽ lên tay thôi.
-
Góc tính theo radian:
Public Function PolarPoint(ByVal basePt As Point2d, ByVal angle As Double, ByVal distance As Double) As Point2d Dim x As Double = basePt(0) + distance * Math.Cos(angle) Dim y As Double = basePt(1) + distance * Math.Sin(angle) Dim point As Point2d = New Point2d(x, y) Return point End Function <CommandMethod("DrawLines2")> Public Sub DrawPLines() Dim doc As Document = Application.DocumentManager.MdiActiveDocument Dim db As Database = doc.Database Dim ed As Editor = doc.Editor ' Lấy số lượng đường cần vẽ từ người dùng Dim numLines As Integer = 7 ' GetNumberFromUser("Nhập số lượng đường (từ 1 đến 12): ", 1, 12) ' Lấy khoảng cách giữa các đường từ người dùng Dim distance As Double = 12 ' GetNumberFromUser("Nhập khoảng cách giữa các đường (số nhỏ nhất là 3): ", 3, Double.MaxValue) ' Danh sách mã màu cho các đường Dim colors() As Integer = {160, 30, 94, 15, 253, 255, 10, 250, 50, 202, 220, 130} ' Kiểm tra nếu Layer "SODODAUNOI" chưa tồn tại, tạo mới 'If Not LayerExists("SODODAUNOI") Then ' CreateLayer("SODODAUNOI") 'End If Dim length As Double = distance * 5 Dim angle As Double = System.Math.PI / 3 Dim insertPt As Point3d Dim ppr As PromptPointResult = ed.GetPoint("\nInsertion point: ") If ppr.Status <> PromptStatus.OK Then Return insertPt = ppr.Value Using trans As Transaction = db.TransactionManager.StartTransaction() Dim btr As BlockTableRecord = trans.GetObject(db.CurrentSpaceId, OpenMode.ForWrite) ' Vẽ đường thứ nhất Dim startPoint As New Point2d(insertPt.X, insertPt.Y) Dim endPoint As New Point2d() endPoint = PolarPoint(startPoint, angle, length) Dim pLine As New Polyline() pLine.AddVertexAt(0, New Point2d(startPoint.X, startPoint.Y), 0, 0, 0) pLine.AddVertexAt(1, New Point2d(endPoint.X, endPoint.Y), 0, 0, 0) pLine.ColorIndex = colors(0) 'pLine.Layer = "SODODAUNOI" btr.AppendEntity(pLine) trans.AddNewlyCreatedDBObject(pLine, True) ' Vẽ các đường tiếp theo For i As Integer = 1 To numLines - 1 startPoint = PolarPoint(startPoint, angle - System.Math.PI / 2, distance) endPoint = PolarPoint(endPoint, angle - System.Math.PI / 2, distance) pLine = New Polyline() pLine.AddVertexAt(0, startPoint, 0, 0, 0) pLine.AddVertexAt(1, endPoint, 0, 0, 0) pLine.ColorIndex = colors(i Mod colors.Length) 'pLine.Layer = "SODODAUNOI" btr.AppendEntity(pLine) trans.AddNewlyCreatedDBObject(pLine, True) ' Cập nhật điểm khởi đầu cho đường tiếp theo 'startPoint = New Point2d(startPoint.X, startPoint.Y + distance) 'endPoint = New Point2d(endPoint.X, endPoint.Y + distance) Next trans.Commit() End Using ed.WriteMessage("Đã vẽ xong các đường PLINE.") End Sub
-
Bạn tham khảo code :
<CommandMethod("DrawLines2")> Public Sub DrawPLines() Dim doc As Document = Application.DocumentManager.MdiActiveDocument Dim db As Database = doc.Database Dim ed As Editor = doc.Editor ' Lấy số lượng đường cần vẽ từ người dùng Dim numLines As Integer = 7 ' GetNumberFromUser("Nhập số lượng đường (từ 1 đến 12): ", 1, 12) ' Lấy khoảng cách giữa các đường từ người dùng Dim distance As Double = 12 ' GetNumberFromUser("Nhập khoảng cách giữa các đường (số nhỏ nhất là 3): ", 3, Double.MaxValue) ' Danh sách mã màu cho các đường Dim colors() As Integer = {160, 30, 94, 15, 253, 255, 10, 250, 50, 202, 220, 130} '' Kiểm tra nếu Layer "SODODAUNOI" chưa tồn tại, tạo mới 'If Not LayerExists("SODODAUNOI") Then ' CreateLayer("SODODAUNOI") 'End If Dim length As Double = distance * 5 Using trans As Transaction = db.TransactionManager.StartTransaction() Dim btr As BlockTableRecord = trans.GetObject(db.CurrentSpaceId, OpenMode.ForWrite) ' Vẽ đường thứ nhất Dim startPoint As New Point2d(0, 0) Dim endPoint As New Point2d(length, 0) Dim pLine As New Polyline() pLine.AddVertexAt(0, New Point2d(startPoint.X, startPoint.Y), 0, 0, 0) pLine.AddVertexAt(1, New Point2d(endPoint.X, endPoint.Y), 0, 0, 0) pLine.ColorIndex = colors(0) 'pLine.Layer = "SODODAUNOI" btr.AppendEntity(pLine) trans.AddNewlyCreatedDBObject(pLine, True) ' Vẽ các đường tiếp theo For i As Integer = 1 To numLines - 1 startPoint = New Point2d(startPoint.X, startPoint.Y + distance) endPoint = New Point2d(endPoint.X, endPoint.Y + distance) pLine = New Polyline() pLine.AddVertexAt(0, startPoint, 0, 0, 0) pLine.AddVertexAt(1, endPoint, 0, 0, 0) pLine.ColorIndex = colors(i Mod colors.Length) 'pLine.Layer = "SODODAUNOI" btr.AppendEntity(pLine) trans.AddNewlyCreatedDBObject(pLine, True) ' Cập nhật điểm khởi đầu cho đường tiếp theo 'startPoint = New Point2d(startPoint.X, startPoint.Y + distance) 'endPoint = New Point2d(endPoint.X, endPoint.Y + distance) Next trans.Commit() End Using ed.WriteMessage("Đã vẽ xong các đường PLINE.") End Sub
-
54 phút trước, cuong26 đã nói:trong autocad mình không sử dụng được phím shift, trước đây vẫn bình thường nhưng hôm nay lại không sử dụng được nữa. đã thử gỡ đi và cài đặt lại nhưng vẫn không dùng được, bị lỗi cả 2 phím. các phần mềm khác thì vẫn sử dụng phím shift bình thường. chỉ riêng trong các ứng dụng của autodesk thì lại không sử dụng được. ai có cách khác phục lỗi này không ạ.
Cái này hình như lỗi khi update lên win10.
tham khảo:
https://forums.autodesk.com/t5/autocad-forum/ortho-shift-key-not-working-correctly/td-p/8163935
-
Cám ơn @cuongtk2,
Tôi cũng nghe nói Windows Presentation Foundation (WPF) hỗ trợ UI tốt hơn.
Nhưng thời gian và sức lực có hạn rồi!
Cũng như vì ko có thiết bị (màn 4K) để tận hưởng thành quả nên cứ chần chừ ...
- 1
-
Cám ơn bác đã gợi ý.
.NET có thể thay đổi độ phân giải màn hình.
Tuy nhiên khi ứng dụng vào thực tế thì không khả thi, nó ảnh hưởng rất nhiều đến trải nghiệm của người dùng.
(sự thay đổi của kích thước màn hình quá lớn, từ 4K => full HD và ngược lại).
@7o7: hình như trước đây bác là đồng nghiệp với tôi ?!
-
5 phút trước, Nguyễn Hà Huy đã nói:Bác gửi file demo lên để xem mới biết vấn đề ở đâu chứ
Cám ơn bạn đã quan tâm.
Đã đính kèm dll, tên lệnh: HopThoai4K.
-
Chào anh em CadViet,
Một người quen có nhờ tôi viết 1 tool in ra file PDF, mọi việc xuôn sẻ như nó vốn phải thế.
Tuy nhiên mới đây tôi có nhận được "than phiền" về hộp thoại, nó hiển thị không chính xác (hình bên trái), qua tìm hiểu thì nó chỉ xảy ra khi chạy trên màn hình có độ phân giải 4K (3840x2160).Cho hỏi, có anh em nào đã gặp trường hợp này chưa? (khi sử dụng CAD với màn hình 4K)
Nếu có, cách khắc phục thế nào?Cám ơn anh em đã đọc tin.
PS: đính kèm dll, tên lệnh: HopThoai4K.
Download here: HopThoai4K.zip
-
Lisp Chỉnh sửa Xref
trong AutoLisp
Bạn thay đổi bán kính theo thực tế nhé.
(defun CK:LineWeldF (dd)
(if (not (tblsearch "layer" "WELDF"))
(command "._layer" "n" "WELDF" "c" "Magenta" "WELDF" "l" "continuous" "WELDF" "")
(command "._layer" "c" "Magenta" "WELDF" "")
)
(setvar "clayer" "WELDF")
(setq d1 (getpoint "\nCh\U+1ECDn \U+0111i\U+1EC3m \U+0111\U+1EA7u: ")
d2 (getpoint d1 "\nCh\U+1ECDn \U+0111i\U+1EC3m cu\U+1ED1i: ")
)
(setq rad 100) ; ban kinh duong tron
(setq ang (angle d1 d2)
d3 (polar d1 ang (- (distance d1 d2) rad)))
;(command "LINE" d1 d2 d2 \e)
(command "LINE" d1 d3 "")
)
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)
trong AutoLisp
Đã đăng · Trả lời báo cáo
Thử hàm (vla-Put-StandardScale lyout acScaleToFit)