summaryrefslogtreecommitdiff
path: root/support/xl2latex/xl2latex.bas
blob: 403852b67ec60a2b89a708bd5af86319e635095d (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
Attribute VB_Name = "Latex"
' xl2latex: excel table to latex tabular converter
'
' works only with excel97 (and hopefully above, you never know what microsoft does)
' for color, package "colortbl" is needed (put \usepackage{colortbl} in preamble)
'
' version: 0.9.3
' date: 2001-08-14
' copyright (c) 2001 ronny buchmann <rbla@gmx.de>
'
' ideas taken from Excel2Latex by joachim marder
'
' 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 2
' 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, write to the Free Software
' Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA
' or visit http://www.gnu.org
'
' attention:
' - text without specific alignment (text left, numbers right) is right aligned in latex, if
'   you want it other, format the cells that way
'   or shorter: numbers prefered
'
' features:
' - merged cells (only horizontal, because auf latex)
' - text centered across cells
' - colored cells
' - colored text
' - latex math in cells
' - normal and double borders (with latex limits)
' - hidden rows and columns are ignored
' - cells with wrapped text (uses excels cell width)
'
' todo:
' - cells with wrapped text could be improved i think
' - font sizes
'
' not-todo:
' - vertical merged cells -> the only always working way i see are tables inside tables, too difficult, really
'   one solution would be the use of \raisebox, if you want it put in in the cell


Sub xl2latex()
Dim selcells As Object 'selected cells
Dim texfile As Variant 'filename
Dim file As Integer 'filehandle
Dim r As Object 'row
Dim i, j, k As Integer 'indices
Dim colored As Boolean
    
    If Selection Is Nothing Then Beep: Exit Sub

    'save in directory of current file
    ChDir (ActiveWorkbook.Path)
    ChDrive (Left(ActiveWorkbook.Path, 1))
    texfile = ActiveSheet.Name & ".tex"
    texfile = Application.GetSaveAsFilename(texfile, "LaTeX files (*.tex), *.tex", , "File export")
    If texfile = False Then Exit Sub
    file = FreeFile(0)
    Open texfile For Output As #file
    
    Set selcells = Selection
    Call head(file, selcells)
    
    If selcells.Rows(1).Borders(xlEdgeTop).LineStyle <> xlLineStyleNone Then Print #file, "\hline"
    For i = 1 To selcells.Rows.Count ' for each row
        Set r = selcells.Rows(i)
        If r.Rows.Hidden = False Then ' hidden row?
            For j = 1 To r.cells.Count ' foreach cell in row
                If ActiveSheet.Columns(selcells.Columns(j).Column).Hidden = False Then ' hidden column?
                    ' check for multicolumns
                    multicells = 0
                    If r.cells(j).HorizontalAlignment = xlHAlignCenterAcrossSelection Then
                        multicells = 1
                        For k = 1 To r.cells.Count - j 'rest of the row
                            If r.cells(j + k).HorizontalAlignment = xlHAlignCenterAcrossSelection _
                                And ActiveSheet.Columns(r.cells(j + k).Column).Hidden = False Then
                                If r.cells(j + k) = "" Then 'centering across cells works until next filled cell
                                    multicells = multicells + 1
                                Else
                                    Exit For
                                End If
                            End If
                        Next k 'get multicolumn width
                        alignment = "c"
                    End If
                    If r.cells(j).MergeCells = True Then
                        multicells = 1
                        For k = 1 To r.cells.Count - j 'rest of the row
                            'merged cell has same column and is not hidden
                            If r.cells(j + k).MergeArea.Column = r.cells(j).Column _
                                And ActiveSheet.Columns(r.cells(j + k).Column).Hidden = False Then
                                multicells = multicells + 1
                            End If
                        Next k 'get multicolumn width
                        alignment = align(r.cells(j))
                    End If
                    If r.cells(j).Interior.color <> RGB(255, 255, 255) Then
                        If multicells = 0 Then multicells = 1
                        alignment = align(r.cells(j))
                        colored = True
                    Else
                        colored = False
                    End If
                    If multicells > 0 Then 'multicolumn code needed
                        Print #file, "\multicolumn{"; CStr(multicells); "}";
                        Print #file, "{"; leftborder(r.cells, j); 'latex prints bold border, strange!
                        If colored = True Then Print #file, bgcolor(r.cells(j).Interior.color);
                        Print #file, alignment; rightborder(r.cells, j, multicells); "}";
                        Print #file, "{"; text(r.cells(j)); "}";
                        j = j + multicells - 1
                    Else 'normal cell
                        Print #file, text(r.cells(j));
                    End If
                    If j < r.cells.Count Then Print #file, " & ";
                End If ' hidden column
            Next j 'next column
            Print #file, " \\"
            If r.Borders(xlEdgeBottom).LineStyle <> xlLineStyleNone Then
                If r.Borders(xlEdgeBottom).LineStyle = xlDouble Then
                    Print #file, "\hline"
                End If
                Print #file, "\hline"
            End If
        End If 'hidden row
    Next i 'next row
    
    'end
    Print #file, "\end{tabular}"
    Close #file
    
End Sub


' print table head
Function head(ByVal file As Integer, selcells As Range)
Dim i As Integer

    Print #file, "\begin{tabular}{";
    Print #file, leftborder(selcells, 1);
    For i = 1 To selcells.Columns.Count
        If ActiveSheet.Columns(selcells.Columns(i).Column).Hidden = False Then
            Print #file, align(selcells.Columns(i));
            Print #file, rightborder(selcells, i, 1);
        End If
    Next i
    Print #file, "}"
    
End Function


' get alignment of cells
Function align(sel As Range)
Dim tmpsel As Range

    If sel.HorizontalAlignment <> Null Then
        Set tmpsel = sel
    Else 'unknown alignment for whole column, use first row instead
        Set tmpsel = sel.Rows(1)
    End If
    Select Case tmpsel.HorizontalAlignment
        Case xlHAlignLeft
            align = "l"
        Case xlHAlignCenter
            align = "c"
        Case Else 'right align for numbers, do manual left align for text
            align = "r"
    End Select
    
End Function


' get left border of cell
Function leftborder(actrow As Range, ByVal colindex As Integer)

    leftborder = ""
    If colindex = 1 Then
        If actrow(1).Borders(xlEdgeLeft).LineStyle <> xlLineStyleNone Then leftborder = "|"
        If actrow(1).Borders(xlEdgeLeft).LineStyle = xlDouble Then leftborder = "||"
    Else
        If (actrow(colindex).Borders(xlEdgeLeft).LineStyle <> xlLineStyleNone) Or _
            (actrow(colindex - 1).Borders(xlEdgeRight).LineStyle <> xlLineStyleNone) Then
            leftborder = "|"
            If (actrow(colindex).Borders(xlEdgeLeft).LineStyle = xlDouble) Or _
                (actrow(colindex - 1).Borders(xlEdgeRight).LineStyle = xlDouble) Then
                leftborder = "||"
            End If
        End If
    End If

End Function


' get right border of cell
Function rightborder(actrow As Range, ByVal colindex As Integer, ByVal colwidth As Integer)

    If (actrow(colindex + colwidth - 1).Borders(xlEdgeRight).LineStyle <> xlLineStyleNone) Or _
        (actrow(colindex + colwidth).Borders(xlEdgeLeft).LineStyle <> xlLineStyleNone) Then
        rightborder = "|"
        If (actrow(colindex + colwidth - 1).Borders(xlEdgeRight).LineStyle = xlDouble) Or _
            (actrow(colindex + colwidth).Borders(xlEdgeLeft).LineStyle = xlDouble) Then
            rightborder = rightborder & "|"
        End If
    Else
        rightborder = ""
    End If

End Function


' color attribute of cell (background)
Function bgcolor(ByVal color As Long)

    bgcolor = ">{\columncolor[rgb]{" & rgbcolor(color) & "}}"

End Function


' color attribute of text (foreground)
Function fgcolor(ByVal color As Long)

    fgcolor = "\textcolor[rgb]{" & rgbcolor(color) & "}"
    
End Function


' convert excel color to latex rgb
Function rgbcolor(ByVal color As Long)
Dim red, green, blue As Single

    blue = color \ 65536
    green = (color - (blue * 65536)) \ 256
    red = (color - (blue * 65536) - (green * 256))
    blue = blue / 255
    green = green / 255
    red = red / 255
    rgbcolor = Format(red, "0.000") & "," & Format(green, "0.000") & "," & Format(blue, "0.000")
    rgbcolor = Left(rgbcolor, 1) & "." & Mid(rgbcolor, 3, 5) & "." & Mid(rgbcolor, 9, 5) _
                & "." & Right(rgbcolor, 3)

End Function


' text in cell
Function text(actcell As Range)
Dim pos As Integer

    text = actcell.text
    ' quote special chars
    pos = InStr(text, "%")
    If (pos > 0) Then 'comment doesnt make sense within table
        text = Mid(text, 1, pos - 1) & "\" & Mid(text, pos, Len(text))
    End If
    pos = InStr(text, "$")
    If (pos > 0) Then
        If (InStr(pos + 1, text, "$") = 0) Then 'currencies appear only once and have to be quoted
            text = Mid(text, 1, pos - 1) & "\" & Mid(text, pos, Len(text))
        End If
    End If
    If actcell.Font.color <> 0 Then 'colored text
        text = fgcolor(actcell.Font.color) & "{" & text & "}"
    End If
    ' set font style
    If actcell.Font.Bold Then text = "{\textbf " & text & "}"
    If actcell.Font.Italic Then text = "{\textit " & text & "}"
    ' wrapped text
    If actcell.WrapText = True Then text = "\parbox{" & actcell.width & "pt}{" & text & "}"
    
End Function


' load toolbar
Sub loadtoolbar()
Dim i As Integer
    
    For i = 1 To CommandBars.Count
        If CommandBars(i).Name = "LaTeX" Then GoTo later
    Next i
    CommandBars.Add Name:="LaTeX"
later:
    CommandBars("LaTeX").Visible = False
    CommandBars("LaTeX").Position = msoBarTop
    'overwrite the Excel2Latex button since Excel2LaTeX is now obsolete
    With CommandBars("LaTeX")
        If .Controls.Count = 0 Then .Controls.Add
        .Controls(1).FaceId = 244
        .Controls(1).Caption = "LaTeX export"
        .Controls(1).DescriptionText = "Export selection as LaTeX table"
        .Controls(1).TooltipText = .Controls(1).DescriptionText
        .Controls(1).OnAction = "xl2latex"
        .Visible = True
    End With

End Sub


Sub Auto_Open()

    ThisWorkbook.Windows(1).Visible = False 'hide the sheets, only a macro is here
    Call loadtoolbar
    
End Sub


Sub Auto_Close()

    Call loadtoolbar
    
End Sub