Đến nội dung


Hình ảnh
- - - - -

Chuyển Ảnh .bmp Sang Dcl


  • Please log in to reply
1 reply to this topic

#1 trangiangnam

trangiangnam

    Chưa sử dụng CAD

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

Đã gửi 16 June 2016 - 02:28 PM

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/top...itmap-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!

 


  • 1

#2 Nguyen Hoanh

Nguyen Hoanh

    biết lệnh adcenter

  • Moderator
  • PipPipPipPipPipPipPip
  • 4105 Bài viết
Điểm đánh giá: 4495 (đỉnh cao)

Đã gửi 16 June 2016 - 04:02 PM

Cái này quá hay.
  • 0