1################################################################ 2## printer.tcl 3## 4## Usage: 5## printer::print_widget p 6## If the parameter p is anything but default, uses the 7## print dialog. If it is default, it uses the default printer. 8## 9## Prints a canvas "reasonably" well (as GDI matures...) 10## John Blattner <johnb@imagix.com> contributed the original 11## version of this code. 12## Modifications made by Michael Schwartz (mschwart@nyx.net) 13## Handles some additional printer types that do not put numbers in the 14## resolution field 15## Darcy Kahle <darcykahle@sympatico.ca> contributed the origianl 16## version of this code. 17## Modifications made by Michael Schwartz (mschwart@nyx.net) 18## Several suggestions and code contributions were made by Mick O'Donnell (micko@wagsoft.com) 19## 20## This version (0.1) scales the canvas to "fit" the page. 21## It is very limited now, by may meet simple user needs. 22## LIMITATIONS: 23## This is limited by GDI (e.g., no arrows on the lines, stipples), 24## and is also limited in current canvas items supported. 25## For instance, bitmaps and images are not yet supported. 26## 27## Idea mill for future enhancements: 28## c) Add an optional page title and footer 29## d) Add tk font support to the gdi command if tk is loaded. 30## e) Make scaling an option 31## f) Make rendering the canvas something done as PART of a 32## print. 33################################################################ 34# 35# CHANGES by Mats Bengtsson 36# 37# - fixed font spec problem 38# - ppt replaced by ppi 39# - changed -offset in gdi map call 40# - rewrites, added stuff from text printing 41 42package require gdi 43package require printer 44 45namespace eval printer { 46 47 # First some utilities to ensure we can debug this sucker. 48 49 variable debug 50 variable option 51 variable vtgPrint 52} 53 54proc printer::init_print_canvas { } { 55 variable debug 56 variable option 57 variable vtgPrint 58 59 set debug 0 60 set option(use_copybits) 1 61 set vtgPrint(printer.bg) white 62} 63 64proc printer::is_win {} { 65 return [ info exist tk_patchLevel ] 66} 67 68proc printer::debug_puts {str} { 69 variable debug 70 71 if $debug { 72 if {[ is_win ]} { 73 if {![winfo exist .debug ]} { 74 set tl [ toplevel .debug ] 75 frame $tl.buttons 76 pack $tl.buttons -side bottom -fill x 77 button $tl.buttons.ok -text OK -command "destroy .debug" 78 pack $tl.buttons.ok 79 text $tl.text -yscroll "$tl.yscroll set" 80 scrollbar $tl.yscroll -orient vertical -command "$tl.text yview" 81 pack $tl.yscroll -side right -fill y -expand false 82 pack $tl.text -side left -fill both -expand true 83 } 84 $tl.text insert end $str 85 } else { 86 puts "Debug: $str" 87 after 100 88 } 89 } 90} 91 92################################################################ 93## page_args 94## Description: 95## This is a helper proc used to parse common arguments for 96## text processing in the other commands. 97## "Reasonable" defaults are provided if not present 98## Args: 99## Name of an array in which to store the various pieces 100## needed for text processing 101################################################################ 102 103proc printer::page_args { arrName } { 104 # use upvar one level to get into the context of the immediate caller. 105 upvar 1 $arrName ary 106 107 # First we check whether we have a valid hDC 108 # (perhaps we can later make this also an optional argument, defaulting to 109 # the default printer) 110 set attr [ printer attr ] 111 foreach attrpair $attr { 112 set key [lindex $attrpair 0] 113 set val [lindex $attrpair 1] 114 set ary($key) $val 115 switch -exact $key { 116 "page dimensions" { 117 set wid [lindex $val 0] 118 set hgt [lindex $val 1] 119 if { $wid > 0 } { set ary(pw) $wid } 120 if { $hgt > 0 } { set ary(pl) $hgt } 121 } 122 "page margins" { 123 if { [scan [lindex $val 0] %d tmp] > 0 } { 124 foreach {ary(lm) ary(tm) ary(rm) ary(bm)} $val {} 125 } 126 } 127 "resolution" { 128 if { [scan [lindex $val 0] %d tmp] > 0 } { 129 foreach {ary(resx) ary(resy)} $val {} 130 } else { 131 set ary(resolution) [lindex $val 0] 132 } 133 } 134 } 135 } 136 137 if { ( [ info exist ary(hDC) ] == 0 ) || ($ary(hDC) == 0x0) } { 138 error "Can't get printer attributes" 139 } 140 141 # Now, set "reasonable" defaults if some values were unavailable 142 # Resolution is the hardest. Uses "resolution" first, if it was numeric. 143 # Uses "pixels per inch" second, if it is set. 144 # Use the words medium and best for resolution third--these are guesses 145 # Uses 200 as a last resort. 146 if { ![info exist ary(resx)] } { 147 set ppi "pixels per inch" 148 if { [info exist ary($ppi)] } { 149 if { [scan $ary($ppi) "%d %d" tmp1 tmp2] > 0 } { 150 set ary(resx) $tmp1 151 if { $tmp2 > 0 } { 152 set ary(resy) $tmp2 153 } 154 } else { 155 if [ string match -nocase $ary($ppi) "medium" ] { 156 set ary(resx) 300 157 set ary(resy) 300 158 } elseif [ string match -nocase $ary($ppi) "best" ] { 159 set ary(resx) 600 160 set ary(resy) 600 161 } else { 162 set ary(resx) 200 163 set ary(resy) 200 164 } 165 } 166 } else { 167 set ary(resx) 200 168 } 169 } 170 if { [ info exist ary(resy) ] == 0 } { set ary(resy) $ary(resx) } 171 if { [ info exist ary(tm) ] == 0 } { set ary(tm) 1000 } 172 if { [ info exist ary(bm) ] == 0 } { set ary(bm) 1000 } 173 if { [ info exist ary(lm) ] == 0 } { set ary(lm) 1000 } 174 if { [ info exist ary(rm) ] == 0 } { set ary(rm) 1000 } 175 if { [ info exist ary(pw) ] == 0 } { set ary(pw) 8500 } 176 if { [ info exist ary(pl) ] == 0 } { set ary(pl) 11000 } 177 if { [ info exist ary(copies) ] == 0 } { set ary(copies) 1 } 178} 179 180################################################################ 181# These procedures read in the canvas widget, and write all of # 182# its contents out to the Windows printer. # 183################################################################ 184 185################################################################ 186## print_widget 187## Description: 188## Main procedure for printing a widget. Currently supports 189## canvas widgets. Handles opening and closing of printer. 190## Assumes that printer and gdi packages are loaded. 191## Args: 192## wid The widget to be printed. 193## args 194## -printer Flag whether to use the default printer. 195## -name App name to pass to printer. 196## -font Specify font. 197## -data text 198################################################################ 199 200proc printer::print_widget { wid args } { 201 202 variable debug 203 204 array set argsArr { 205 -data {} 206 -printer {} 207 -name "Tcl" 208 -font {} 209 -copybits 1 210 } 211 array set argsArr $args 212 213 # start printing process ------ 214 if {[string match "default" $argsArr(-printer)]} { 215 set hdc [printer open] 216 } else { 217 set hdc [printer dialog select] 218 if { [lindex $hdc 1] == 0 } { 219 # User has canceled printing 220 return 221 } 222 set hdc [ lindex $hdc 0 ] 223 } 224 225 variable p 226 set p(0) 0 ; unset p(0) 227 page_args p 228 229 if {![info exist p(hDC)]} { 230 set hdc [printer open] 231 page_args p 232 } 233 if {[string match "?" $hdc] || [string match 0x0 $hdc]} { 234 catch {printer close} 235 error "Problem opening printer: printer context cannot be established" 236 } 237 238 printer job start -name "$argsArr(-name)" 239 printer page start 240 241 # Here is where any scaling/gdi mapping should take place 242 # For now, scale so the dimensions of the window are sized to the 243 # width of the page. Scale evenly. 244 245 # For normal windows, this may be fine--but for a canvas, one wants the 246 # canvas dimensions, and not the WINDOW dimensions. 247 if { [winfo class $wid] == "Canvas" } { 248 set sc [ lindex [ $wid configure -scrollregion ] 4 ] 249 # if there is no scrollregion, use width and height. 250 # Mats: since copybits take only visible window. 251 if {1 || "$sc" == "" } { 252 set window_x [ lindex [ $wid configure -width ] 4 ] 253 set window_y [ lindex [ $wid configure -height ] 4 ] 254 } else { 255 set window_x [ lindex $sc 2 ] 256 set window_y [ lindex $sc 3 ] 257 } 258 } else { 259 set window_x [ winfo width $wid ] 260 set window_y [ winfo height $wid ] 261 } 262 263 set pd "page dimensions" 264 set pm "page margins" 265 set ppi "pixels per inch" 266 267 set printer_x [ expr ( [lindex $p($pd) 0] - \ 268 [lindex $p($pm) 0 ] - [lindex $p($pm) 2 ] ) * \ 269 [lindex $p($ppi) 0] / 1000.0 ] 270 set printer_y [ expr ( [lindex $p($pd) 1] - \ 271 [lindex $p($pm) 1 ] - [lindex $p($pm) 3 ] ) * \ 272 [lindex $p($ppi) 1] / 1000.0 ] 273 set factor_x [ expr $window_x / $printer_x ] 274 set factor_y [ expr $window_y / $printer_y ] 275 276 debug_puts "printer: ($printer_x, $printer_y)" 277 debug_puts "window : ($window_x, $window_y)" 278 debug_puts "factor : $factor_x $factor_y" 279 280 if { $factor_x < $factor_y } { 281 set lo $window_y 282 set ph $printer_y 283 set p_y $printer_y 284 set p_x [expr $p_y * $window_x / $window_y] 285 } else { 286 set lo $window_x 287 set ph $printer_x 288 set p_x $printer_x 289 set p_y [expr $p_x * $window_y / $window_x] 290 } 291 292 # handling of canvas widgets 293 # additional procs can be added for other widget types 294 switch [winfo class $wid] { 295 Canvas { 296 if {$argsArr(-copybits)} { 297 #gdi copybits $hdc -window $wid \ 298 # -source [list 0 0 $window_x $window_y] \ 299 # -destination [list $p(lm) $p(tm) ] 300 raise [winfo toplevel $wid] 301 update 302 gdi map $hdc -logical $lo -physical $ph -offset [list $p(resx) $p(resy)] 303 gdi copybits $hdc -window $wid 304 } else { 305 306 # The offset still needs to be set based on page margins 307 debug_puts [ list \ 308 gdi map $hdc -logical $lo -physical $ph -offset [list $p(resx) $p(resy)] ] 309 gdi map $hdc -logical $lo -physical $ph -offset [list $p(resx) $p(resy)] 310 311 print_canvas [lindex $hdc 0] $wid 312 } 313 } 314 Text { 315 set lm [ expr $p(lm) * $p(resx) / 1000 ] 316 set tm [ expr $p(tm) * $p(resy) / 1000 ] 317 set pw [ expr ($p(pw) - $p(rm) - $p(lm)) * $p(resx) / 1000 ] 318 set pl [ expr ($p(pl) - $p(tm) - $p(bm)) * $p(resx) / 1000 ] 319 if {$debug} { 320 gdi rectangle $p(hDC) $lm $tm [expr $lm+$pw] [expr $tm+$pl] 321 gdi text $p(hDC) $lm [expr $tm+$pl] -anchor sw -text \ 322 "lm=$lm, tm=$tm, pw=$pw, pl=$pl" -font {Times 10} 323 gdi text $p(hDC) $lm [expr $tm+$pl-200] -anchor sw -text \ 324 "p(resx)=$p(resx), p(resy)=$p(resy)" -font {courier 10} 325 } 326 if {[llength $argsArr(-font)]} { 327 set fontargs [list -font [printer::font_map $argsArr(-font)]] 328 } else { 329 set fontargs {} 330 } 331 if {[llength $argsArr(-data)]} { 332 set data $argsArr(-data) 333 } else { 334 set data [$wid get 1.0 end] 335 } 336 eval {gdi text $p(hDC) $lm $tm -anchor nw -text $data -width $pw} \ 337 $fontargs 338 } 339 default { 340 debug_puts "Can't print items of type [winfo class $wid]. No handler registered" 341 } 342 } 343 344 # end printing process ------ 345 printer page end 346 printer job end 347 printer close 348} 349 350proc printer::font_map {font} { 351 352 switch -- [lindex $font 0] { 353 "Courier" { 354 return "{Courier New} [lrange $font 1 end]" 355 } 356 default { 357 return $font 358 } 359 } 360} 361 362################################################################ 363## print_page_data 364## Description: 365## This is the simplest way to print a small amount of text 366## on a page. The text is formatted in a box the size of the 367## selected page and margins. 368## Args: 369## data Text data for printing 370## fontargs Optional arguments to supply to the text command 371################################################################ 372 373proc printer::print_page_data {data args} { 374 375 page_args printargs 376 if { ! [info exist printargs(hDC)] } { 377 printer open 378 page_args printargs 379 } 380 381 set tm [ expr $printargs(tm) * $printargs(resy) / 1000 ] 382 set lm [ expr $printargs(lm) * $printargs(resx) / 1000 ] 383 set pw [ expr ( $printargs(pw) - $printargs(lm) - $printargs(rm) ) / \ 384 1000 * $printargs(resx) ] 385 printer job start 386 printer page start 387 eval {gdi text $printargs(hDC) $lm $tm \ 388 -anchor nw -text $data -width $pw} $args 389 printer page end 390 printer job end 391} 392 393################################################################ 394## print_canvas 395## Description: 396## Main procedure for writing canvas widget items to printer. 397## Args: 398## hdc The printer handle. 399## cw The canvas widget. 400################################################################ 401 402proc printer::print_canvas {hdc cw} { 403 variable vtgPrint 404 405 # get information about page being printed to 406 # print_canvas.CalcSizing $cw 407 set vtgPrint(canvas.bg) [string tolower [$cw cget -background]] 408 409 # re-write each widget from cw to printer 410 foreach id [$cw find all] { 411 set type [$cw type $id] 412 if { [ info commands print_canvas.$type ] == "print_canvas.$type" } { 413 print_canvas.[$cw type $id] $hdc $cw $id 414 } else { 415 debug_puts "Omitting canvas item of type $type since there is no handler registered for it" 416 } 417 } 418} 419 420################################################################ 421## These procedures support the various canvas item types, # 422## reading the information about the item on the real canvas # 423## and then writing a similar item to the printer. # 424################################################################ 425 426################################################################ 427## print_canvas.line 428## Description: 429## Prints a line item. 430## Args: 431## hdc The printer handle. 432## cw The canvas widget. 433## id The id of the canvas item. 434################################################################ 435 436proc printer::print_canvas.line {hdc cw id} { 437 variable vtgPrint 438 439 set color [print_canvas.TransColor [$cw itemcget $id -fill]] 440 if {[string match $vtgPrint(printer.bg) $color]} {return} 441 set coords [$cw coords $id] 442 set wdth [$cw itemcget $id -width] 443 444 if {$wdth <= 1 } { 445 set cmmd "gdi line $hdc $coords -fill $color" 446 } else { 447 set cmmd "gdi line $hdc $coords -fill $color -width $wdth" 448 } 449 450 debug_puts "$cmmd" 451 eval $cmmd 452} 453 454 455################################################################ 456## print_canvas.polygon 457## Description: 458## Prints a polygon item. 459## Args: 460## hdc The printer handle. 461## cw The canvas widget. 462## id The id of the canvas item. 463################################################################ 464 465proc printer::print_canvas.polygon {hdc cw id} { 466 variable vtgPrint 467 468 set fcolor [print_canvas.TransColor [$cw itemcget $id -fill]] 469 if {![string length $fcolor]} {set fcolor $vtgPrint(printer.bg)} 470 set ocolor [print_canvas.TransColor [$cw itemcget $id -outline]] 471 if {![string length $ocolor]} {set ocolor $vtgPrint(printer.bg)} 472 set coords [$cw coords $id] 473 set wdth [$cw itemcget $id -width] 474 475 set cmmd "gdi polygon $hdc $coords -width $wdth \ 476 -fill $fcolor -outline $ocolor" 477 debug_puts "$cmmd" 478 eval $cmmd 479} 480 481 482################################################################ 483## print_canvas.oval 484## Description: 485## Prints an oval item. 486## Args: 487## hdc The printer handle. 488## cw The canvas widget. 489## id The id of the canvas item. 490################################################################ 491 492proc printer::print_canvas.oval { hdc cw id } { 493 variable vtgPrint 494 495 set fcolor [print_canvas.TransColor [$cw itemcget $id -fill]] 496 if {![string length $fcolor]} {set fcolor $vtgPrint(printer.bg)} 497 set ocolor [print_canvas.TransColor [$cw itemcget $id -outline]] 498 if {![string length $ocolor]} {set ocolor $vtgPrint(printer.bg)} 499 set coords [$cw coords $id] 500 set wdth [$cw itemcget $id -width] 501 502 set cmmd "gdi oval $hdc $coords -width $wdth \ 503 -fill $fcolor -outline $ocolor" 504 debug_puts "$cmmd" 505 eval $cmmd 506} 507 508################################################################ 509## print_canvas.rectangle 510## Description: 511## Prints a rectangle item. 512## Args: 513## hdc The printer handle. 514## cw The canvas widget. 515## id The id of the canvas item. 516################################################################ 517 518proc printer::print_canvas.rectangle {hdc cw id} { 519 variable vtgPrint 520 521 set fcolor [print_canvas.TransColor [$cw itemcget $id -fill]] 522 if {![string length $fcolor]} {set fcolor $vtgPrint(printer.bg)} 523 set ocolor [print_canvas.TransColor [$cw itemcget $id -outline]] 524 if {![string length $ocolor]} {set ocolor $vtgPrint(printer.bg)} 525 set coords [$cw coords $id] 526 set wdth [$cw itemcget $id -width] 527 528 set cmmd "gdi rectangle $hdc $coords -width $wdth \ 529 -fill $fcolor -outline $ocolor" 530 debug_puts "$cmmd" 531 eval $cmmd 532} 533 534 535################################################################ 536## print_canvas.text 537## Description: 538## Prints a text item. 539## Args: 540## hdc The printer handle. 541## cw The canvas widget. 542## id The id of the canvas item. 543################################################################ 544 545proc printer::print_canvas.text {hdc cw id} { 546 variable vtgPrint 547 variable p 548 549 set p(0) 1 ; unset p(0) 550 page_args p 551 552 set color [print_canvas.TransColor [$cw itemcget $id -fill]] 553 # if {[string match white [string tolower $color]]} {return} 554 # set color black 555 set txt [$cw itemcget $id -text] 556 if {![string length $txt]} {return} 557 set coords [$cw coords $id] 558 set anchr [$cw itemcget $id -anchor] 559 560 set bbox [$cw bbox $id] 561 set wdth [expr [lindex $bbox 2] - [lindex $bbox 0]] 562 563 set just [$cw itemcget $id -justify] 564 565 set font [ $cw itemcget $id -font ] 566 #set font [list [font configure -family] -[font configure -size]] 567 568 set cmmd "gdi text $hdc $coords -fill $color -text [list $txt] \ 569 -anchor $anchr -font [ list $font ] \ 570 -width $wdth -justify $just" 571 debug_puts "$cmmd" 572 eval $cmmd 573} 574 575 576################################################################ 577## print_canvas.image 578## Description: 579## Prints an image item. 580## Args: 581## hdc The printer handle. 582## cw The canvas widget. 583## id The id of the canvas item. 584################################################################ 585 586proc printer::print_canvas.image {hdc cw id} { 587 588 variable vtgPrint 589 variable option 590 591 # First, we have to get the image name 592 set imagename [ $cw itemcget $id -image] 593 # Now we get the size 594 set wid [ image width $imagename] 595 set hgt [ image height $imagename ] 596 # next, we get the location and anchor 597 set anchor [ $cw itemcget $id -anchor ] 598 set coords [ $cw coords $id ] 599 600 601 # Since the GDI commands don't yet support images and bitmaps, 602 # and since this represents a rendered bitmap, we CAN use 603 # copybits IF we create a new temporary toplevel to hold the beast. 604 # if this is too ugly, change the option! 605 if { [ info exist option(use_copybits) ] } { 606 set firstcase $option(use_copybits) 607 } else { 608 set firstcase 0 609 } 610 611 if { $firstcase > 0 } { 612 set tl [toplevel .tmptop[expr int( rand() * 65535 ) ] -height $hgt -width $wid -background $vtgPrint(printer.bg) ] 613 canvas $tl.canvas -width $wid -height $hgt 614 $tl.canvas create image 0 0 -image $imagename -anchor nw 615 pack $tl.canvas -side left -expand false -fill none 616 tkwait visibility $tl.canvas 617 update 618 set srccoords [list "0 0 [ expr $wid - 1] [expr $hgt - 1 ]" ] 619 set dstcoords [ list "[lindex $coords 0] [lindex $coords 1] [expr $wid - 1] [expr $hgt - 1]" ] 620 set cmmd "gdi copybits $hdc -window $tl -client -source $srccoords -destination $dstcoords " 621 debug_puts "$cmmd" 622 eval $cmmd 623 destroy $tl 624 } else { 625 set cmmd "gdi image $hdc $coords -anchor $anchor -image $imagename" 626 debug_puts "$cmmd" 627 eval $cmmd 628 } 629} 630 631################################################################ 632## print_canvas.bitmap 633## Description: 634## Prints a bitmap item. 635## Args: 636## hdc The printer handle. 637## cw The canvas widget. 638## id The id of the canvas item. 639################################################################ 640 641proc printer::print_canvas.bitmap {hdc cw id} { 642 variable option 643 variable vtgPrint 644 645 # First, we have to get the bitmap name 646 set imagename [ $cw itemcget $id -bitmap] 647 # Now we get the size 648 set wid [ image width $imagename] 649 set hgt [ image height $imagename ] 650 # next, we get the location and anchor 651 set anchor [ $cw itemcget $id -anchor ] 652 set coords [ $cw itemcget $id -coords ] 653 654 # Since the GDI commands don't yet support images and bitmaps, 655 # and since this represents a rendered bitmap, we CAN use 656 # copybits IF we create a new temporary toplevel to hold the beast. 657 # if this is too ugly, change the option! 658 if { [ info exist option(use_copybits) ] } { 659 set firstcase $option(use_copybits) 660 } else { 661 set firstcase 0 662 } 663 if { $firstcase > 0 } { 664 set tl [toplevel .tmptop[expr int( rand() * 65535 ) ] -height $hgt -width $wid -background $vtgPrint(canvas.bg) ] 665 canvas $tl.canvas -width $wid -height $hgt 666 $tl.canvas create bitmap 0 0 -bitmap $imagename -anchor nw 667 pack $tl.canvas -side left -expand false -fill none 668 tkwait visibility $tl.canvas 669 update 670 set srccoords [list "0 0 [ expr $wid - 1] [expr $hgt - 1 ]" ] 671 set dstcoords [ list "[lindex $coords 0] [lindex $coords 1] [expr $wid - 1] [expr $hgt - 1]" ] 672 set cmmd "gdi copybits $hdc -window $tl -client -source $srccoords -destination $dstcoords " 673 debug_puts "$cmmd" 674 eval $cmmd 675 destroy $tl 676 } else { 677 set cmmd "gdi bitmap $hdc $coords -anchor $anchor -bitmap $imagename" 678 debug_puts "$cmmd" 679 eval $cmmd 680 } 681} 682 683################################################################ 684## These procedures transform attribute setting from the real # 685## canvas to the appropriate setting for printing to paper. # 686################################################################ 687 688################################################################ 689## print_canvas.TransColor 690## Description: 691## Does the actual transformation of colors from the 692## canvas widget to paper. 693## Args: 694## color The color value to be transformed. 695################################################################ 696 697proc printer::print_canvas.TransColor {color} { 698 variable vtgPrint 699 700 switch [string toupper $color] { 701 $vtgPrint(canvas.bg) {return $vtgPrint(printer.bg)} 702 } 703 return $color 704} 705 706# Initialize all the variables once 707printer::init_print_canvas 708 709