Word (VBA)

Word VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 7 Home Premium : Word 2007)
Fieldの挿入
投稿日時: 18/01/05 16:41:33
投稿者: bornkiller

 みなさんいつもお世話になります。Fieldの文字列を引数にしてVBAでFieldの挿入をするマクロを検索するとSelectionを使ったものしか出てきません。それでRangeを使ったものをつくってみました。ところが本文領域やFooterなどでは動作するのですが、TableのCellのRangeを引数にするとこのコマンドは使えませんというErrorになります。この場合でもRangeで動かせるのか、それともSelectionでないと動かないのでしょうか。
 
Sub InsFld(myRange1 As Range, txt1 As String)
  'Fieldの挿入
  Dim cnt1 As Integer, cnt2 As Integer, cnt3 As Integer, cnt4 As Integer, cnt5 As Integer, cnt6 As Integer
  Dim FLG1 As Integer, sng1 As Single, txt2 As String, txt3 As String, Var1 As Variant, Var3() As Variant
  Dim doc1 As Document, doc2 As Document, myRange2 As Range, myPara1 As Paragraph, myFSO As Object
  Dim myTBL1 As Table, myShape As Shape, myFLD1 As Field, myFLD() As Field, myPTY As Office.DocumentProperty
  On Error GoTo myErr
  '最初に括弧の数と位置が正しいかどうかを調べる
  cnt2 = 0
  cnt3 = 0
  For cnt1 = 1 To Len(txt1)
    Select Case cnt1
      Case 1
        If Mid(txt1, cnt1, 1) <> "{" Then
          txt2 = "1字目が{ではありません。"
          GoTo myErr
        End If
      Case Len(txt1)
        If Mid(txt1, cnt1, 1) <> "}" Then
          txt2 = "最後の文字が}ではありません。"
          GoTo myErr
        End If
    End Select
    If Mid(txt1, cnt1, 1) = "{" Then
      cnt2 = cnt2 + 1
    ElseIf Mid(txt1, cnt1, 1) = "}" Then
      cnt3 = cnt3 + 1
    End If
    If cnt3 > cnt2 Then
      txt2 = "括弧の位置が不正です。"
      GoTo myErr
    End If
  Next cnt1
  If cnt2 <> cnt3 Then
    txt2 = "括弧の数が不正です。"
    GoTo myErr
  End If
  cnt2 = 0 'FieldのIndex
  For cnt1 = 1 To Len(txt1)
    If Mid(txt1, cnt1, 1) = "{" Then
      If cnt1 = 1 Then
        ReDim Var3(0)
        cnt2 = cnt2 + 1
        '{or},自分のIndex,親のIndex,開始位置,終了位置,継続文字
        Var3(0) = "{," & cnt2 & ",," & cnt1 & "," & Len(txt1) & ","
      Else
        ReDim Preserve Var3(UBound(Var3) + 1)
        cnt2 = cnt2 + 1
        cnt4 = 0
        cnt5 = 0
        For cnt3 = cnt1 To Len(txt1)
          If Mid(txt1, cnt3, 1) = "{" Then
            cnt4 = cnt4 + 1
          ElseIf Mid(txt1, cnt3, 1) = "}" Then
            cnt5 = cnt5 + 1
          End If
          If cnt4 = cnt5 Then Exit For
        Next cnt3
        Var1 = Split(Var3(UBound(Var3) - 1), ",")
        If Var1(0) = "{" Then
          Var3(UBound(Var3)) = "{," & cnt2 & "," & Var1(1) & "," & cnt1 & "," & cnt3 & ","
          '括弧の中間に文字がある場合はそれを入れる
          If CInt(Split(Var3(UBound(Var3)), ",")(3)) - CInt(Var1(3)) > 1 Then
            Var3(UBound(Var3) - 1) = Var3(UBound(Var3) - 1) & Mid(txt1, CInt(Var1(3)) + 1, _
                                CInt(Split(Var3(UBound(Var3)), ",")(3)) - CInt(Var1(3)) - 1)
          End If
        ElseIf Var1(0) = "}" Then
          Var3(UBound(Var3)) = "{," & cnt2 & "," & Var1(2) & "," & cnt1 & "," & cnt3 & ","
          '括弧の中間に文字がある場合はそれを入れる
          If CInt(Split(Var3(UBound(Var3)), ",")(3)) - CInt(Var1(3)) > 1 Then
            Var3(UBound(Var3) - 1) = Var3(UBound(Var3) - 1) & Mid(txt1, CInt(Var1(3)) + 1, _
                                CInt(Split(Var3(UBound(Var3)), ",")(3)) - CInt(Var1(3)) - 1)
          End If
        End If
      End If
    ElseIf Mid(txt1, cnt1, 1) = "}" Then
      ReDim Preserve Var3(UBound(Var3) + 1)
      For cnt3 = UBound(Var3) - 1 To 0 Step -1
        Var1 = Split(Var3(cnt3), ",")
        If Var1(0) = "{" Then
          If cnt1 = CInt(Var1(4)) Then Exit For
        End If
      Next cnt3
      Var3(UBound(Var3)) = "}," & Var1(1) & "," & Var1(2) & "," & cnt1 & ",,"
      Var1 = Split(Var3(UBound(Var3) - 1), ",")
      '括弧の中間に文字がある場合はそれを入れる
      If CInt(Split(Var3(UBound(Var3)), ",")(3)) - CInt(Var1(3)) > 1 Then
        Var3(UBound(Var3) - 1) = Var3(UBound(Var3) - 1) & Mid(txt1, CInt(Var1(3)) + 1, _
                            CInt(Split(Var3(UBound(Var3)), ",")(3)) - CInt(Var1(3)) - 1)
      End If
    End If
  Next cnt1
  Set doc1 = myRange1.Parent
  For cnt1 = 0 To UBound(Var3)
    Var1 = Split(Var3(cnt1), ",")
    If Var1(0) = "{" Then
      If CInt(Var1(1)) = 1 Then
        ReDim myFLD(0)
        Set myFLD(UBound(myFLD)) = myRange1.Fields.Add(Range:=myRange1, Type:=wdFieldEmpty, Text:="" _
                                        , PreserveFormatting:=False) 'ここでエラーが出る
        myFLD(UBound(myFLD)).Code.Text = Var1(5)
      Else
        ReDim Preserve myFLD(UBound(myFLD) + 1)
        Set myRange2 = myFLD(CInt(Var1(2)) - 1).Code
        myRange2.Collapse Direction:=wdCollapseEnd
        Set myFLD(UBound(myFLD)) = doc1.Fields.Add(Range:=myRange2, Type:=wdFieldEmpty, Text:="" _
                                        , PreserveFormatting:=False)
        myFLD(UBound(myFLD)).Code.Text = Var1(5)
      End If
    ElseIf Var1(0) = "}" Then
      If Var1(5) = "" Then
      Else
        Set myRange2 = myFLD(CInt(Var1(2)) - 1).Code
        myRange2.Collapse Direction:=wdCollapseEnd
        myRange2.InsertAfter Var1(5)
      End If
    End If
  Next cnt1
  For cnt1 = 0 To UBound(myFLD)
    myFLD(cnt1).Update
    If cnt1 > 0 Then myFLD(cnt1).ShowCodes = True
  Next cnt1
  Exit Sub
myErr:
  If Err.Number = 0 Then
    MsgBox txt2
    Stop
  Else
    MsgBox Err.Description
    Stop
    Resume Next
  End If
 
End Sub

回答
投稿日時: 18/01/05 18:32:19
投稿者: sk

引用:
Fieldの文字列を引数にしてVBAでFieldの挿入をするマクロ

引用:
ところが本文領域やFooterなどでは動作するのですが、
TableのCellのRangeを引数にすると
このコマンドは使えませんというErrorになります。

引用:
Sub InsFld(myRange1 As Range, txt1 As String)

(プロシージャ InsFld の呼び出し例)
----------------------------------------------------------
 
Dim wrdRange As Word.Range
     
Set wrdRange = ThisDocument.Tables(1).Cell(1, 1).Range
wrdRange.MoveEnd wdCharacter, -1
 
Call InsFld(wrdRange, "{フィールドコード}")
     
Set wrdRange = Nothing
 
----------------------------------------------------------

投稿日時: 18/01/09 11:11:34
投稿者: bornkiller

 skさん、RESありがとうございます。できました。
 
 wrdRange.MoveEnd wdCharacter, -1
 これを入れないと動かないのでしょうけど、ヘルプ読むだけでこんなこと分かるわけがない。