notesscript

Option Public
Option Declare

Sub ExtractAttachments()
Dim session As New NotesSession
Dim db As NotesDatabase
Dim doc As NotesDocument
Dim rtItem As NotesRichTextItem
Dim embeddedObjects As Variant
Dim obj As NotesEmbeddedObject
Dim filePath As String
Dim targetDir As String
Dim matchedFiles As Integer

' ダウンロード先フォルダ
targetDir = "C:\\temp\\download\\"
If Dir(targetDir, 16) = "" Then MkDir targetDir

' 現在のデータベースを取得
Set db = session.CurrentDatabase
' 現在開いている文書を取得
Set doc = session.DocumentContext

' リッチテキストフィールド R を取得
If Not doc.HasItem("R") Then
    Msgbox "フィールド R が見つかりません。", 16, "エラー"
    Exit Sub
End If

Set rtItem = doc.GetFirstItem("R")
If rtItem.Type <> RICHTEXT Then
    Msgbox "フィールド R はリッチテキストではありません。", 16, "エラー"
    Exit Sub
End If

' 添付ファイルをチェック
embeddedObjects = rtItem.EmbeddedObjects
matchedFiles = 0

Forall obj In embeddedObjects
    If obj.Type = EMBED_ATTACHMENT Then
        ' 拡張子のチェック
        If Right$(Lcase$(obj.Name), 4) = ".zip" Or Right$(Lcase$(obj.Name), 5) = ".xlsm" Then
            matchedFiles = matchedFiles + 1
            filePath = targetDir & obj.Name
            Call obj.ExtractFile(filePath)
            
            ' ZIP の場合は解凍
            If Right$(Lcase$(obj.Name), 4) = ".zip" Then
                Call UnzipFile(filePath, targetDir)
            End If
        End If
    End If
End Forall

' 条件エラー処理
If matchedFiles = 0 Then
    Msgbox "適切な添付ファイルがありません（.zip または .xlsm）。", 16, "エラー"
    Exit Sub
ElseIf matchedFiles > 1 Then
    Msgbox ".zip または .xlsm のファイルが複数あります。", 16, "エラー"
    Exit Sub
End If

Msgbox "処理が完了しました。", 64, "完了"

End Sub

' ZIPファイルを解凍する
Sub UnzipFile(zipPath As String, extractTo As String)
Dim shellCmd As String
shellCmd = "powershell -command ""Expand-Archive -Path '" & zipPath & "' -DestinationPath '" & extractTo & "' -Force"""
Call Shell(shellCmd, 0)
End Sub