Attribute VB_Name = "VbaIntegrationHelper"
'Attribute VB_Name = "VbaIntegrationHelper"
Option Explicit

' ■ このモジュールについて：

' - VBEからアプリに連携
'  コードの作成はVBEをメインに、作成したコードをアプリで管理したい場合、こちらのモジュールをお使いできます。
'  ローカルAPIを呼び出して、VBE上のモジュールをアップロードしたり、アプリ上のコードをこのファイルにインポートできます。

' ■ 使用方法:

' - 前提:
'   1) アプリを実行し、ローカルサーバ http://127.0.0.1:5000 が起動していること
'   2) 信頼センターで「VBAプロジェクトオブジェクトモデルへの信頼アクセス」を有効化
'      Excel: オプション → セキュリティセンター → セキュリティセンターの設定 → マクロの設定
'      Access: オプション → トラストセンター → トラストセンターの設定 → マクロ設定
'   3) 現状、アプリ上のパスワード認証を有効している場合連携できません。



' ■ 設定：

' - ローカルサーバー設定:
Private Const STR_API_BASE1 As String = "http://127.0.0.1:5000"
Private Const STR_API_BASE2 As String = "http://127.0.0.1:8000"

' - アップロードしたいVBE内のモジュール名を設定：
Private Const STR_TARGET_MOD_NAME As String = "あああ"

' - インポート先のモジュール名設定：
Private Const STR_IMPORT_MOD_NAME As String = "いいい"

' - アップロード時のコードタイトル名（任意）：
Private Const STR_UPLOAD_CODE_NAME As String = ""



' ■ アップロード・インポートマクロ：

'A:　以下の関数を実行すると、設定で指定したモジュールをアップロードします
Private Sub exeUploadVBEMod()

    Call UploadModuleByName(STR_TARGET_MOD_NAME, STR_UPLOAD_CODE_NAME)

End Sub

'B:　以下の関数を実行すると、アプリのコード一覧を取得しシートに表示、選択したコードをインポートします
Private Sub exeInportAppCode()

    Call PickAndInjectExcel
    
End Sub






'以下連携用の関数です（改変OKです）
'########################

'APIベースURLを取得する関数
Private Function fncGetApiBase() As String
    Dim arrBases(1) As String
    Dim lngIndex As Long
    Dim objRequest As Object
    Dim blnSuccess As Boolean
    
    arrBases(0) = STR_API_BASE1
    arrBases(1) = STR_API_BASE2
    
    For lngIndex = 0 To UBound(arrBases)
        On Error Resume Next
        Set objRequest = CreateObject("WinHttp.WinHttpRequest.5.1")
        objRequest.SetTimeouts 2000, 2000, 3000, 3000
        objRequest.Open "GET", arrBases(lngIndex) & "/api/list-codes-plain", False
        objRequest.Send
        blnSuccess = (Err.Number = 0)
        On Error GoTo 0
        
        If blnSuccess And objRequest.Status = 200 Then
            fncGetApiBase = arrBases(lngIndex)
            Exit Function
        End If
    Next lngIndex
    
    fncGetApiBase = arrBases(0)
End Function

