Chuyển đến nội dung
Diễn đàn CADViet
  • Thông báo

    • Nguyen Hoanh

      CADViet đã hoàn tất nâng cấp   14/09/2017

      Chào các bạn, CADViet đã hoàn tất việc nâng cấp lên phiên bản mới. Tất cả các chức năng đã hoạt động theo kỳ vọng của ban quản trị. Nếu có vấn đề gì cần phản hồi, các bản post ở đây nhé: Trân trọng, Nguyễn Hoành.
Đăng nhập để thực hiện theo  
trangiangnam

Chuyển Ảnh .bmp Sang Dcl

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

lwCrJdS.png

 

Gửi Cả nhà.

Mình mới mày mò viết lisp, có tham khảo trên các diễn dàn,

Có thấy Lee Mac có đoạn code chuyển bmp sang ma trận màu, và dùng hàm hiển thị trên DCL.

Cái này mình cũng từng thấy Bác Thaistreetz có đề cập. nhưng vẫn chưa thấy công cụ nào đưa ra.

Nay mình tìm thấy một đoạn code chuyển được từ Bmp sang ma trận màu nhưng chỉ chạy được cho 24bit.

Link: http://cadxp.com/topic/37160-bitmap-pour-dcl/

Code:

(defun bmp(/ act col fic lst nb pal pos str readbinary hexdec inv)

  ; Lecture d'un fichier binaire
  ; Merci à highflyingbird
  ; Trouvé sur TheSwamp.org
  ; http:/
/www.theswamp.org/index.php?topic=36656.msg417089#msg417089
  ; Modifié par Patrick_35 pour positionner le début de la lecture et la longueur à lire
 
; ReadBinary (fichier position longueur)

  (defun readbinary (fichier position longueur / str wsObj)
    (setq wsObj (vlax-create-object "ScriptControl"))
    (or position
     
(setq position 0)
    )
    (if (or (not longueur) (zerop longueur))
      (setq longueur (- (vl-file-size fichier) position))
    )
    (vlax-put wsObj "language" "VBS")
    (setq str
     
(strcat
       
"Function ReadBinary(fichier)
        Const adTypeBinary = 1
        Dim stream, xmldom, node
        Set xmldom = CreateObject(\"Microsoft.XMLDOM\")
        Set node = xmldom.CreateElement(\"binary\")
        node.DataType = \"bin.hex\"
        Set stream = CreateObject(\"ADODB.Stream\")
        stream.Type = adTypeBinary
        stream.Open
        stream.LoadFromFile fichier
        stream.Position = "
(itoa position) "
        node.NodeTypedValue = stream.Read("
(itoa longueur) ")
        stream.Close
        Set stream = Nothing
        ReadBinary = node.Text
        Set node = Nothing
        Set xmldom = Nothing
        End Function"

      )
    )
    (vlax-invoke wsObj 'ExecuteStatement str)
    (setq str (vlax-invoke wsObj '
run "ReadBinary" fichier))
    (vlax-release-object wsObj)
    str
 
)

  (defun hexdec (nb / r i s)
    (if (= (type nb) 'INT)
      (setq nb (itoa nb))
    )
    (setq r 0 i 0)
    (while (and (= (type nb) '
STR) (< i (strlen nb)))
      (setq i (1+ i)
            s (strcase (substr nb i 1 ))
            r (+ (lsh r 4) (- (ascii s)
                              (if (<= s "9")
                                48
                                55
                              )
                            )
              )
      )
    )
  )

  (defun inv(str / nb txt)
    (setq nb 1 txt "")
    (while (< nb (strlen str))
      (setq txt (strcat (substr str nb 2) txt)
            nb (+ nb 2)
      )
    )
    txt
 
)

  (and (setq fic (getfiled "Veuillez sélectionner un fichier BMP" "" "bmp" 16))
    (progn
     
(setq col (vlax-create-object (strcat "AutoCAD.AcCmColor." (substr (getvar 'ACADVER) 1 2)))
            pos (hexdec (inv (readbinary fic 10 4)))
            bit (hexdec (inv (readbinary fic 28 4)))
            str (readbinary fic pos nil)
            nb 1
      )
      (cond
        ((eq bit 24)
          (while (< nb (strlen str))
            (vla-setrgb col (hexdec (substr str (+ nb 4) 2))
                            (hexdec (substr str (+ nb 2) 2))
                            (hexdec (substr str nb 2))
            )
            (setq act (vla-get-colorindex col)
                  nb (+ nb 6)
            )
            (if (eq act 7)
              (setq lst (cons -15 lst))
              (setq lst (cons act lst))
            )
          )
        )
        (T
          (princ "\nLe lisp ne fonctionne qu'
avec des images 24 bits\n")
        )
      )
      (vlax-release-object col)
    )
  )
  lst
)

 

Nhờ cả nhà chỉ giáo, nâng cấp code trên cho tất cả các ảnh bmp.

Cảm ơn!

 

  • 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

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

Đăng nhập để thực hiện theo  

×