вторник, 27 октября 2009 г.

Создание файлов формата MS Excel 2003 в Tcl

В основу положена реализация, приведенная в вики wiki.tcl.tk Во-первых, выполнена "доработка напильником", во-вторых, реализован интерфейс в лисп-стиле.


# Copyright 2009, Mobile Business Group
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see http://www.gnu.org/licenses/.

#package provide excel 1.0

namespace eval ::excel:: {
variable styles
variable columnDefault
variable rowCounter
variable workbooks 0
variable workSheets
variable workbooksArray
variable workSheetsArray
variable data
variable data_str
variable style_str

namespace export book sheet row style columntype
}

proc ::excel::createWorkbook {} {
#
# @comment create a workbook pointer
# @result pointer to created workbook
#
incr ::excel::workbooks
set workbookName workbook$::excel::workbooks
set ::excel::workbooksArray($workbookName) 1
return $workbookName
}

proc ::excel::createWorkSheet {workbook name} {
#
# @comment create a worksheet pointer
# @argument workbook pointer to a workbook
# @argument name name of the worksheet
# @result pointer to a worksheet
#
variable data

if {[info exists ::excel::workbooksArray($workbook)]} {
if {![info exists ::excel::workSheets($workbook)]} {
set ::excel::workSheets($workbook) 1
} else {
incr ::excel::workSheets($workbook)
}
set workSheetName workSheet[string range ${workbook} 8 end].$::excel::workSheets($workbook)
set map_list [list \] {} \[ {} \\ {} \/ {} {*} {} {?} {} {<} {} {>} {} \{ {} \} {} {&} {} {'} {}]
set data(workSheet,$::excel::workSheets($workbook),name) [string range [string map $map_list $name] 0 29]
set data(workSheet,$::excel::workSheets($workbook)) $workSheetName
set data(workSheet,$workSheetName) 1
set ::excel::rowCounter($workSheetName) 0
return $workSheetName
} else {
error "$workbook is not a valid workbook"
}
}

proc ::excel::setColumnType {workSheet columnIndex type} {
#
# @comment define a column type
# @argument workSheet pointer to a workSheet
# @argument columnIndex index of column
# @argument type of column
# @result column type is changed
#
# variable data
# _checkSpreadSheet $workSheet
# set data($workSheet,row,$columnIndex,type) [string totitle $type]
}

proc ::excel::_checkSpreadSheet {workSheet} {
variable data
if {![info exists data(workSheet,$workSheet)]} {
error "$workSheet is not a valid workSheet"
}
}

proc ::excel::deleteWorkbook {workbook} {
#
# @comment delete a workbook pointer
# @argument workbook pointer to a workbook
# @result undecoded string
#
# variable data

unset ::excel::style_str
array unset ::excel::data_str

for {set d 1} {$d<=$::excel::workSheets($workbook)} {incr d} {
array unset ::excel::data $d
set workSheet $::excel::data(workSheet,$d)
for {set i 1} {$i<=$::excel::rowCounter($workSheet)} {incr i} {
array unset ::excel::data $workSheet*
}
unset ::excel::rowCounter($workSheet)
}

array unset ::excel::workSheetsArray
array unset ::excel::workbooksArray
array unset ::excel::rowCounter
}

proc ::excel::asXml {workbook} {
#
# @comment returns excel workbook as xml
# @argument workbook pointer to a workbook
# @result workbook xml representation
#

variable data
variable rowCounter

set xml "<?xml version='1.0' encoding='UTF-8'?>\
<?mso-application progid='Excel.Sheet'?>\
<Workbook xmlns='urn:schemas-microsoft-com:office:spreadsheet'\
xmlns:o='urn:schemas-microsoft-com:office:office'\
xmlns:x='urn:schemas-microsoft-com:office:excel'\
xmlns:ss='urn:schemas-microsoft-com:office:spreadsheet'\
xmlns:html='http://www.w3.org/TR/REC-html40'>\
<DocumentProperties xmlns='urn:schemas-microsoft-com:office:office'>\
<Author>Mobile Business Group</Author>\
<Created>[clock format [clock seconds] -format {%Y-%m-%dT%H:%M:%SZ}]</Created>\
<Company>Mobile Business Group</Company>\
</DocumentProperties>\n\
<Styles>\n\
<Style ss:ID='s1'>\n\
<Alignment ss:Vertical='Bottom'/>\n\
<Font x:CharSet='177'/>\n\
</Style>\n"

append xml $::excel::style_str
append xml "</Styles>\n"

for {set d 1} {$d<=$::excel::workSheets($workbook)} {incr d} {
set workSheet $::excel::data(workSheet,$d)
append xml "<Worksheet ss:Name='$::excel::data(workSheet,$d,name)'>\n\
<Table x:FullColumns='1' x:FullRows='1'>\n"
append xml $::excel::data_str($workSheet)
append xml "</Table>\n</Worksheet>\n"
}
append xml "</Workbook>"

return $xml
}

proc ::excel::addRow {workSheet args} {
#
# @comment add row to excel worksheet
# @argument workSheet pointer to a workSheet
# @argument args list of variables
# @result row id
#
# variable data
# variable data_str

set xml {}
append xml "<Row>\n"
foreach arg $args {
set dataValue [string map [list & {&} < {<} > {>}] [lindex $arg 0]]
set dataType [string totitle [lindex $arg 1]]
set dataStyle [lindex $arg 2]
set dataColspan {}
if {[lindex $arg 3] ne {}} {
set dataColspan [expr {[lindex $arg 3] - 1}]
}
set dataRowspan {}
if {[lindex $arg 4] ne {}} {
set dataRowspan [expr {[lindex $arg 4] - 1}]
}
if {$dataType eq {}} {
set dataType {String}
}
if {[string index $dataValue 0] == "="} {
append xml "<Cell ss:Formula='$dataValue'"
set dataValue ""
} else {
append xml "<Cell"
}
if {$dataColspan ne {} && $dataColspan ne {-1}} {
append xml " ss:MergeAcross='$dataColspan'"
}
if {$dataRowspan ne {} && $dataRowspan ne {-1}} {
append xml " ss:MergeDown='$dataRowspan'"
}
if {$dataStyle ne {}} {
append xml " ss:StyleID='$dataStyle'>\n"
} else {
append xml ">\n"
}
append xml "<Data ss:Type='$dataType'>$dataValue</Data></Cell>\n"
}
append xml "</Row>\n"
append ::excel::data_str($workSheet) $xml

return
}


proc ::excel::createStyle {workbook args} {
#
# @comment create an excel style
# @argument workbook pointer to a workbook
# @argument args argument list
# @result style pointer
#
# variable data

set xml {}

if {[info exists ::excel::styles($workbook)]} {
incr ::excel::styles($workbook)
} else {
set ::excel::styles($workbook) 2
}
set styleName s$::excel::styles($workbook)

array set tmp $args
foreach z [array names tmp] {
if {[lsearch "-font -fontcolor -background -bold" $z]==-1} {
error "style option $z option is not supported"
}
}
foreach z [list -font -fontcolor -background -bold] {
if {[info exists tmp($z)]} {
set style$z $tmp($z)
} else {
set style$z {}
}
}

append xml "<Style ss:ID='$styleName'><Alignment ss:Vertical='Bottom'/>\n"
if {${style-font} ne {} || ${style-fontcolor} ne {}} {
append xml "<Font x:CharSet='177'"

if {${style-font} ne {}} {
append xml " ss:FontName='${style-font}'"
}

if {${style-fontcolor} ne {}} {
append xml " ss:Color='${style-fontcolor}'"
}

if {${style-bold} ne {}} {
append xml " ss:Bold='1'"
}

append xml "/>\n"
}

if {${style-background} ne {}} {
append xml "<Interior ss:Color='${style-background}' ss:Pattern='Solid'/>\n"
}

append xml "</Style>\n"

append ::excel::style_str $xml

return $styleName
}

##########################################################################
########## Функции высокого уровня, которые используются в коде ##########
proc ::excel::book { code_block } {
upvar 1 xmlbook xmlbook
uplevel 1 set xmlbook [::excel::createWorkbook]

set ::excel::style_str {}
array set ::excel::data_str {}

uplevel 1 $code_block
uplevel 1 ns_adp_mimetype "application/vnd.ms-excel"
uplevel 1 {ns_adp_puts [::excel::asXml $xmlbook]}
uplevel 1 ::excel::deleteWorkbook $xmlbook
}

proc ::excel::sheet { name code_block } {
upvar 1 xmlbook xmlbook
uplevel 1 set xmlsheet [::excel::createWorkSheet $xmlbook $name]
uplevel 1 {set ::excel::data_str($xmlsheet) {}}
uplevel 1 $code_block
}

proc ::excel::row { args } {
upvar 1 xmlsheet xmlsheet
lappend cmd ::excel::addRow $xmlsheet
append cmd " "
append cmd $args
uplevel 1 eval $cmd
}

proc ::excel::style { stylename args } {
upvar 1 xmlbook xmlbook
upvar 1 $stylename $stylename
lappend cmd ::excel::createStyle $xmlbook
append cmd " "
append cmd $args
set $stylename [eval $cmd]
}

proc ::excel::columntype { columnIndex type } {
}

Комментариев нет:


(C) Alexey Pechnikov aka MBG, mobigroup.ru