'JSON文字列をエスケープする関数
Public Function fncEscapeJson(ByVal strInput As String) As String
    Dim strResult As String
    
    strResult = strInput
    strResult = Replace(strResult, "\", "\\")
    strResult = Replace(strResult, """", "\""")
    strResult = Replace(strResult, vbCrLf, "\r\n")
    strResult = Replace(strResult, vbCr, "\r")
    strResult = Replace(strResult, vbLf, "\n")
    
    fncEscapeJson = strResult
End Function

'コードIDを指定してコードを注入するメイン関数
Public Sub InjectCodeById(ByVal strCodeId As String, _
                          ByVal strModuleName As String, _
                          Optional ByVal strTargetApp As String = "excel", _
                          Optional ByVal strFilePath As String = "")
    Dim objRequest As Object
    Dim strBaseUrl As String
    Dim strBody As String
    
    On Error GoTo lbl_Err
    
    strBaseUrl = fncGetApiBase()
    Set objRequest = CreateObject("WinHttp.WinHttpRequest.5.1")
    
    objRequest.Open "POST", strBaseUrl & "/api/transfer-by-id", False
    objRequest.SetRequestHeader "Content-Type", "application/json"
    
    strBody = "{""codeId"":""" & fncEscapeJson(strCodeId) & _
              """,""moduleName"":""" & fncEscapeJson(strModuleName) & _
              """,""targetApp"":""" & fncEscapeJson(strTargetApp) & _
              """,""filePath"":""" & fncEscapeJson(strFilePath) & """}"
    
    objRequest.Send strBody
    
    If objRequest.Status <> 200 Then
        MsgBox "転送APIエラー: " & objRequest.Status & " / " & objRequest.ResponseText, vbCritical
    Else
        MsgBox "転送が完了しました ( " & strModuleName & " )", vbInformation
    End If
    
    Exit Sub
    
lbl_Err:
    MsgBox "InjectCodeById エラー: " & Err.Description, vbCritical
End Sub

'コード一覧から選択して注入
Public Sub PickAndInjectExcel()
On Error GoTo lbl_Err

    Dim objRequest As Object
    Dim wsPicker As Worksheet
    Dim wbCurrent As Workbook
    Dim rngSelection As Range

    Dim strBaseUrl As String
    Dim strPickedId As String
    Dim arrParts() As String
    Dim arrLines() As String

    Dim lngRow As Long
    Dim lngIndex As Long

    Dim blnSheetExists As Boolean

    strBaseUrl = fncGetApiBase()
    Set objRequest = CreateObject("WinHttp.WinHttpRequest.5.1")
    
    objRequest.Open "GET", strBaseUrl & "/api/list-codes-plain", False
    objRequest.Send
    
    If objRequest.Status <> 200 Then
        MsgBox "一覧取得エラー: " & objRequest.Status & " / " & objRequest.ResponseText, vbCritical
        Exit Sub
    End If
    
    arrLines = Split(objRequest.ResponseText, vbCrLf)
    Set wbCurrent = ThisWorkbook
    blnSheetExists = False
    
    'ピッカー用シートの作成/取得
    For Each wsPicker In wbCurrent.Worksheets
        If wsPicker.Name = "CodePicker" Then
            blnSheetExists = True
            Exit For
        End If
    Next wsPicker
    
    If wsPicker Is Nothing Then
        Set wsPicker = wbCurrent.Worksheets.Add(After:=wbCurrent.Worksheets(wbCurrent.Worksheets.Count))
        wsPicker.Name = "CodePicker"
    End If
    
    With wsPicker
        .Cells.Clear
        
        .Range("A1").Value = "コードID"
        .Range("B1").Value = "名前"
        .Range("C1").Value = "カテゴリ"
        
        lngRow = 2
        
        For lngIndex = 0 To UBound(arrLines)
            If Trim(arrLines(lngIndex)) <> "" Then
                arrParts = Split(arrLines(lngIndex), vbTab)
                
                If UBound(arrParts) >= 1 Then
                    .Cells(lngRow, 1).Value = arrParts(0)
                    .Cells(lngRow, 2).Value = arrParts(1)
                    
                    If UBound(arrParts) >= 2 Then
                        .Cells(lngRow, 3).Value = arrParts(2)
                    End If
                    
                    lngRow = lngRow + 1
                End If
            End If
        Next lngIndex
        
        .Columns("A:C").EntireColumn.AutoFit
        .Activate
        
        MsgBox "シート上に入力されたコード一覧から、注入したいコードの「名前」列の「セル」を選択してください。", vbInformation
        
        On Error Resume Next
        Set rngSelection = Application.InputBox(Prompt:="シート上から「名前列のセル」を選択 ( 例 : $B$3 )", Type:=8)
        On Error GoTo lbl_Err
        
        If rngSelection Is Nothing Then Exit Sub
        
        If rngSelection.Column <> 2 Then
            MsgBox "名前列(B列)のセルを選択してください。", vbExclamation
            Exit Sub
        End If
        
        strPickedId = .Cells(rngSelection.Row, 1).Value
        
        If Len(strPickedId) = 0 Then
            MsgBox "IDが取得できませんでした。", vbExclamation
            Exit Sub
        End If
    End With
    
    ' ローカル注入を実行
    InjectSelfById strPickedId, STR_IMPORT_MOD_NAME
    
    Exit Sub
    
lbl_Err:
    MsgBox "PickAndInjectExcel エラー: " & Err.Description, vbCritical
End Sub

'ローカル環境にコードを注入する関数
Public Sub InjectSelfById(ByVal strCodeId As String, ByVal strModuleName As String)

    Dim objRequest As Object
    Dim strBaseUrl As String
    Dim strCodeText As String
    Dim objVbe As Object
    Dim objProject As Object
    Dim objComponents As Object
    Dim objComponent As Object
    Dim objCodeModule As Object
    Dim lngIndex As Long
    Dim lngCount As Long
    Dim lngLineCount As Long
    Dim blnFound As Boolean
    
    On Error GoTo lbl_Err
    
    strBaseUrl = fncGetApiBase()
    Set objRequest = CreateObject("WinHttp.WinHttpRequest.5.1")
    
    objRequest.SetTimeouts 3000, 3000, 15000, 15000
    objRequest.Open "GET", strBaseUrl & "/api/codes/" & fncEscapeJson(strCodeId) & "/plain?decrypt=true", False
    objRequest.SetRequestHeader "Accept", "text/plain"
    objRequest.Send
    
    If objRequest.Status <> 200 Then
        MsgBox "コード取得エラー: " & objRequest.Status & " / " & objRequest.ResponseText, vbCritical
        Exit Sub
    End If
    
    strCodeText = objRequest.ResponseText
    
    Set objVbe = Application.vbe
    Set objProject = objVbe.VBProjects(1)
    Set objComponents = objProject.VBComponents
    
    blnFound = False
    
    '既存モジュールを検索
    lngCount = objComponents.Count
    
    For lngIndex = 1 To lngCount
        If objComponents.Item(lngIndex).Name = strModuleName Then
            Set objComponent = objComponents.Item(lngIndex)
            blnFound = True
            Exit For
        End If
    Next lngIndex
    
    'モジュールが存在しない場合は新規作成
    If Not blnFound Then
        Set objComponent = objComponents.Add(1) '1 = 標準モジュール
        On Error Resume Next
        objComponent.Name = strModuleName
        On Error GoTo lbl_Err
    End If
    
    Set objCodeModule = objComponent.CodeModule
    lngLineCount = objCodeModule.CountOfLines
    
    '既存コードを削除
    If lngLineCount > 0 Then
        objCodeModule.DeleteLines 1, lngLineCount
    End If
    
    '新しいコードを追加
    objCodeModule.AddFromString strCodeText
    
    MsgBox "ローカル注入が完了しました（" & strModuleName & "）", vbInformation
    
    Exit Sub
    
lbl_Err:
    MsgBox "InjectSelfById エラー: " & Err.Description, vbCritical
End Sub

'コード一覧を取得する関数
Public Function fncGetCodeList() As Variant
    Dim objRequest As Object
    Dim strBaseUrl As String
    Dim arrLines() As String
    Dim arrResult() As String
    Dim lngIndex As Long
    Dim lngCount As Long
    
    On Error GoTo lbl_Err
    
    strBaseUrl = fncGetApiBase()
    Set objRequest = CreateObject("WinHttp.WinHttpRequest.5.1")
    
    objRequest.Open "GET", strBaseUrl & "/api/list-codes-plain", False
    objRequest.Send
    
    If objRequest.Status = 200 Then
        arrLines = Split(objRequest.ResponseText, vbCrLf)
        lngCount = 0
        
        '※ 空行を除く行数をカウント
        For lngIndex = 0 To UBound(arrLines)
            If Trim(arrLines(lngIndex)) <> "" Then
                lngCount = lngCount + 1
            End If
        Next lngIndex
        
        If lngCount > 0 Then
            ReDim arrResult(1 To lngCount, 1 To 3)
            lngCount = 0
            
            For lngIndex = 0 To UBound(arrLines)
                If Trim(arrLines(lngIndex)) <> "" Then
                    Dim arrParts() As String
                    arrParts = Split(arrLines(lngIndex), vbTab)
                    
                    lngCount = lngCount + 1
                    arrResult(lngCount, 1) = arrParts(0)
                    arrResult(lngCount, 2) = arrParts(1)
                    
                    If UBound(arrParts) >= 2 Then
                        arrResult(lngCount, 3) = arrParts(2)
                    Else
                        arrResult(lngCount, 3) = ""
                    End If
                End If
            Next lngIndex
            
            fncGetCodeList = arrResult
        Else
            fncGetCodeList = Empty
        End If
    Else
        fncGetCodeList = Empty
    End If
    
    Exit Function
    
lbl_Err:
    fncGetCodeList = Empty
End Function

'現在アクティブなコードモジュールをアップロード（新規作成）
Public Sub UploadCurrentModule(Optional ByVal strDescription As String = "")
    On Error GoTo lbl_Err
    Dim objVbe As Object, objProject As Object, objComponents As Object
    Dim objComponent As Object, objCodeModule As Object
    Set objVbe = Application.vbe
    Set objProject = objVbe.VBProjects(1)
    Set objComponents = objProject.VBComponents
    Dim strModuleName As String
    strModuleName = objComponents.Item(ActiveCodePaneCodeName(objComponents)).Name
    Set objCodeModule = objComponents.Item(strModuleName).CodeModule
    Dim lngLines As Long
    lngLines = objCodeModule.CountOfLines
    If lngLines <= 0 Then
        MsgBox "現在のモジュールにコードがありません。", vbExclamation
        Exit Sub
    End If
    Dim strCode As String
    strCode = objCodeModule.lines(1, lngLines)
    Dim strBaseUrl As String: strBaseUrl = fncGetApiBase()
    Dim objRequest As Object: Set objRequest = CreateObject("WinHttp.WinHttpRequest.5.1")
    objRequest.SetTimeouts 2000, 2000, 15000, 15000
    objRequest.Open "POST", strBaseUrl & "/api/codes", False
    objRequest.SetRequestHeader "Content-Type", "application/json"
    Dim strBody As String
    strBody = "{""name"":""" & fncEscapeJson(strModuleName) & """,""content"":""" & fncEscapeJson(strCode) & """,""description"":""" & fncEscapeJson(strDescription) & """}"
    objRequest.Send strBody
    If objRequest.Status <> 200 Then
        MsgBox "アップロードエラー: " & objRequest.Status & " / " & objRequest.ResponseText, vbCritical
    Else
        MsgBox "アップロードが完了しました（" & strModuleName & "）", vbInformation
    End If
    Exit Sub
lbl_Err:
    MsgBox "UploadCurrentModule エラー: " & Err.Description, vbCritical
End Sub

'指定モジュール名のコードをアップロード（新規作成）
Public Sub UploadModuleByName(ByVal strModuleName As String, Optional ByVal strDescription As String = "")
    On Error GoTo lbl_Err
    Dim objVbe As Object, objProject As Object, objComponents As Object
    Dim objComponent As Object, objCodeModule As Object
    Set objVbe = Application.vbe
    Set objProject = objVbe.VBProjects(1)
    Set objComponents = objProject.VBComponents
    Dim blnFound As Boolean
    Dim i As Long
    For i = 1 To objComponents.Count
        If objComponents.Item(i).Name = strModuleName Then
            Set objComponent = objComponents.Item(i)
            blnFound = True
            Exit For
        End If
    Next
    If Not blnFound Then
        MsgBox "モジュールが見つかりません: " & strModuleName, vbExclamation
        Exit Sub
    End If
    Set objCodeModule = objComponent.CodeModule
    Dim strCode As String
    strCode = objCodeModule.lines(1, objCodeModule.CountOfLines)
    Dim strBaseUrl As String: strBaseUrl = fncGetApiBase()
    Dim objRequest As Object: Set objRequest = CreateObject("WinHttp.WinHttpRequest.5.1")
    objRequest.SetTimeouts 2000, 2000, 15000, 15000
    objRequest.Open "POST", strBaseUrl & "/api/codes", False
    objRequest.SetRequestHeader "Content-Type", "application/json"
    Dim strBody As String
    strBody = "{""name"":""" & fncEscapeJson(strModuleName) & """,""content"":""" & fncEscapeJson(strCode) & """,""description"":""" & fncEscapeJson(strDescription) & """}"
    objRequest.Send strBody
    If objRequest.Status <> 200 Then
        MsgBox "アップロードエラー: " & objRequest.Status & " / " & objRequest.ResponseText, vbCritical
    Else
        MsgBox "アップロードが完了しました（" & strModuleName & "）", vbInformation
    End If
    Exit Sub
lbl_Err:
    MsgBox "UploadModuleByName エラー: " & Err.Description, vbCritical
End Sub

'アクティブなコードペインのモジュール名を取得
Private Function ActiveCodePaneCodeName(ByVal objComponents As Object) As String
    On Error Resume Next
    Dim objPane As Object
    Set objPane = Application.vbe.ActiveCodePane
    Dim objCodeModule As Object
    Set objCodeModule = objPane.CodeModule
    ActiveCodePaneCodeName = objCodeModule.Parent.Name
End Function


