These are the support routines for Canvas Buttons in 3-D.  

These routines can also be used to make other things.  
The corners and sides are all separate, so one could 
build anything rectangular and 3-D on a canvas.  
A combobox would be interesting.  

Here's a link to the Canvas Buttons in 3-D, 
that use these routines.  

[Canvas Buttons in 3-D]

----

 proc CreateTopLeftCorner {theCanvas x y height args} {
 
     global tlcorner
 
     set id [$theCanvas create rectangle 0 0 1 1]
 
     set tlcorner($id,theCanvas) $theCanvas
     set tlcorner($id,adjustedHeight) [expr round(0.707 * $height)]
     # I'd rather deal with integers. 
     set tlcorner($id,x) $x
     set tlcorner($id,y) $y
 
     set tlcorner($id,color) white
     set tags ""
     set state normal
 
     foreach {option value} $args {
 
         switch -- $option {
 
             -color {
 
                 set tlcorner($id,color) $value
 
                 # No checking at present that color value is valid. 
 
             }
 
             -tag - 
             -tags {
 
                 set tags $value
 
             }
 
             -state {
 
                 switch -- $value {
 
                     normal {
 
                         set state normal
 
                     }
 
                     hidden {
 
                         set state hidden
 
                     }
 
                     default {
 
                         tk_messageBox -message "CreateTopLeftCorner: \
                          Unrecognized state value:  $value" -type ok
 
                     }
 
                 }
 
             }
 
             default {
 
                 tk_messageBox -message "CreateTopLeftCorner:  Unrecognized\
                  option:  $option" -type ok
 
             }
 
         }
 
     }
 
     set ah $tlcorner($id,adjustedHeight)
     set ax [expr $x + $ah]  ;# Altered x. 
     set ay [expr $y + $ah]  ;# Altered y. 
 
     $theCanvas coords $id $x $y $ax $ay
 
     set c $tlcorner($id,color)
 
     $theCanvas itemconfig $id -fill $c -outline $c -tags $tags -state $state
     # Both the fill and the outline need to be set, for rectangle 
     # to match polygon. 
 
     return $id
 
     # Hopefully, the caller won't keep the id long, but will assign 
     # a tag to the assemblage. 
 
 }
 
 # Since I don't want to make a separate routine to set the state for each 
 # piece, and I don't want the rectangle to have to directly twiddle variables 
 # belonging to a piece, I don't make the state of the canvas item, hidden or 
 # normal, part of the state of the piece. 
 
 
 proc CreateLeftSide {theCanvas x ty by height args} {
 
     global lside
 
     set id [$theCanvas create rectangle 0 0 1 1]
 
     set lside($id,theCanvas) $theCanvas
     set lside($id,adjustedHeight) [expr round(0.707 * $height)]
     set lside($id,x) $x
     set lside($id,ty) $ty
     set lside($id,by) $by
 
     set lside($id,color) white
     set tags ""
     set state normal
 
     foreach {option value} $args {
 
         switch -- $option {
 
             -color {set lside($id,color) $value}
 
             -tag - -tags {set tags $value}
 
             -state {
                 switch -- $value {
                     normal {set state normal}
                     hidden {set state hidden}
                     default {tk_messageBox -message "CreateLeftSide: \
                      Unrecognized state value:  $value" -type ok}
                 }
             }
 
             default {tk_messageBox -message "CreateLeftSide: \
              Unrecognized option:  $option" -type ok}
 
         }
 
     }
 
     set ah $lside($id,adjustedHeight)
     set ax [expr $x + $ah]
     set aty [expr $ty + $ah]
     set aby [expr $by - $ah]
 
     $theCanvas coords $id $x $aty $ax $aby
 
     set c $lside($id,color)
 
     $theCanvas itemconfig $id -fill $c -outline $c -tags $tags -state $state
 
     return $id
 
 }
 
 
 proc CreateBottomLeftCorner {theCanvas x y height args} {
 
     global blcorner
 
     set id [$theCanvas create polygon 0 0 1 0 1 1]
 
     set blcorner($id,theCanvas) $theCanvas
     set blcorner($id,adjustedHeight) [expr round(0.707 * $height)]
     set blcorner($id,x) $x
     set blcorner($id,y) $y
 
     set blcorner($id,color) white
     set tags ""
     set state normal
 
     foreach {option value} $args {
 
         switch -- $option {
 
             -color {set blcorner($id,color) $value}
 
             -tag - -tags {set tags $value}
 
             -state {
                 switch -- $value {
                     normal {set state normal}
                     hidden {set state hidden}
                     default {tk_messageBox -message "CreateBottomLeftCorner: \
                      Unrecognized state value:  $value" -type ok}
                 }
             }
 
             default {tk_messageBox -message "CreateBottomLeftCorner: \
              Unrecognized option:  $option" -type ok}
 
         }
 
     }
 
     set ah $blcorner($id,adjustedHeight)
     set ax [expr $x + $ah]
     set by [expr $y + $ah]
     set ty [expr $y - $ah]
 
     $theCanvas coords $id $x $y $ax $by $ax $ty $x $ty
 
     set c $blcorner($id,color)
 
     $theCanvas itemconfig $id -fill $c -outline $c -tags $tags -state $state
 
     return $id
 
 }
 
 # We let the corner manage the territory a little way up the side, 
 # so if we ever decide to allow the customer to change the perspective 
 # so that he is to the left and below the button, instead of to the left 
 # and above, we can. 
 # 
 # This seems as good a place as any to mention that if the height of the 
 # button or whatever gets to be an appreciable fraction of the width and 
 # breadth of the button, these routines will fail. 
 
 
 proc CreateTopSide {theCanvas lx rx y height args} {
 
     global tside
 
     set id [$theCanvas create rectangle 0 0 1 1]
 
     set tside($id,theCanvas) $theCanvas
     set tside($id,adjustedHeight) [expr round(0.707 * $height)]
     set tside($id,lx) $lx
     set tside($id,rx) $rx
     set tside($id,y) $y
 
     set tside($id,color) white
     set tags ""
     set state normal
 
     foreach {option value} $args {
 
         switch -- $option {
 
             -color {set tside($id,color) $value}
 
             -tag - -tags {set tags $value}
 
             -state {
                 switch -- $value {
                     normal {set state normal}
                     hidden {set state hidden}
                     default {tk_messageBox -message "CreateTopSide: \
                      Unrecognized state value:  $value" -type ok}
                 }
             }
 
             default {tk_messageBox -message "CreateTopSide: \
              Unrecognized option:  $option" -type ok}
 
         }
 
     }
 
     set ah $tside($id,adjustedHeight)
     set alx [expr $lx + $ah]
     set arx [expr $rx - $ah]
     set ay [expr $y + $ah]
 
     $theCanvas coords $id $alx $y $arx $ay
 
     set c $tside($id,color)
 
     $theCanvas itemconfig $id -fill $c -outline $c -tags $tags -state $state
 
     return $id
 
 }
 
 
 proc CreateTopRightCorner {theCanvas x y height args} {
 
     global trcorner
 
     set id [$theCanvas create polygon 0 0 1 0 1 1]
 
     set trcorner($id,theCanvas) $theCanvas
     set trcorner($id,adjustedHeight) [expr round(0.707 * $height)]
     set trcorner($id,x) $x
     set trcorner($id,y) $y
 
     set trcorner($id,color) white
     set tags ""
     set state normal
 
     foreach {option value} $args {
 
         switch -- $option {
 
             -color {set trcorner($id,color) $value}
 
             -tag - -tags {set tags $value}
 
             -state {
                 switch -- $value {
                     normal {set state normal}
                     hidden {set state hidden}
                     default {tk_messageBox -message "CreateTopRightCorner: \
                      Unrecognized state value:  $value" -type ok}
                 }
             }
 
             default {tk_messageBox -message "CreateTopRightCorner: \
              Unrecognized option:  $option" -type ok}
 
         }
 
     }
 
     set ah $trcorner($id,adjustedHeight)
     set arx [expr $x + $ah]
     set alx [expr $x - $ah]
     set ay  [expr $y + $ah]
 
     $theCanvas coords $id $x $y $alx $y $alx $ay $arx $ay
 
     set c $trcorner($id,color)
 
     $theCanvas itemconfig $id -fill $c -outline $c -tags $tags -state $state
 
     return $id
 
 }
 
 
 proc CreateBottomSide {theCanvas lx rx y height args} {
 
     global bside
 
     set id [$theCanvas create rectangle 0 0 1 1]
 
     set bside($id,theCanvas) $theCanvas
     set bside($id,adjustedHeight) [expr round(0.707 * $height)]
     set bside($id,lx) $lx
     set bside($id,rx) $rx
     set bside($id,y) $y
 
     set bside($id,color) white
     set tags ""
     set state normal
 
     foreach {option value} $args {
 
         switch -- $option {
 
             -color {set bside($id,color) $value}
 
             -tag - -tags {set tags $value}
 
             -state {
                 switch -- $value {
                     normal {set state normal}
                     hidden {set state hidden}
                     default {tk_messageBox -message "CreateBottomSide: \
                      Unrecognized state value:  $value" -type ok}
                 }
             }
 
             default {tk_messageBox -message "CreateBottomSide: \
              Unrecognized option:  $option" -type ok}
 
         }
 
     }
 
     set ah $bside($id,adjustedHeight)
     set arx [expr $rx - $ah]
     set ay [expr $y - $ah]
 
     $theCanvas coords $id $lx $y $arx $ay
 
     set c $bside($id,color)
 
     $theCanvas itemconfig $id -fill $c -outline $c -tags $tags -state $state
 
     return $id
 
 }
 
 # Logically, the corner owns the territory out an adjustedHeight distance 
 # from the vertex.  But I can't bring myself to make a separate little 
 # corner when it won't be visible.  So I extend this side, and the right 
 # side, all the way to the vertex. 
 
 
 proc CreateBottomRightCorner {theCanvas x y height args} {
 
     global brcorner
 
     set id [$theCanvas create rectangle 0 0 1 1]
 
     set brcorner($id,theCanvas) $theCanvas
     set brcorner($id,adjustedHeight) [expr round(0.707 * $height)]
     set brcorner($id,x) $x
     set brcorner($id,y) $y
 
     set brcorner($id,color) white
     set tags ""
     set state normal
 
     foreach {option value} $args {
 
         switch -- $option {
 
             -color {set brcorner($id,color) $value}
 
             -tag - -tags {set tags $value}
 
             -state {
                 switch -- $value {
                     normal {set state normal}
                     hidden {set state hidden}
                     default {tk_messageBox -message "CreateBottomRightCorner: \
                      Unrecognized state value:  $value" -type ok}
                 }
             }
 
             default {tk_messageBox -message "CreateBottomRightCorner: \
              Unrecognized option:  $option" -type ok}
 
         }
 
     }
 
     set ah $brcorner($id,adjustedHeight)
     set ax [expr $x - $ah]
     set ay [expr $y - $ah]
 
     $theCanvas coords $id $x $y $ax $ay
 
     set c $brcorner($id,color)
 
     $theCanvas itemconfig $id -fill $c -outline $c -tags $tags -state $state
 
     return $id
 
 }
 
 
 proc CreateRightSide {theCanvas x ty by height args} {
 
     global rside
 
     set id [$theCanvas create rectangle 0 0 1 1]
 
     set rside($id,theCanvas) $theCanvas
     set rside($id,adjustedHeight) [expr round(0.707 * $height)]
     set rside($id,x) $x
     set rside($id,ty) $ty
     set rside($id,by) $by
 
     set rside($id,color) white
     set tags ""
     set state normal
 
     foreach {option value} $args {
 
         switch -- $option {
 
             -color {set rside($id,color) $value}
 
             -tag - -tags {set tags $value}
 
             -state {
                 switch -- $value {
                     normal {set state normal}
                     hidden {set state hidden}
                     default {tk_messageBox -message "CreateRightSide: \
                      Unrecognized state value:  $value" -type ok}
                 }
             }
 
             default {tk_messageBox -message "CreateRightSide: \
              Unrecognized option:  $option" -type ok}
 
         }
 
     }
 
     set ah $rside($id,adjustedHeight)
     set ax [expr $x - $ah]
     set aby [expr $by - $ah]
 
     $theCanvas coords $id $x $aby $ax $ty
 
     set c $rside($id,color)
 
     $theCanvas itemconfig $id -fill $c -outline $c -tags $tags -state $state
 
     return $id
 
 }
 
 
 proc DestroyTopLeftCorner id {
 
     global tlcorner
 
     # I thought about converting from a tag to an id, if the value passed 
     # is not numeric, but how are you going to get the canvas name? 
 
     $tlcorner($id,theCanvas) delete $id
 
     unset tlcorner($id,theCanvas)
     unset tlcorner($id,adjustedHeight)
     unset tlcorner($id,x)
     unset tlcorner($id,y)
     unset tlcorner($id,color)
 
 }
 
 
 # Rather than have a procedure "ShowTopLeftCorner" and one "HideTopLeftCorner" 
 # I think I'll have the orchestrator configure state using a tag that refers 
 # to all the parts. 
 
 
 proc DestroyLeftSide id {
 
     global lside
 
     $lside($id,theCanvas) delete $id
 
     unset lside($id,theCanvas)
     unset lside($id,adjustedHeight)
     unset lside($id,x)
     unset lside($id,ty)
     unset lside($id,by)
     unset lside($id,color)
 
 }
 
 
 proc DestroyBottomLeftCorner id {
 
     global blcorner
 
     $blcorner($id,theCanvas) delete $id
 
     unset blcorner($id,theCanvas)
     unset blcorner($id,adjustedHeight)
     unset blcorner($id,x)
     unset blcorner($id,y)
     unset blcorner($id,color)
 
 }
 
 
 proc DestroyTopSide id {
 
     global tside
 
     $tside($id,theCanvas) delete $id
 
     unset tside($id,theCanvas)
     unset tside($id,adjustedHeight)
     unset tside($id,lx)
     unset tside($id,rx)
     unset tside($id,y)
     unset tside($id,color)
 
 }
 
 
 proc DestroyTopRightCorner id {
 
     global trcorner
 
     $trcorner($id,theCanvas) delete $id
 
     unset trcorner($id,theCanvas)
     unset trcorner($id,adjustedHeight)
     unset trcorner($id,x)
     unset trcorner($id,y)
     unset trcorner($id,color)
 
 }
 
 
 proc DestroyBottomSide id {
 
     global bside
 
     $bside($id,theCanvas) delete $id
 
     unset bside($id,theCanvas)
     unset bside($id,adjustedHeight)
     unset bside($id,lx)
     unset bside($id,rx)
     unset bside($id,y)
     unset bside($id,color)
 
 }
 
 
 proc DestroyBottomRightCorner id {
 
     global brcorner
 
     $brcorner($id,theCanvas) delete $id
 
     unset brcorner($id,theCanvas)
     unset brcorner($id,adjustedHeight)
     unset brcorner($id,x)
     unset brcorner($id,y)
     unset brcorner($id,color)
 
 }
 
 
 proc DestroyRightSide id {
 
     global rside
 
     $rside($id,theCanvas) delete $id
 
     unset rside($id,theCanvas)
     unset rside($id,adjustedHeight)
     unset rside($id,x)
     unset rside($id,ty)
     unset rside($id,by)
     unset rside($id,color)
 
 }
 
 
 # --------------------- Above are the pieces of a rectangle -------------------
 #                       to be assembled in different ways. 
 
 
 # Some options that might be confusing are: 
 # 
 # dx, dy - If you have something written on the surface of your box 
 # (for example if the box is a button and the top of it says "Quit") 
 # as the box is raised and recessed, the text or image should be moved 
 # with a canvas move command.  Dx and dy tell you how much to move your 
 # image over.  They are relative to if you had written your image directly 
 # in the surface, without being raised above it or lowered below it.  
 # The names of the variables where you would like the values placed are 
 # passed using these options. 
 
 proc Create3DBox {theCanvas lx ty rx by height args} {
 
     global box3d
 
     set id [$theCanvas create rectangle 0 0 1 1]
 
     set box3d($id,theCanvas) $theCanvas
     set box3d($id,adjustedHeight) [expr round(0.707 * $height)]
     set box3d($id,lx) $lx
     set box3d($id,ty) $ty
     set box3d($id,rx) $rx
     set box3d($id,by) $by
 
     set box3d($id,outSideColor) white
     set box3d($id,inSideColor) white
     set box3d($id,topFillColor) gray
     set box3d($id,topOutlineColor) black
     set box3d($id,relief) raised
     set dxname ""
     set dyname ""
     set tags ""
 
     foreach {option value} $args {
 
         switch -- $option {
 
             -outsidecolor {
 
                 set box3d($id,outSideColor) $value
 
                 # No checking that color value is valid. 
 
             }
 
             -insidecolor {
 
                 set box3d($id,inSideColor) $value
 
             }
 
             -topfillcolor {
 
                 set box3d($id,topFillColor) $value
 
             }
 
             -topoutlinecolor {
 
                 set box3d($id,topOutlineColor) $value
 
             }
 
             -relief {
 
                 switch -- $value {
 
                     raised {
 
                         set box3d($id,relief) raised
 
                     }
 
                     sunken - 
                     recessed {
 
                         set box3d($id,relief) recessed
 
                         # Tk users are likely to say sunken. 
 
                     }
 
                     flat {
 
                         set box3d($id,relief) flat
 
                     }
 
                     default {
 
                         tk_messageBox -message "Create3DBox: \
                          Unrecognized relief value:  $value" -type ok
 
                     }
 
                 }
 
             }
 
             -dx {
 
                 set dxname $value
 
             }
 
             -dy {
 
                 set dyname $value
 
             }
 
             -tag - 
             -tags {
 
                 set tags $value
 
             }
 
             default {
 
                 tk_messageBox -message "Create3DBox:  Unrecognized\
                  option:  $option" -type ok
 
             }
 
         }
 
     }
 
     set osc $box3d($id,outSideColor)
     set isc $box3d($id,inSideColor)
     set tfc  $box3d($id,topFillColor)
     set toc  $box3d($id,topOutlineColor)
 
     lappend tags box3d$id
 
     set box3d($id,blcid) [CreateBottomLeftCorner $theCanvas $lx $by \
      $height -color $osc -tags $tags]
 
     set box3d($id,lsid) [CreateLeftSide $theCanvas $lx $ty $by $height \
      -color $osc -tags $tags]
 
     set box3d($id,tlcid) [CreateTopLeftCorner $theCanvas $lx $ty $height \
      -color $osc -tags $tags]
 
     set box3d($id,tsid) [CreateTopSide $theCanvas $lx $rx $ty $height \
      -color $osc -tags $tags]
 
     set box3d($id,trcid) [CreateTopRightCorner $theCanvas $rx $ty $height \
      -color $osc -tags $tags]
 
     set box3d($id,bsid) [CreateBottomSide $theCanvas $lx $rx $by $height \
      -color $isc -tags $tags]
 
     set box3d($id,brcid) [CreateBottomRightCorner $theCanvas $rx $by \
      $height -color $isc -tags $tags]
 
     set box3d($id,rsid) [CreateRightSide $theCanvas $rx $ty $by $height \
      -color $isc -tags $tags]
 
     $theCanvas itemconfig $id -outline $toc -fill $tfc -tags $tags
 
     Draw3DBox $id localdx localdy
 
     if {$dxname != ""} {
 
         upvar $dxname dx
 
         set dx $localdx
 
     }
 
     if {$dyname != ""} {
 
         upvar $dyname dy
 
         set dy $localdy
 
     }
 
     return $id
 
 }
 
 # First we set tags to an empty string, then set it with any list of tags, 
 # then appended our required tag.  Thus we kept it a one level list. 
 # 
 # Typically, Create3DBox will be called with only one tag, but it it becomes 
 # part of a larger assemblage later, this may be useful. 
 
 
 proc Destroy3DBox id {
 
     global box3d
 
     DestroyBottomLeftCorner $box3d($id,blcid)
     DestroyLeftSide $box3d($id,lsid)
     DestroyTopLeftCorner $box3d($id,tlcid)
     DestroyTopSide $box3d($id,tsid)
     DestroyTopRightCorner $box3d($id,trcid)
     DestroyRightSide $box3d($id,rsid)
     DestroyBottomRightCorner $box3d($id,brcid)
     DestroyBottomSide $box3d($id,bsid)
 
     $box3d($id,theCanvas) delete $id
 
     unset box3d($id,theCanvas)
     unset box3d($id,adjustedHeight)
     unset box3d($id,lx)
     unset box3d($id,ty)
     unset box3d($id,rx)
     unset box3d($id,by)
 
     unset box3d($id,outSideColor)
     unset box3d($id,inSideColor)
     unset box3d($id,topFillColor)
     unset box3d($id,topOutlineColor)
     unset box3d($id,relief)
 
     unset box3d($id,blcid)
     unset box3d($id,lsid)
     unset box3d($id,tlcid)
     unset box3d($id,tsid)
     unset box3d($id,trcid)
     unset box3d($id,rsid)
     unset box3d($id,brcid)
     unset box3d($id,bsid)
 
 }
 
 # Seems best to always have all the parts of a rectangle exists, if the 
 # rectangle exists.  Some of the parts may have the state "hidden".  
 # Otherwise, we have to create and delete things when the button pops up, 
 # or create things only when they are first called for, and keep track 
 # of whether the piece exists yet. 
 # 
 # I'll put this here arbitrarily.  It seems unfortunate to calculate the 
 # adjusted height from the passed height of the rectangle in multiple 
 # different places.  What if one calculates it slightly differently?  
 # Also, it seems silly to put the same code to handle an option like 
 # -state in each routine.  If I were using something like XOTcl, I would 
 # handle the options the specialized object knows about, and then finish 
 # my routine in the parent object with the next command. 
 
 
 proc Draw3DBox {id dxname dyname} {
 
     global box3d
 
     set c   $box3d($id,theCanvas)
     set lx  $box3d($id,lx)
     set ty  $box3d($id,ty)
     set rx  $box3d($id,rx)
     set by  $box3d($id,by)
     set ah  $box3d($id,adjustedHeight)
     set osc $box3d($id,outSideColor)
     set isc $box3d($id,inSideColor)
     set tfc $box3d($id,topFillColor)
     set toc $box3d($id,topOutlineColor)
     set r   $box3d($id,relief)
 
     upvar $dxname dx
     upvar $dyname dy
 
     if {$r == "raised"} {
         set ulstate normal
         set lrstate hidden
     } elseif {$r == "recessed"} {
         set ulstate hidden
         set lrstate normal
     } else {  ;# Flat
         set ulstate hidden
         set lrstate hidden
     }
 
     $c itemconfig $box3d($id,blcid) -state $ulstate
     $c itemconfig $box3d($id,lsid) -state $ulstate
     $c itemconfig $box3d($id,tlcid) -state $ulstate
     $c itemconfig $box3d($id,tsid) -state $ulstate
     $c itemconfig $box3d($id,trcid) -state $ulstate
     $c itemconfig $box3d($id,rsid) -state $lrstate
     $c itemconfig $box3d($id,brcid) -state $lrstate
     $c itemconfig $box3d($id,bsid) -state $lrstate
 
     if {$r == "raised"} {
 
         $c coords $id [expr $lx + $ah] [expr $ty + $ah] [expr $rx + $ah] \
          [expr $by + $ah]
 
         $c lower $id box3d$id
         # Probably could just lower below everything, but if sometime in 
         # the future the 3d box is part of a more complicated assemblage, 
         # it will be good to stay with my group. 
         # 
         # Lowered so that outline will only be visible where top meets 
         # background, not where it meets sides. 
 
         set dx $ah
         set dy $ah
 
     } elseif {$r == "recessed"} {
 
         $c coords $id $lx $ty [expr $rx - $ah] [expr $by - $ah]
 
         $c lower $id box3d$id
 
         set dx -$ah
         set dy -$ah
 
     } else {  ;# Flat
 
         $c coords $id $lx $ty $rx $by
 
         set dx 0
         set dy 0
 
     }
 
 }
 
 
 proc Set3DBoxRelief {id relief args} {
 
     global box3d
 
     if {![info exists box3d($id,theCanvas)]} {
 
         tk_messageBox -message "Set3DBoxRelief:  no such id:  $id" -type ok
 
     }
 
     # I'm not going to check that the relief value is legal each time.  
     # The user may be waiting for his button to go down. 
 
     if {$relief == "sunken"} {set relief recessed}
 
     if {$box3d($id,relief) == $relief} {
 
         set ah $box3d($id,adjustedHeight)
 
         if {$relief == "raised"} {
             set localdx $ah
             set localdy $ah
         } elseif {$relief == "recessed"} {
             set localdx -$ah
             set localdy -$ah
         } else {
             set localdx 0 
             set localdy 0 
         }
 
     } else {
 
         set box3d($id,relief) $relief
 
         Draw3DBox $id localdx localdy
 
     }
 
     # Set3DBoxRelief really shouldn't know things about drawing, like that 
     # if the relief is raised, any label on top of the button should be 
     # moved down and right by adjustedHeight amount.  I could always call 
     # Draw3DBox.  I guess I'll regard this knowledge on Set3DBoxRelief's 
     # part as an optimization. 
 
     set dxname ""
     set dyname ""
 
     foreach {option value} $args {
 
         switch -- $option {
 
             -dx {set dxname $value}
 
             -dy {set dyname $value}
 
             # Not checking for unrecognized option. 
 
         }
 
     }
 
     if {$dxname != ""} {
 
         upvar $dxname dx
 
         set dx $localdx
 
     }
 
     if {$dyname != ""} {
 
         upvar $dyname dy
 
         set dy $localdy
 
     }
 
 }
 
 
 # It might be desired to bind to the whole box, not to each of its subparts. 
 # One way to accomplish this might be to put a polygon over the top of the box. 
 # You can give the polygon a fill color and outline color of the empty string. 
 
 proc Get3DBoxPolygon {id} {
 
     global box3d
 
     set coords {}
 
     set ah $box3d($id,adjustedHeight)
     set lx $box3d($id,lx)
     set ty $box3d($id,ty)
     set rx $box3d($id,rx)
     set by $box3d($id,by)
 
     lappend coords $lx $ty $rx $ty [expr $rx + $ah] [expr $ty + $ah]
     
     lappend coords [expr $rx + $ah] [expr $by + $ah]
     
     lappend coords [expr $lx + $ah] [expr $by + $ah] $lx $by
 
     return $coords
 }

----
[Category Graphics]