JavaModule.bas

Attribute VB_Name = "JavaModule"

Option Explicit

''' Java コンパイル
Public Sub JavaCompile()

    CompileAndRun True
    
End Sub

''' Java コンパイルと実行
Public Sub JavaRun()

    CompileAndRun False

End Sub

''' ソースのコンパイルおよびプログラムの実行を行います。
Private Sub CompileAndRun(compileOnly As Boolean)
    
    Dim srcDir As String
    Dim clsDir As String
    Dim sheet As Worksheet
    Dim classpath As String
    Dim args As String
    Dim source As String
    Dim pkgName As String
    Dim filePath As String
    Dim activeFilePath As String
    Dim shell As Object
    Dim command As String
    Dim rc As Integer

    'compile env
    srcDir = ActiveWorkbook.Path & Application.PathSeparator & "src" & Application.PathSeparator & "main"
    clsDir = ActiveWorkbook.Path & Application.PathSeparator & "classes"
    
    For Each sheet In ActiveWorkbook.Sheets
    
        If sheet.Name = ".classpath" Then
            source = ReadSheet(sheet)
            classpath = CreateClasspath(source)
        End If
        
        If sheet.Name = ".args" Then
            source = ReadSheet(sheet)
            args = CreateArgs(source)
        End If
        
        If EndsWith(sheet.Name, ".java") Then
            
            source = ReadSheet(sheet)
            pkgName = GetPackageName(source)
            filePath = CreateFilePath(srcDir, pkgName, sheet.Name)
            WriteTextFile filePath, source
            
            '現在アクティブなシートのファイルパスを保存
            If sheet.Index = ActiveSheet.Index Then
                activeFilePath = filePath
            End If
            
        End If
        
    Next sheet
    
    '現在アクティブなシートのファイルをコンパイルする
    If activeFilePath <> "" Then
        MkDirs clsDir
        Set shell = CreateObject("WScript.Shell")
        
        'javac 実行。javac は環境変数 Path から見えるところに。このままだとコンパイルエラーの内容がわからない＞＜
        command = "cmd /c cd " & ActiveWorkbook.Path & " & javac -cp " & classpath & " -d " & clsDir & " " & activeFilePath
        
        If compileOnly Then
            rc = shell.Run(command & " & pause", 1, True)
        Else
            rc = shell.Run(command, 0, True)
            If rc = 0 Then
                command = "cmd /c cd " & ActiveWorkbook.Path & " & java -cp " & classpath & ";" & clsDir & " " & Replace(Mid(activeFilePath, Len(srcDir) + 2, Len(activeFilePath) - Len(srcDir) - 1 - Len(".java")), Application.PathSeparator, ".") & " " & args & " & pause"
                rc = shell.Run(command)
            End If
        End If
        
    End If
End Sub


''' 文字列からコマンドラインクラスパスを生成します
Private Function CreateClasspath(source As String)
    
    Dim re As Object
    
    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "\s+"
    re.Global = True
    
    CreateClasspath = re.Replace(source, ";") 'Windows でのクラスパス区切り文字
    
End Function

