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
|
