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