home *** CD-ROM | disk | FTP | other *** search
/ The Fred Fish Collection 1.5 / ffcollection-1-5-1992-11.iso / ff_disks / 500-599 / ff597.lzh / IconTools / source / ReplaceImage.f < prev    next >
Text File  |  1992-02-01  |  5KB  |  217 lines
  1. \ $VER: ReplaceImage.f 1.01 (19 Jan 1992 23:33)
  2. \ Program to change the image of a number icons simultaneously,
  3. \   using the Workbench and Intuition.
  4. \ Written in JForth Professional 2.0
  5. \
  6. \ (c) Copyright 1992 by Richard Mazzarisi
  7. \    All rights reserved.
  8. \
  9. \ address:
  10. \    891 Post St. #207
  11. \    San Francisco, CA
  12. \    94109
  13. \
  14. \  email:
  15. \    rich@californium.cchem.berkeley.edu
  16. \    rmazz@hydrogen.cchem.berkeley.edu
  17. \    nmr@garnet.berkeley.edu
  18. \
  19. \
  20. \ v. 1.00 1/12/92
  21. \      1/13/92  moved the resource management routines to IconTools.f
  22. \      1/14/92  whoops, forgot to release the first icon when done!
  23. \ v. 1.01 1/19/92  moved window down so that requester will not obscure the
  24. \            name of the image to be used if a large screen
  25. \            font is used
  26. \                  recompiled with new IconTools.f (cf)
  27. \
  28. \ Instructions:
  29. \ 1 - Click on the icon for this program.
  30. \ 2 - Shift click on the icon which will supply its image to the others.
  31. \ 3 - shift click on the icons which are to get the image from the first icon.
  32. \
  33. \ (NOTE: The author assumes no responsibility for any damages
  34. \ resulting from the use of this program.)
  35.  
  36.  
  37. INCLUDE? TASK-ICONTOOLS ICONTOOLS.F
  38.  
  39.  
  40. ANEW task-replaceimage
  41.  
  42. DECIMAL
  43.  
  44.  
  45. \ *** variables ***
  46.  
  47. VARIABLE repl-icon
  48. VARIABLE repl-gadget
  49. VARIABLE repl-strings    \ need to save these even tho we don't use 'em
  50.  
  51.  
  52. \ *** main window stuff ***
  53.  
  54. : open.ri-window    ( -- window/null )
  55.     getWBscreendata
  56.     it-newwindow NEWWINDOW.SETUP
  57.     45 18 set.vert-params
  58.     it-newwindow ..! nw_Height
  59.     it-newwindow ..! nw_TopEdge
  60.     20 52 set.horiz-params
  61.     it-newwindow ..! nw_Width
  62.     it-newwindow ..! nw_LeftEdge
  63.     0" ReplaceImage  1.01" >ABS it-newwindow ..! nw_Title
  64.     CLOSEWINDOW it-newwindow ..! nw_IDCMPFlags
  65.     WINDOWCLOSE WINDOWDRAG | WINDOWDEPTH | WINDOWSIZING | ACTIVATE |
  66.         it-newwindow ..! nw_Flags
  67.     it-newwindow GR.OPENCURW
  68. ;
  69.  
  70.  
  71. \ *** support ***
  72.  
  73. : ri.greeting        ( -- )
  74.     " Replace the Image of Icons." con.write.itl con.cr
  75.     " © Copyright by Richard Mazzarisi 1992" con.write.c3 con.cr
  76.     "          All rights reserved." con.write.c3 con.cr
  77.     "      Written in JForth Professional 2.0." con.write.c3 con.cr con.cr
  78. ;
  79.  
  80.  
  81. : prt.ri-instr        ( -- )
  82.     " Instructions:"  con.write con.cr
  83.     " 1 - Click on the icon for this program."  con.write con.cr
  84.     " 2 - Shift click on the icon which will supply its"  con.write con.cr
  85.     "     image to the others."  con.write con.cr
  86.     " 3 - shift click on the icons which are to get the"  con.write con.cr
  87.     "     image from the first icon."  con.write con.cr
  88.     " (NOTE: The author assumes no responsibility for any"
  89.     con.write con.cr
  90.     " damages resulting from the use of this program.)" con.write con.cr
  91. ;
  92.  
  93.  
  94. : copy.gadget        ( -- )
  95. \ replaces the whole gadget structure
  96.     PAD $it.get-icon
  97.     repl-gadget @  theIcon @ .. do_Gadget  SizeOf() Gadget  CMOVE
  98. [ clone-it @ ] .IF
  99.     PAD $it.save-icon
  100. .ELSE
  101. \ don't really do it if we are testing things in the interpreter
  102.     it.abort-icon
  103. .THEN
  104. ;
  105.  
  106.  
  107. : replace.one        { wb-arg -- }
  108.     \ get file's path name
  109.     wb-arg get.full-path IF
  110.         "   " con.write
  111.         PAD con.write con.cr
  112.         copy.gadget
  113.     ELSE
  114.         " ERROR: Could not get path for the icon:" con.write.itl con.cr
  115.         "   " con.write
  116.         wreq @ wb-arg ..@ wa_Name >REL ConPutStr() con.cr
  117.     THEN
  118. ;
  119.  
  120.  
  121. : replace.images    ( wb-arg #args -- )
  122.     \ go thru icons to be changed
  123.     " Replacing the Image for:" con.write con.cr
  124.     \ 3rd and on are the icons to work on
  125.     1+  2  DO
  126.                 DUP  SizeOf() WBArg  I *  +
  127.                 replace.one
  128.         \ check for stop action
  129.         ?CLOSEBOX IF LEAVE THEN
  130.     LOOP
  131.     DROP
  132.     con.cr " Done.  " con.write.itl
  133. ;
  134.  
  135.  
  136. : verify.path        ( -- t/f )
  137. \ verify with user that the replacement is OK
  138.     " Image to be used will be: " con.write con.cr
  139.     "    " con.write
  140.     PAD con.write con.cr con.cr
  141.     " Is the replacement OK to use?"
  142.     " OK, do it!" " No, Cancel" $it.auto.request IF
  143.         " Click closebox to abort."  con.write
  144.         con.cr con.cr
  145.         TRUE
  146.     ELSE
  147.         " Cancelled!" con.write.itl con.cr
  148.         FALSE
  149.     THEN
  150. ;
  151.  
  152.  
  153. : get.replacement-image    { wb-arg -- t/f }
  154.     wb-arg  SizeOf() WBArg  +
  155.     get.full-path IF
  156.         verify.path DUP IF
  157.             PAD $it.get-icon
  158.             theIcon @  DUP repl-icon !
  159.             .. do_Gadget  repl-gadget !
  160.             theStrings @  repl-strings !
  161.             theIcon OFF
  162.         THEN
  163.     ELSE
  164.         " ERROR getting path for the replacement image: " con.write.itl
  165.         wreq @    wb-arg ..@ wa_Name >REL
  166.         ConPutStr() con.cr
  167.         FALSE
  168.      THEN
  169. ;
  170.  
  171.  
  172. : release.repl-icon    ( -- )
  173.     repl-icon @ theIcon !
  174.     repl-strings @ theStrings !
  175.     it.abort-icon
  176. ;
  177.  
  178.  
  179. \ *** main ***
  180.  
  181. : replaceimage        ( -- )
  182.     ' prt.ri-instr IS prt.it-instr
  183.     ' open.ri-window IS open.it-window
  184.     open.it-things
  185.     cursor.off
  186.     ri.greeting
  187.     check.WB
  188.     3 check.num.args IF                                      ( #args )
  189.         \ get pointer to args
  190.         WBMESSAGE @ >REL ..@ sm_ArgList >REL  SWAP       ( wbarg #args )
  191.                 \ first one is the replacement image
  192.         OVER get.replacement-image  IF
  193.             replace.images
  194.             release.repl-icon
  195.         ELSE
  196.             2DROP
  197.         THEN
  198.     THEN
  199.     close.it-things
  200. ;
  201.  
  202.  
  203. : ri
  204.     replaceimage
  205. ;
  206.  
  207.  
  208. clone-it @ .IF
  209.  
  210. initclone
  211. clone replaceimage
  212. save-image replaceimage ReplaceImage -icon
  213.  
  214. .THEN
  215.  
  216. CR CR ." Type 'ri to run." CR CR
  217.