Entmake Ole2Frame Paitbrush image

newer

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. 
    
13.         Dim DW, DH As Integer
    
14.         If MYANG = 0 Then
    
15.             DW = 0
    
16.             DH = 0
    
17.         Else
    
18.             DW = 5
    
19.             DH = 5
    
20.         End If
    
21.         Dim retBMP As New Bitmap(IMG.Width + DW, IMG.Height + DH)
    
22.         retBMP.SetResolution(IMG.HorizontalResolution, IMG.VerticalResolution)
    
23. 
    
24.         Using g = Graphics.FromImage(retBMP)
    
25.             g.Clear(Drawing.Color.White)
    
26.             g.TranslateTransform(0, IMG.Height)
    
27.             g.RotateTransform(MYANG)
    
28.             g.TranslateTransform(0, -IMG.Height)
    
29.             g.DrawImage(IMG, New PointF(0, 0))
    
30.         End Using
    
31.         retBMP.Save(IMGTMP, ImageFormat.Jpeg)
    
32.         '
    
33.         Dim imge As Drawing.Image = Bitmap.FromFile(IMGTMP)
    
34.         Dim mem As New IO.MemoryStream
    
35.         imge.Save(mem, Imaging.ImageFormat.Jpeg)
    
36.         imge.Dispose()
    
37.         mem.Position = 0
    
38.         imge = Drawing.Image.FromStream(mem)
    
39.         Clipboard.SetImage(imge)
    
40.         '
    
41.         '<<<ARGUMENTOS DE SAIDA
    
42.         'Use RTREAL  (5001) for doubles
    
43.         'Use RTSHORT (5003) for integers
    
44.         'Use RTSTR   (5005) for strings
    
45.         Dim rbfResult As ResultBuffer
    
46.         rbfResult = New ResultBuffer( _
    
47.             New TypedValue(CInt(5005), MYIMG))
    
48.         Return rbfResult
    
49.     End Function
    
50. 
    
51.     <LispFunction("FIMGIMP")> _
    
52.     Public Function FIMGIMP(ByVal rbfArgs As ResultBuffer) As ResultBuffer
    
53.         '
    
54.         '>>>ARGUMENTOS DE ENTRADA
    
55.         Dim arInputArgs As Array
    
56.         arInputArgs = rbfArgs.AsArray
    
57.         Dim MYSTR As String = CStr(CType(arInputArgs.GetValue(0), TypedValue).Value)
    
58.         Dim MYIMG As String = CStr(CType(arInputArgs.GetValue(1), TypedValue).Value)
    
59.         '
    
60.         Try
    
61.             Dim client As New WebClient()
    
62.             'By default, the google static map api returns a png file
    
63.             client.DownloadFile(MYSTR, MYIMG)
    
64.         Catch
    
65.         End Try
    
66.         '
    
67.         '<<<ARGUMENTOS DE SAIDA
    
68.         'Use RTREAL  (5001) for doubles
    
69.         'Use RTSHORT (5003) for integers
    
70.         'Use RTSTR   (5005) for strings
    
71.         Dim rbfResult As ResultBuffer
    
72.         rbfResult = New ResultBuffer( _
    
73.             New TypedValue(CInt(5005), MYIMG))
    
74.         Return rbfResult
    
75.     End Function
    

