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 <[email protected]>
'
' 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

You are viewing proxied material from ftp.icm.edu.pl. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.