''' 文字列からコマンドライン実行引数を生成します。
Private Function CreateArgs(source As String)
    
    Dim re As Object
    
    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "\s+"
    re.Global = True
    
    CreateArgs = re.Replace(source, " ")
    
End Function

''' ソースコードからパッケージ名を取り出します。
''' パッケージ名が設定されていない場合はブランクを返します。
Private Function GetPackageName(source As String)
    
    Dim packageName As String
    Dim str As String
    Dim re As Object
    Dim mc As Object
    Dim m As Object
    
    Set re = CreateObject("VBScript.RegExp")
    
    'まずソース先頭のコメントを除去
    '@see https://gist.github.com/346584
    re.Pattern = "^(\s*(\/)(?:\*[\s\S]*?\*\/|\/.*))+"
    str = re.Replace(source, "")
    
    'ソースの最初に出てくる package 宣言から package 名を取得(package aaa/*hoge*/bbb; みたいなのはサポートしない)
    re.Pattern = "^\s*package\s+(.*)\s*;"
    Set mc = re.Execute(str)
    
    If mc.count = 0 Then
        packageName = ""
    Else
        packageName = mc.Item(0).SubMatches(0)
    End If
    
    '不正なパッケージ名でないかチェック
    If InStr(packageName, "/") > 0 Or InStr(packageName, "\") > 0 Or InStr(packageName, "..") > 0 Then
        Err.Raise 1000, "GetPackageName", "パッケージ名が不正です。[" & packageName & "]"
    End If
    
    GetPackageName = packageName
    
End Function

''' ソースフォルダとパッケージ名でファイルのパスを構築します。
Function CreateFilePath(srcDir As String, pkgName As String, fileName As String) As String
    
    Dim fileDir As String
    
    If pkgName = "" Then
        fileDir = Application.PathSeparator
    Else
        fileDir = Application.PathSeparator & Replace(pkgName, ".", Application.PathSeparator) & Application.PathSeparator
    End If
    
    CreateFilePath = srcDir & fileDir & fileName
    
End Function


''' シート内の全てのセルの文字列を連結して返します。
''' セルから文字列を取得する方法については {@link #GetText} を参照してください。
Private Function ReadSheet(sheet As Worksheet) As String

    Dim str As String
    Dim c As range
    Dim re As Object '@see http://d.hatena.ne.jp/s-n-k/20081007/1223395593
    
    For Each c In sheet.range(sheet.Cells(1, 1), sheet.Cells.SpecialCells(xlLastCell))
        If c.Column = 1 Then
            If c.Row <> 1 Then
                str = str & vbCrLf
            End If
            str = str & GetText(c)
        Else
            str = str & vbTab & GetText(c)
        End If
    Next c
    
    '末尾の空白を削除
    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "[ \t]+$"
    re.Global = True
    re.MultiLine = True
    
    str = re.Replace(str, "")
    
    ReadSheet = str
    
End Function

''' セルから文字列を取得します。
''' 取り消し線が設定されている文字は取り除かれます。
''' @see http://stabucky.com/wp/archives/3209
Private Function GetText(cell As range) As String

    Dim i As Integer
    Dim org As String
    Dim result As String
    
    org = cell.text
    If org = "" Then
        result = ""
    ElseIf cell.Font.Strikethrough = True Then
        result = ""
    ElseIf cell.Font.Strikethrough = False Then
        result = org
    Else ' cell.Font.Strikethrough = Null
        For i = 1 To Len(org)
            If Not cell.Characters(i, 1).Font.Strikethrough Then
                result = result + Mid(org, i, 1)
            End If
        Next
    End If
    
    GetText = result
    
End Function

''' テキストファイルを出力します。
''' @see http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_110_040.html
Private Sub WriteTextFile(fileName As String, strData As String)

    Dim fso As Object
    Dim ts As Object
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    If Not fso.FolderExists(fso.GetParentFolderName(fileName)) Then
        MkDirs fso.GetParentFolderName(fileName)
    End If
    
    Set ts = fso.CreateTextFile(fileName:=fileName, Overwrite:=True)
    
    ts.Write strData
    ts.Close
    
End Sub

''' ディレクトリを作成します。
''' @see http://pnpk.net/cms/archives/308
Private Sub MkDirs(dirName As String)

    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    If Not fso.FolderExists(dirName) Then
        If Not fso.FolderExists(fso.GetParentFolderName(dirName)) Then
            MkDirs fso.GetParentFolderName(dirName)
        End If
        fso.CreateFolder dirName
    End If
    
End Sub

''' String.EndsWith の実装
Private Function EndsWith(target As String, search As String)
    '@see http://dev.ariel-networks.com/Members/uchida/javascript7684startswith/
    EndsWith = Len(target) >= Len(search) And InStr(Len(target) - Len(search) + 1, target, search) <> 0
End Function