找回密码
 立即注册

QQ登录

只需一步,快速开始

扫一扫,访问微社区

查看: 650|回复: 0

[每日一码] Entmake Ole2Frame Paitbrush image

[复制链接]

已领礼包: 40个

财富等级: 招财进宝

发表于 2021-1-13 21:17:57 | 显示全部楼层 |阅读模式

马上注册,结交更多好友,享用更多功能,让你轻松玩转社区。

您需要 登录 才可以下载或查看,没有账号?立即注册

×

  1. <LispFunction("FIMGOLE")> _
  2.     Public Function FIMGOLE(ByVal rbfArgs As ResultBuffer) As ResultBuffer
  3.         '
  4.         '>>>ARGUMENTOS DE ENTRADA
  5.         Dim arInputArgs As Array
  6.         arInputArgs = rbfArgs.AsArray
  7.         Dim MYIMG As String = CStr(CType(arInputArgs.GetValue(0), TypedValue).Value)
  8.         Dim MYANG As Single = CSng(CType(arInputArgs.GetValue(1), TypedValue).Value)
  9.         '
  10.         Dim IMGTMP As String = Path.GetDirectoryName(MYIMG) & "\myimg.jpg"
  11.         Dim IMG As System.Drawing.Image = New Bitmap(MYIMG)

  12.         Dim DW, DH As Integer
  13.         If MYANG = 0 Then
  14.             DW = 0
  15.             DH = 0
  16.         Else
  17.             DW = 5
  18.             DH = 5
  19.         End If
  20.         Dim retBMP As New Bitmap(IMG.Width + DW, IMG.Height + DH)
  21.         retBMP.SetResolution(IMG.HorizontalResolution, IMG.VerticalResolution)

  22.         Using g = Graphics.FromImage(retBMP)
  23.             g.Clear(Drawing.Color.White)
  24.             g.TranslateTransform(0, IMG.Height)
  25.             g.RotateTransform(MYANG)
  26.             g.TranslateTransform(0, -IMG.Height)
  27.             g.DrawImage(IMG, New PointF(0, 0))
  28.         End Using
  29.         retBMP.Save(IMGTMP, ImageFormat.Jpeg)
  30.         '
  31.         Dim imge As Drawing.Image = Bitmap.FromFile(IMGTMP)
  32.         Dim mem As New IO.MemoryStream
  33.         imge.Save(mem, Imaging.ImageFormat.Jpeg)
  34.         imge.Dispose()
  35.         mem.Position = 0
  36.         imge = Drawing.Image.FromStream(mem)
  37.         Clipboard.SetImage(imge)
  38.         '
  39.         '<<<ARGUMENTOS DE SAIDA
  40.         'Use RTREAL  (5001) for doubles
  41.         'Use RTSHORT (5003) for integers
  42.         'Use RTSTR   (5005) for strings
  43.         Dim rbfResult As ResultBuffer
  44.         rbfResult = New ResultBuffer( _
  45.             New TypedValue(CInt(5005), MYIMG))
  46.         Return rbfResult
  47.     End Function

  48.     <LispFunction("FIMGIMP")> _
  49.     Public Function FIMGIMP(ByVal rbfArgs As ResultBuffer) As ResultBuffer
  50.         '
  51.         '>>>ARGUMENTOS DE ENTRADA
  52.         Dim arInputArgs As Array
  53.         arInputArgs = rbfArgs.AsArray
  54.         Dim MYSTR As String = CStr(CType(arInputArgs.GetValue(0), TypedValue).Value)
  55.         Dim MYIMG As String = CStr(CType(arInputArgs.GetValue(1), TypedValue).Value)
  56.         '
  57.         Try
  58.             Dim client As New WebClient()
  59.             'By default, the google static map api returns a png file
  60.             client.DownloadFile(MYSTR, MYIMG)
  61.         Catch
  62.         End Try
  63.         '
  64.         '<<<ARGUMENTOS DE SAIDA
  65.         'Use RTREAL  (5001) for doubles
  66.         'Use RTSHORT (5003) for integers
  67.         'Use RTSTR   (5005) for strings
  68.         Dim rbfResult As ResultBuffer
  69.         rbfResult = New ResultBuffer( _
  70.             New TypedValue(CInt(5005), MYIMG))
  71.         Return rbfResult
  72.     End Function