<LispFunction("FIMGOLE")> _<br />     Public Function FIMGOLE(ByVal rbfArgs As ResultBuffer) As ResultBuffer<br />         '<br />         '>>>ARGUMENTOS DE ENTRADA<br />         Dim arInputArgs As Array<br />         arInputArgs = rbfArgs.AsArray<br />         Dim MYIMG As String = CStr(CType(arInputArgs.GetValue(0), TypedValue).Value)<br />         Dim MYANG As Single = CSng(CType(arInputArgs.GetValue(1), TypedValue).Value)<br />         '<br />         Dim IMGTMP As String = Path.GetDirectoryName(MYIMG) & "\myimg.jpg"<br />         Dim IMG As System.Drawing.Image = New Bitmap(MYIMG)<br /> <br />         Dim DW, DH As Integer<br />         If MYANG = 0 Then<br />             DW = 0<br />             DH = 0<br />         Else<br />             DW = 5<br />             DH = 5<br />         End If<br />         Dim retBMP As New Bitmap(IMG.Width + DW, IMG.Height + DH)<br />         retBMP.SetResolution(IMG.HorizontalResolution, IMG.VerticalResolution)<br /> <br />         Using g = Graphics.FromImage(retBMP)<br />             g.Clear(Drawing.Color.White)<br />             g.TranslateTransform(0, IMG.Height)<br />             g.RotateTransform(MYANG)<br />             g.TranslateTransform(0, -IMG.Height)<br />             g.DrawImage(IMG, New PointF(0, 0))<br />         End Using<br />         retBMP.Save(IMGTMP, ImageFormat.Jpeg)<br />         '<br />         Dim imge As Drawing.Image = Bitmap.FromFile(IMGTMP)<br />         Dim mem As New IO.MemoryStream<br />         imge.Save(mem, Imaging.ImageFormat.Jpeg)<br />         imge.Dispose()<br />         mem.Position = 0<br />         imge = Drawing.Image.FromStream(mem)<br />         Clipboard.SetImage(imge)<br />         '<br />         '<<<ARGUMENTOS DE SAIDA<br />         'Use RTREAL  (5001) for doubles<br />         'Use RTSHORT (5003) for integers<br />         'Use RTSTR   (5005) for strings<br />         Dim rbfResult As ResultBuffer<br />         rbfResult = New ResultBuffer( _<br />             New TypedValue(CInt(5005), MYIMG))<br />         Return rbfResult<br />     End Function<br /> <br />     <LispFunction("FIMGIMP")> _<br />     Public Function FIMGIMP(ByVal rbfArgs As ResultBuffer) As ResultBuffer<br />         '<br />         '>>>ARGUMENTOS DE ENTRADA<br />         Dim arInputArgs As Array<br />         arInputArgs = rbfArgs.AsArray<br />         Dim MYSTR As String = CStr(CType(arInputArgs.GetValue(0), TypedValue).Value)<br />         Dim MYIMG As String = CStr(CType(arInputArgs.GetValue(1), TypedValue).Value)<br />         '<br />         Try<br />             Dim client As New WebClient()<br />             'By default, the google static map api returns a png file<br />             client.DownloadFile(MYSTR, MYIMG)<br />         Catch<br />         End Try<br />         '<br />         '<<<ARGUMENTOS DE SAIDA<br />         'Use RTREAL  (5001) for doubles<br />         'Use RTSHORT (5003) for integers<br />         'Use RTSTR   (5005) for strings<br />         Dim rbfResult As ResultBuffer<br />         rbfResult = New ResultBuffer( _<br />             New TypedValue(CInt(5005), MYIMG))<br />         Return rbfResult<br />     End Function<br />

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)
    

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;<br /> (DEFUN C:IMGOLE ()<br /> (COMMAND "_UNDO" "_G")<br /> (SETQ #CAD (SUBSTR (GETVAR "ACADVER") 1 2))<br /> (COND<br /> ((= #CAD "17")(SETQ ARQUIVO "IMGOLENET3.DLL" ));ACAD 2007/2008/2009<br /> ((= #CAD "18")(SETQ ARQUIVO "IMGOLENET4.DLL" ));ACAD 2010/2011/2012<br /> ((= #CAD "19")(SETQ ARQUIVO "IMGOLENET4.DLL" ));ACAD 2013/2014<br /> ((= #CAD "20")(SETQ ARQUIVO "IMGOLENET45.DLL"));ACAD 2015/2016<br /> ((= #CAD "21")(SETQ ARQUIVO "IMGOLENET45.DLL"));ACAD 2017<br /> ((= #CAD "22")(SETQ ARQUIVO "IMGOLENET45.DLL"));ACAD 2018<br /> ((= #CAD "23")(SETQ ARQUIVO "IMGOLENET45.DLL"));ACAD 2019<br /> ( T           (SETQ ARQUIVO "IMGOLENET45.DLL"));<br /> )<br /> (VL-CMDF "NETLOAD" (FINDFILE ARQUIVO))<br /> ;<br /> (SETQ LLISTA  (SSGET "_X" (LIST (CONS 0 "IMAGE") )))<br /> (SETQ NN 0)<br /> (IF LLISTA<br />    (PROGN<br />    (FOREACH EEP (SSNAMEX LLISTA)<br />       (SETQ NN  (+ NN 1))<br />       (SETQ LL  (ENTGET (CADR EEP)))<br />       (SETQ PT  (CDR (ASSOC 10 LL)))<br />       (SETQ PT11 (CDR (ASSOC 11 LL)))<br />       (SETQ PT12 (CDR (ASSOC 12 LL)))<br />       (SETQ IMG  (CDR (ASSOC 1 (ENTGET (CDR (ASSOC 340 LL))))))<br />       (SETQ ANGG (RPG (ANGLE (LIST 0 0) PT11)))<br />       (SETQ ANGG (- 360.0 ANGG))<br />       (SETQ SCX  (* 512 (DISTANCE (LIST 0 0) PT11)))<br />       (SETQ SCY  (* 512 (DISTANCE (LIST 0 0) PT12)))<br />       (COMMAND "_IMAGE" "_D" (VL-FILENAME-BASE IMG))<br />       (IMGPASTE IMG PT ANGG)<br />       (SETQ ENTO (ENTLAST))<br />       (SETQ LISO (ENTGET ENTO))<br />       (SETQ PT10 (CDR (ASSOC 10 LISO)))<br />       (SETQ PT11 (CDR (ASSOC 11 LISO)))<br />       (SETQ DXO  (- (CAR  PT11) (CAR  PT10)))<br />       (SETQ DYO  (- (CADR PT10) (CADR PT11)))<br />       ;<br />       (COMMAND "_SCALE" ENTO "" PT (/ SCX DYO))<br />       (COMMAND "_DRAWORDER" (ENTLAST) "" "_B")<br />    )<br />    (SETVAR "OLEFRAME" 0)<br />    (COMMAND "_REGEN")<br />    (ALERT (STRCAT ">> " (ITOA NN) " << IMAGES CONVERTEDS."<br />                   "\n"<br />                   "\nOLEFRAME (System Variable)"<br />                   "\n= 0 Frame is not displayed and not plotted"<br />                   "\n= 1 Frame is displayed and is plotted"<br />                   "\n= 2 Frame is displayed but is not plotted"<br />                   "\n"<br />                   "\nType U to back"<br />           )<br />    )<br />    )<br />    (ALERT (STRCAT ">> " (ITOA NN) " << IMAGES NOT FOUNDS."))<br /> )<br /> (COMMAND "_UNDO" "_E")<br /> (PRINC)<br /> )<br /> ;...<br /> (defun IMGPASTE (image-path 2d-insert-point image-angg / cmdecho elast nircmd-path x y )<br /> ;;;<a href=\"http://www.theswamp.org\" target=\"_blank\">www.theswamp.org</a> by MP Seagull<br />     (and<br />         (progn (setq elast (entlast)) t)<br />         (setq cmdecho (getvar 'cmdecho))<br />         (setvar 'cmdecho 0)<br />         (setq image-path (findfile image-path))<br />         (progn<br />             (FIMGOLE IMAGE-PATH image-angg) ;;;DLL<br />             (command ".pasteclip" (mapcar 'set '(x y) 2d-insert-point))<br />         )       <br />     )       <br />     (setvar 'cmdecho cmdecho)<br />     (not (equal elast (entlast)))<br /> )<br /> ;...<br /> (DEFUN GPR  ($G) (* $G (/ PI 180)) )<br /> (DEFUN RPG  ($R) (* $R (/ 180 PI)) )<br /> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;<br /> (PRINC)<br />