<Outlook>ExcelみたいにSUM関数で合計計算マクロ｜コピペで表計算・文章計算に対応

'===========================
' クリップボード API (64bit) ※前回のまま
'===========================
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
Private Declare PtrSafe Function lstrcpy Lib "kernel32" Alias "lstrcpyW" (ByVal lpStr1 As LongPtr, ByVal lpStr2 As LongPtr) As LongPtr

Private Const CF_UNICODETEXT As Long = 13
Private Const GMEM_MOVEABLE  As Long = &H2

Private Sub SetClipboardText(ByVal strText As String)
    Dim hGlobal As LongPtr, pGlobal As LongPtr
    hGlobal = GlobalAlloc(GMEM_MOVEABLE, (Len(strText) + 1) * 2)
    If hGlobal = 0 Then Exit Sub
    pGlobal = GlobalLock(hGlobal)
    If pGlobal <> 0 Then
        lstrcpy pGlobal, StrPtr(strText)
        GlobalUnlock hGlobal
        If OpenClipboard(0) Then
            EmptyClipboard
            SetClipboardData CF_UNICODETEXT, hGlobal
            CloseClipboard
        End If
    End If
End Sub

'===========================
' メイン：計算オールマイティー v2（表/非表 自動判定・安全版）
'===========================
Sub 計算オールマイティー()
    Dim insp As Object, doc As Object, sel As Object
    Dim total As Currency, outText As String
    Const wdWithInTable As Long = 12

    Set insp = Application.ActiveInspector
    If insp Is Nothing Then MsgBox "開いているメールがありません。": Exit Sub
    Set doc = insp.WordEditor
    Set sel = doc.Application.Selection

    '--- 1) 表の中なら：アクティブセルの列の「上」を合計 ---
    If sel.Information(wdWithInTable) Then
        Dim tbl As Object, col As Long, row As Long, r As Long, s As String

        ' ※表内が確定してから Cells に触る（ここが安全ポイント）
        Set tbl = sel.Cells(1).Range.Tables(1)
        row = sel.Cells(1).RowIndex
        col = sel.Cells(1).ColumnIndex

        total = 0
        For r = 1 To row - 1
            s = tbl.Cell(r, col).Range.text
            If Len(s) >= 2 Then s = Left$(s, Len(s) - 2)     ' EndOfCellMarker除去
            total = total + ParseAmountOrZero(s)
        Next

    '--- 2) 表の外なら：複数行選択→その範囲 / 1行→空行で区切られたブロック ---
    Else
        Dim lines As Collection: Set lines = New Collection
        If sel.Range.Characters.Count > 1 And InStr(sel.text, vbCr) > 0 Then
            CollectLinesFromRange sel.Range, lines
        Else
            CollectBlockAroundCursor doc, sel, lines
        End If

        Dim i As Long
        total = 0
        For i = 1 To lines.Count
            total = total + ParseAmountOrZero(CStr(lines(i)))
        Next
    End If

    outText = "\" & Format$(total, "#,##0") & "-"   ' 生の数値が良ければ CStr(total)

    SetClipboardText outText
    MsgBox "合計をクリップボードにコピーしました：" & vbCrLf & outText
End Sub

'===========================
' テキスト処理ユーティリティ（前回のまま）
'===========================
Private Sub CollectLinesFromRange(ByVal rng As Object, ByRef lines As Collection)
    Dim t As String, arr() As String, i As Long
    t = rng.text
    t = Replace$(t, vbCrLf, vbLf)
    t = Replace$(t, vbCr, vbLf)
    arr = Split(t, vbLf)
    For i = LBound(arr) To UBound(arr)
        If Trim$(arr(i)) <> "" Then lines.Add arr(i)
    Next
End Sub

Private Sub CollectBlockAroundCursor(ByVal doc As Object, ByVal sel As Object, ByRef lines As Collection)
    Dim para As Object, t As String
    Set para = sel.Paragraphs(1)

    ' 上へ遡ってブロック先頭へ（直前が空行で停止）
    Do While Not para.Previous Is Nothing
        t = para.Previous.Range.text
        If Trim$(Left$(t, Len(t) - 1)) = "" Then Exit Do
        Set para = para.Previous
    Loop

    ' 先頭から下へ、空行に当たるまで収集
    Do While Not para Is Nothing
        t = para.Range.text
        If t = vbCr Then Exit Do
        lines.Add Left$(t, Len(t) - 1) ' 行末の vbCr を除去
        If para.Next Is Nothing Then Exit Do
        Set para = para.Next
        If Trim$(Left$(para.Range.text, Len(para.Range.text) - 1)) = "" Then Exit Do
    Loop
End Sub

' 金額表記の正規化 → 数値化
Private Function ParseAmountOrZero(ByVal s As String) As Currency
    Dim neg As Boolean
    s = Trim$(s)
    If s = "" Then ParseAmountOrZero = 0: Exit Function

    ' () マイナス
    If Left$(s, 1) = "(" And Right$(s, 1) = ")" Then
        neg = True
        s = Mid$(s, 2, Len(s) - 2)
    End If

    ' 空白類（半角/全角/NBSP/ナローNBSP）
    s = Replace$(s, " ", "")
    s = Replace$(s, "　", "")
    s = Replace$(s, ChrW(&HA0), "")
    s = Replace$(s, ChrW(&H202F), "")

    ' 通貨・単位・桁区切り
    s = Replace$(s, ChrW(&HA5), "")                 ' \
    s = Replace$(s, "\", "")                        ' \（環境によって\表示）
    s = Replace$(s, ",", "")
    s = Replace$(s, "円", "", , , vbTextCompare)
    s = Replace$(s, "JPY", "", , , vbTextCompare)

    ' 末尾の装飾ハイフン（\123- / \123- など）
    If Right$(s, 1) = "-" And InStr(s, "-") = Len(s) Then s = Left$(s, Len(s) - 1)

    ' 先頭符号
    If Left$(s, 1) = "-" Then neg = True: s = Mid$(s, 2)
    If Left$(s, 1) = "+" Then s = Mid$(s, 2)

    If s = "" Or Not IsNumeric(s) Then
        ParseAmountOrZero = 0
    Else
        ParseAmountOrZero = IIf(neg, -CCur(s), CCur(s))
    End If
End Function