LISP代码:

  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. (DEFUN C:IMGOLE ()
  3. (COMMAND "_UNDO" "_G")
  4. (SETQ #CAD (SUBSTR (GETVAR "ACADVER") 1 2))
  5. (COND
  6. ((= #CAD "17")(SETQ ARQUIVO "IMGOLENET3.DLL" ));ACAD 2007/2008/2009
  7. ((= #CAD "18")(SETQ ARQUIVO "IMGOLENET4.DLL" ));ACAD 2010/2011/2012
  8. ((= #CAD "19")(SETQ ARQUIVO "IMGOLENET4.DLL" ));ACAD 2013/2014
  9. ((= #CAD "20")(SETQ ARQUIVO "IMGOLENET45.DLL"));ACAD 2015/2016
  10. ((= #CAD "21")(SETQ ARQUIVO "IMGOLENET45.DLL"));ACAD 2017
  11. ((= #CAD "22")(SETQ ARQUIVO "IMGOLENET45.DLL"));ACAD 2018
  12. ((= #CAD "23")(SETQ ARQUIVO "IMGOLENET45.DLL"));ACAD 2019
  13. ( T           (SETQ ARQUIVO "IMGOLENET45.DLL"));
  14. )
  15. (VL-CMDF "NETLOAD" (FINDFILE ARQUIVO))
  16. ;
  17. (SETQ LLISTA  (SSGET "_X" (LIST (CONS 0 "IMAGE") )))
  18. (SETQ NN 0)
  19. (IF LLISTA
  20.    (PROGN
  21.    (FOREACH EEP (SSNAMEX LLISTA)
  22.       (SETQ NN  (+ NN 1))
  23.       (SETQ LL  (ENTGET (CADR EEP)))
  24.       (SETQ PT  (CDR (ASSOC 10 LL)))
  25.       (SETQ PT11 (CDR (ASSOC 11 LL)))
  26.       (SETQ PT12 (CDR (ASSOC 12 LL)))
  27.       (SETQ IMG  (CDR (ASSOC 1 (ENTGET (CDR (ASSOC 340 LL))))))
  28.       (SETQ ANGG (RPG (ANGLE (LIST 0 0) PT11)))
  29.       (SETQ ANGG (- 360.0 ANGG))
  30.       (SETQ SCX  (* 512 (DISTANCE (LIST 0 0) PT11)))
  31.       (SETQ SCY  (* 512 (DISTANCE (LIST 0 0) PT12)))
  32.       (COMMAND "_IMAGE" "_D" (VL-FILENAME-BASE IMG))
  33.       (IMGPASTE IMG PT ANGG)
  34.       (SETQ ENTO (ENTLAST))
  35.       (SETQ LISO (ENTGET ENTO))
  36.       (SETQ PT10 (CDR (ASSOC 10 LISO)))
  37.       (SETQ PT11 (CDR (ASSOC 11 LISO)))
  38.       (SETQ DXO  (- (CAR  PT11) (CAR  PT10)))
  39.       (SETQ DYO  (- (CADR PT10) (CADR PT11)))
  40.       ;
  41.       (COMMAND "_SCALE" ENTO "" PT (/ SCX DYO))
  42.       (COMMAND "_DRAWORDER" (ENTLAST) "" "_B")
  43.    )
  44.    (SETVAR "OLEFRAME" 0)
  45.    (COMMAND "_REGEN")
  46.    (ALERT (STRCAT ">> " (ITOA NN) " << IMAGES CONVERTEDS."
  47.                   "\n"
  48.                   "\nOLEFRAME (System Variable)"
  49.                   "\n= 0 Frame is not displayed and not plotted"
  50.                   "\n= 1 Frame is displayed and is plotted"
  51.                   "\n= 2 Frame is displayed but is not plotted"
  52.                   "\n"
  53.                   "\nType U to back"
  54.           )
  55.    )
  56.    )
  57.    (ALERT (STRCAT ">> " (ITOA NN) " << IMAGES NOT FOUNDS."))
  58. )
  59. (COMMAND "_UNDO" "_E")
  60. (PRINC)
  61. )
  62. ;...
  63. (defun IMGPASTE (image-path 2d-insert-point image-angg / cmdecho elast nircmd-path x y )
  64. ;;;www.theswamp.org by MP Seagull
  65.     (and
  66.         (progn (setq elast (entlast)) t)
  67.         (setq cmdecho (getvar 'cmdecho))
  68.         (setvar 'cmdecho 0)
  69.         (setq image-path (findfile image-path))
  70.         (progn
  71.             (FIMGOLE IMAGE-PATH image-angg) ;;;DLL
  72.             (command ".pasteclip" (mapcar 'set '(x y) 2d-insert-point))
  73.         )      
  74.     )      
  75.     (setvar 'cmdecho cmdecho)
  76.     (not (equal elast (entlast)))
  77. )
  78. ;...
  79. (DEFUN GPR  ($G) (* $G (/ PI 180)) )
  80. (DEFUN RPG  ($R) (* $R (/ 180 PI)) )
  81. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  82. (PRINC)
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

QQ|申请友链|Archiver|手机版|小黑屋|辽公网安备|晓东CAD家园 ( 辽ICP备15016793号 )

GMT+8, 2024-3-29 05:11 , Processed in 0.317524 second(s), 27 queries , Gzip On.

Powered by Discuz! X3.5

© 2001-2024 Discuz! Team.

快速回复 返回顶部 返回列表