StarLingPlugins: plugin_excel_export.prg

File plugin_excel_export.prg, 4.5 KB (added by phil, 5 years ago)

Excel export via OLE - source code

Line 
1/* $Id$ */
2
3#include "cfg.h"
4#include "dialog.ch"
5#include "dbstruct.ch"
6
7INIT FUNCTION register()
8  stPluginRegister( "Export to Excel via OLE", {|| export_to_excel() } )
9RETURN 0
10
11
12PROCEDURE export_to_excel(from_file, condition)
13  LOCAL dlg, excel, i, area := Select(), n_row, s, j, k, start, styles, cell, ok, fcount, fields, u, t
14  MEMVAR cfg
15
16  IF Empty(from_file)
17    dlg :=  { ;
18     { st_FILENAME, "Source file (with extension)", stCurrentDbf(), stCurrentMask() }, ;
19     { st_RICHEDIT, "Condition", ".T." } }
20    IF !stDialog("Plugin: Export to Excel via OLE", , dlg)
21      RETURN
22    ENDIF
23    from_file = dlg[1]
24    condition = dlg[2]
25  ENDIF
26
27  IF !File(from_file)
28    RETURN
29  ENDIF
30
31  IF Empty(condition)
32    condition := ".T."
33  ELSE
34    condition := processCondition(condition)
35  ENDIF
36
37  USE (from_file) SHARED NEW READONLY ALIAS _EXCELEXPORT
38  fields := fieldRange(infRead(from_file, "field_list"))
39  fcount := Len(fields)
40  IF fcount == 0
41    AEval( DbStruct(), {|x| AAdd(fields, x[DBS_NAME]) } )
42    fcount := Len(fields)
43  ENDIF
44  IF fcount > 256
45    stMessage("Poor Excel supports only 256 columns, and you have " + LTrim(Str(fcount)) + ". The first 256 fields will be exported.")
46    fcount := 256
47  ENDIF
48
49  excel = win_OleCreateObject("Excel.Application")
50  excel:Workbooks:Add()
51
52  FOR i := 1 TO fcount
53    ok := .F.
54    BEGIN SEQUENCE
55      excel:Cells(1, i):Value := UTF8(aliasName(fields[i]))
56      ok := .T.
57    END SEQUENCE
58    IF !ok
59      stMessage("error while exporting heading "+str(i)+aliasName(fields[i]))
60    ENDIF
61    excel:Cells(1, i):Font:Bold := .T.
62  NEXT
63
64  GO TOP
65  n_row := 2
66  DO WHILE !Eof()
67    IF &(condition)
68      FOR i := 1 TO fcount
69        s := toString(FieldGet(FieldPos(fields[i])))
70        u := UTF8(destyle(s))
71        IF Len(u) > 0 .AND. u[1] == '='
72          /* Need to escape strings starting with = */
73          IF '"' $ u
74            /* Escape also " */
75            s := StrTran(s, '"', '""') // not exactly, but we should care only about UCS2 string
76            u := StrTran(u, '"', '""')
77          ENDIF
78          s := '="' + s + '"'
79          u := '="' + u + '"'
80        ENDIF
81        cell := excel:Cells(n_row, i)
82        ok := .F.
83        BEGIN SEQUENCE
84          //debug("n_row" + Str(n_row) + " n_cell" + Str(i) + " value" + u + " s:" + s)
85          cell:Value = u
86          ok := .T.
87        END SEQUENCE
88        IF !ok
89          stMessage("error while exporting Recno:" + Str(RecNo()) + " field: " + Str(fields[i]) + " value: " + destyle(s))
90        ENDIF
91        j := 1
92        k := 1
93        start := 1
94        styles := { 'B' => .F., 'C' => .F., 'H' => .F., 'I' => .F., 'K' => .F., 'L' => .F., 'U' => .F., 'X' => .F. }
95        u := UCS2(s)
96        DO WHILE j <= Len(u) / 2
97          IF u[j * 2 - 1] == '\' .AND. u[j * 2] == Chr(0)
98            apply_styles(cell, start, k, styles)
99            j++
100            t = u[j * 2 - 1]
101            DO CASE
102              CASE u[j * 2] == Chr(0) .AND. t $ 'BCHIKLU'
103                styles[t] = .T.
104              CASE u[j * 2] == Chr(0) .AND. t $ 'bchiklux'
105                styles[Upper(t)] = .F.
106              CASE u[j * 2] == Chr(0) .AND. t == 'X'
107                IF j < Len(u) / 2
108                  j++
109                  t = u[j * 2 - 1]
110                  IF u[j * 2] == Chr(0) .AND. t == '<'
111                    DO WHILE j <= Len(u) / 2 .AND. !(u[j * 2 - 1] == '>' .AND. u[j * 2] == Chr(0))
112                      j++
113                    ENDDO
114                  ENDIF
115                ENDIF
116                styles['X'] = .T.
117              OTHERWISE
118                k++
119            ENDCASE
120            start := k
121          ELSE
122            k++
123          ENDIF
124          j++
125        ENDDO
126        apply_styles(cell, start, k, styles)
127      NEXT
128      statusstring("Record " + Str(RecNo()) + "/" + LTrim(Str(RecCount())))
129    ENDIF
130    SKIP
131    n_row++
132  ENDDO
133
134  excel:Range(excel:Cells(1, 1), excel:Cells(n_row - 1, fcount)):Font:Name := UTF8(cfg[CFG_WINFONT][1][2])
135  excel:Visible := .T.
136
137  USE
138  SELECT (area)
139RETURN
140
141STATIC PROCEDURE apply_styles(cell, start, k, styles)
142  LOCAL chars
143  IF k > start
144    chars := cell:Characters(start, k - start)
145    IF styles['B']
146      chars:Font:Bold := .T.
147    ENDIF
148    IF styles['C']
149      chars:Font:Size := chars:Font:Size - 4
150    ENDIF
151    IF styles['H']
152      chars:Font:Superscript := .T.
153    ENDIF
154    IF styles['I']
155      chars:Font:Italic := .T.
156    ENDIF
157    IF styles['L']
158      chars:Font:Subscript := .T.
159    ENDIF
160    IF styles['U']
161      chars:Font:Underline := 2
162    ENDIF
163    IF styles['X']
164      chars:Font:Underline := 2
165      chars:Font:Color := 5
166    ENDIF
167  ENDIF
168RETURN