First commit

LICENSE

+Copyright 2018 patekawa
+
+Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
\ No newline at end of file

README.md

+Texcel
+===
+
+## Description
+
+Excelで書いた表をTeXコードに変換するマクロです．
+
+## Requirement
+
+以下の環境で確認しました．
+
+- Windows 7 + Microsoft Excel 2010
+- Windows 10 + Microsoft Excel 2013
+
+## Usage
+
+1. 関数
+
+`Texcel(表の範囲[, キャプション[, ラベル[, 表の配置[, ダブルカラム[, ズーム[, インデントの種類]]]]]])`
+
+- 表の配置: h(デフォルト), t, b, p
+- ダブルカラム: 0, 1
+	* 0のとき`table`環境(デフォルト)，1のとき`table*`環境を使います．
+- インデントの種類
+	* 1 : TAB(デフォルト)
+	* 2 : 半角スペース2文字
+	* 3 : 半角スペース3文字
+
+## Author
+
+- [patekawa](https://github.com/patekawa)

TexcelCls.bas

+Attribute VB_Name = "TexcelCls"
+Private tIndentChr As String
+
+Sub CallTexcel()
+    
+    TexcelForm.Show
+    
+End Sub
+
+' TeXのエスケープ文字をエスケープします
+Function EscapeForTex(text As String)
+
+    Dim res As String
+    
+    res = text
+    res = Replace(res, "\", "\\")
+    res = Replace(res, "_", "\_")
+    res = Replace(res, "#", "\#")
+    res = Replace(res, "$", "\$")
+    res = Replace(res, "&", "\&")
+    res = Replace(res, "%", "\%")
+    res = Replace(res, "{", "\{")
+    res = Replace(res, "}", "\}")
+    
+    EscapeForTex = res
+    
+End Function
+
+' インデント文字をN段分出力します
+Private Function Indent(N As Integer)
+
+    Dim i As Integer
+    Dim res As String
+    
+    res = ""
+    
+    For i = 1 To N
+        res = res & tIndentChr
+    Next i
+    
+    Indent = res
+
+End Function
+
+' ExcelのAlignのコードに対応するTeXのAlign文字を出力します
+Private Function GetAlign(align As Integer)
+
+    Dim chr As String
+    
+    Select Case align
+        Case -4108:
+            chr = "c"
+        Case -4131:
+            chr = "l"
+        Case -4152:
+            chr = "r"
+        Case Else:
+            chr = "c"
+    End Select
+    
+    GetAlign = chr
+    
+End Function
+
+' hlineまたはclineを出力します
+Private Function GetHline(base_r As Long, base_c As Long, row As Long, cols As Long, Optional edge As Integer = xlEdgeBottom)
+
+    Dim allline_flag As Boolean
+    
+    
+    Dim hline() As Integer
+    ReDim hline(cols + 1)
+    hline(cols + 1) = xlLineStyleNone
+    
+    If Cells(base_r + row - 1, base_c).Borders(edge).LineStyle <> xlLineStyleNone Then
+        allline_flag = True
+    Else
+        allline_flag = False
+    End If
+    
+    For i = 1 To cols
+        hline(i) = Cells(base_r + row - 1, base_c + i - 1).Borders(edge).LineStyle
+        If (i > 1) And (hline(i - 1) <> hline(i)) Then
+            allline_flag = False
+        End If
+    Next i
+    
+    Dim hline_str As String
+    hline_str = ""
+    
+    If allline_flag Then
+        hline_str = "\hline"
+    Else
+        Dim linestate As Integer
+        linestate = 0
+        For i = 1 To cols + 1
+            If linestate > 0 And hline(i) = xlLineStyleNone Then
+                hline_str = hline_str & "\cline{" & linestate & "-" & i - 1 & "}"
+            ElseIf linestate = 0 And hline(i) <> xlLineStyleNone Then
+                linestate = i
+            End If
+        Next i
+    End If
+    
+    GetHline = " " & hline_str
+    
+End Function
+
+' 本体です
+' table : 表となるセルの範囲
+' aCaption : キャプション
+' aLabel : ラベル
+' aPos : 位置を示すタグ(h, t, b, p)
+' aDoubleColumn : table / table*
+' aScaleBox : 拡大率
+' aIndent : インデントの文字
+Public Function Excel2Tex( _
+        table As Range, _
+        Optional aCaption As String = "", _
+        Optional aLabel As String = "", _
+        Optional aPos As String = "h", _
+        Optional aDoubleColumn As Boolean = False, _
+        Optional aScaleBox As Double = 1#, _
+        Optional aIndent As String = "")
+
+    Dim rows, cols, i, j As Integer
+    
+    Dim result(2) As Variant
+    Dim textext As String   ' TeX出力テキスト
+    Dim preamble As String  ' プリアンブル
+    Dim tmpchr As String
+    Dim tablecommand As String
+    
+    ' 入力チェック
+    If Not (aPos = "h" Or aPos = "t" Or aPos = "b" Or aPos = "p") Then
+        result(0) = "Error in 'pos'"
+        Excel2Tex = result
+        Exit Function
+    End If
+    
+    If aIndent = "" Then
+        aIndent = chr(9)
+    End If
+    tIndentChr = aIndent
+    
+    Dim multirow_en As Boolean
+    multirow_en = False
+    
+    rows = table.rows.Count
+    cols = table.Columns.Count
+    
+    Dim OpCell As Object    '操作対象のセル
+    Dim base_r, base_c As Long
+    
+    ' tableのタグ指定
+    If aDoubleColumn Then
+        tablecommand = "table*"
+    Else
+        tablecommand = "table"
+    End If
+    
+    preamble = ""
+    
+    ' tableタグ スタート
+    textext = "\begin{" & tablecommand & "}[" & aPos & "]" & vbCrLf
+    textext = textext & Indent(1) & "\centering" & vbCrLf
+    textext = textext & Indent(1) & "\caption{" & aCaption & "}" & vbCrLf
+    textext = textext & Indent(1) & "\label{" & aLabel & "}" & vbCrLf
+    
+    If aScaleBox <> 1# Then
+        textext = textext & Indent(1) & "\scalebox{" & aScaleBox & "}{" & vbCrLf
+    End If
+    
+    ' 表の設定: 1列目で判定
+    textext = textext & Indent(1) & "\begin{tabular}{"
+    
+    base_r = table(1).row
+    base_c = table(1).Column
+    
+    ' 左罫線の指定
+    tmpchr = ""
+    For i = 1 To rows
+        If Cells(base_r + i - 1, base_c).Borders(xlEdgeLeft).LineStyle <> xlLineStyleNone Then
+            tmpchr = "|"
+        End If
+    Next i
+    textext = textext & tmpchr
+    
+    ' 全体的なセルのAlign
+    For i = 1 To cols
+        Set OpCell = Cells(base_r, base_c + i - 1)
+        textext = textext & GetAlign(OpCell.HorizontalAlignment)
+        
+        tmpchr = ""
+        For j = 1 To rows
+            If Cells(base_r + j - 1, base_c + i - 1).Borders(xlEdgeRight).LineStyle <> xlLineStyleNone Then
+                tmpchr = "|"
+            End If
+        Next j
+        textext = textext & tmpchr
+    Next i
+    textext = textext & "}"
+    
+    ' 上罫線の指定
+    textext = textext & GetHline((base_r), (base_c), 1, (cols), xlEdgeTop)
+    textext = textext & vbCrLf
+    
+    Dim FirstColumnFlag As Boolean
+    
+    For i = 1 To rows
+        FirstColumnFlag = True
+        textext = textext & Indent(2) & splitchr
+        For j = 1 To cols
+            Set OpCell = Cells(base_r + i - 1, base_c + j - 1)
+            
+            ' セルの結合の判定
+            If OpCell.MergeCells Then
+                Dim MergeAreaColumns, MergeAreaRows As Integer
+                Dim MergeAreaText, MergeAreaAlign As String
+                MergeAreaColumns = OpCell.MergeArea.Columns.Count
+                MergeAreaRows = OpCell.MergeArea.rows.Count
+                MergeAreaText = EscapeForTex(OpCell.MergeArea.Cells(1, 1).text)
+                ' セルのAlignの設定
+                MergeAreaAlign = ""
+                If OpCell.MergeArea.Cells(1, 1).Borders(xlEdgeLeft).LineStyle <> xlLineStyleNone Then
+                    MergeAreaAlign = MergeAreaAlign & "|"
+                End If
+                MergeAreaAlign = MergeAreaAlign & GetAlign(OpCell.HorizontalAlignment)
+                If OpCell.MergeArea.Cells(1, MergeAreaColumns).Borders(xlEdgeRight).LineStyle <> xlLineStyleNone Then
+                    MergeAreaAlign = MergeAreaAlign & "|"
+                End If
+                If OpCell.Column = OpCell.MergeArea.Cells(1, MergeAreaColumns).Column Then
+                    If Not FirstColumnFlag Then
+                        textext = textext & " & "
+                    End If
+                    If MergeAreaRows > 1 Then
+                        If OpCell.row = OpCell.MergeArea.Cells(1, mergeareacolmuns).row Then
+                            multirow_en = True
+                            If MergeAreaColumns > 1 Then
+                                textext = textext & "\multicolumn{" & MergeAreaColumns & "}{" & MergeAreaAlign & "}{\multirow{" & MergeAreaRows & "}{*}{" & MergeAreaText & "}}"
+                            Else
+                                textext = textext & "\multirow{" & MergeAreaRows & "}{*}{" & MergeAreaText & "}"
+                            End If
+                        Else
+                            If MergeAreaColumns > 1 Then
+                                textext = textext & "\multicolumn{" & MergeAreaColumns & "}{" & MergeAreaAlign & "}{~}"
+                            Else
+                                textext = textext & " "
+                            End If
+                        End If
+                    Else
+                        textext = textext & "\multicolumn{" & MergeAreaColumns & "}{" & MergeAreaAlign & "}{" & MergeAreaText & "}"
+                    End If
+                Else
+                    GoTo ContinueJ
+                End If
+            Else
+                If Not FirstColumnFlag Then
+                    textext = textext & " & "
+                End If
+                textext = textext & EscapeForTex(OpCell.text)
+            End If
+            
+            
+            FirstColumnFlag = False
+ContinueJ:
+        Next j
+        textext = textext & " \\"
+        
+        ' 下罫線の判定
+        textext = textext & GetHline((base_r), (base_c), (i), (cols))
+        
+        textext = textext & vbCrLf
+    Next i
+    
+    textext = textext & Indent(1) & "\end{tabular}" & vbCrLf
+    If aScaleBox <> 1# Then
+        textext = textext & Indent(1) & "}" & vbCrLf
+    End If
+    textext = textext & "\end{" & tablecommand & "}"
+    
+    If multirow_en Then
+        preamble = preamble & "\usepackage{multirow}" & vbCrLf
+    End If
+    
+    result(0) = textext
+    result(1) = preamble
+    result(2) = "Reserved"
+    
+    Excel2Tex = result
+
+End Function
+
+' ワークシートから呼び出すときはこちらです
+Public Function Texcel( _
+        Area As Range, _
+        Optional Caption As String = "", _
+        Optional Label As String = "", _
+        Optional Pos As String = "h", _
+        Optional DoubleColumn As Boolean = False, _
+        Optional Zoom As Double = 1#, _
+        Optional Indent As Integer = 1) As String
+        
+    Dim res As Variant
+    Dim IndentChr As String
+    
+    Select Case Indent
+        Case 1
+            IndentChr = chr(9)
+        Case 2
+            IndentChr = "  "
+        Case 3
+            IndentChr = "    "
+        Case Else
+            IndentChr = chr(9)
+    End Select
+    
+    res = Excel2Tex(Area, Caption, Label, Pos, DoubleColumn, Zoom, IndentChr)
+    
+    Texcel = res(0)
+
+End Function