Word (VBA)

Word VBAに関するフォーラムです。
  • 掲示板への投稿には会員登録(無料)が必要です。会員登録がまだの方はこちら
  • 掲示板ご利用上のお願い」に反するご記入はご遠慮ください。
  • Q&A掲示板の使い方はこちらをご覧ください
トピックに返信
質問

 
(Windows 7 Professional : Word 2013)
再帰呼び出しをループに変換
投稿日時: 20/02/14 12:55:35
投稿者: ストロベリー

下記の再帰呼び出し処理をループ処理に変換できますでしょうか?
スタック領域が不足しているというエラーが発生して、
調べてみると、再帰呼び出し処理でこのエラーがよく発生するとあって、
ループに直してみたいと思いますが、直し方がわからなくて、
ご教授いただければ幸いです。
よろしくお願いします。
 

Private Sub prc(shp As Word.Shape)

  Dim rng As Word.Range
  Dim i As Long
  
  Select Case shp.Type
  
    Case msoGroup
      
      For i = 1 To shp.GroupItems.Count
        Call prc(shp.GroupItems.Item(i))
      Next
    
    Case msoCanvas
      
      For i = 1 To shp.CanvasItems.Count
        Call prc(shp.CanvasItems.Item(i))
      Next
    
    Case Else
      ' 処理

  End Select
  
End Sub

回答
投稿日時: 20/02/14 22:50:34
投稿者: simple

再帰以外に書き換えるというのは現実的ではないでしょう。
というのは、
描画キャンバス内にグループ化された図形(さらにその内部にグループ化された図形を含む等々)を
含むと言ったバラエティを尽くすことは現実的ではないでしょう。
 
それよりも、スタックエラーになる原因を調べた方が適切ではないでしょうか。
特殊なshapeが原因となっているはずです。
例えば、下記のコードを実行するとどんな結果が得られますか?
(念のため、バックアップをとってから実行してください。ステップ実行したほうがよいかも)
 

Sub test()
    Dim doc As Document
    Dim shp As Shape
    Dim i As Long
    
    Set doc = ActiveDocument
    For Each shp In doc.Shapes
        Call prc(shp, 1)
    Next
End Sub
Private Sub prc(shp As Word.Shape, depth As Long)
    Dim rng As Word.Range
    Dim i As Long
    
    Debug.Print Space(2 * depth); shp.Name; "  ( type= "; shp.Type; ")"

    Select Case shp.Type
        Case msoGroup
            For i = 1 To shp.GroupItems.Count
                Call prc(shp.GroupItems.Item(i), depth + 1)
            Next
        Case msoCanvas
            For i = 1 To shp.CanvasItems.Count
                Call prc(shp.CanvasItems.Item(i), depth + 1)
            Next
        Case Else
    End Select
End Sub

回答
投稿日時: 20/02/14 23:02:48
投稿者: simple

考えてみれば、それは「オブジェクトの選択と表示」と同じ結果になるんですね。
無駄だったかな。
でも、エラーになる原因の解明に何か役立つかも知れないと思い、
あえてアップしたままとしておきます。

回答
投稿日時: 20/02/16 07:24:01
投稿者: simple

スタックエラーの発生を再現できるコードを提示してみてはどうですか?
つまり、'処理 のところでどんな処理をしているのですか?
ひょっとして、
Call prc(shp)
などと書いてしまっていて、無限ループが発生していることはありませんか?
関数呼び出しに伴うスタックが積み上がって、スタック領域を使い尽くしてエラー発生、
などというケースが考えられます。

投稿日時: 20/02/17 14:03:35
投稿者: ストロベリー

すみません、ちょっとプログラムが長いですが、
今やっていることを載せてみました。
Wordの変更履歴を取得して出力するというのが目的です。
 
最初に書いたコードのPrivate Sub prc(shp As Word.Shape)が
Private Sub GetRev_Shape(shp As Word.Shape, revOutData() As REVINFO, revOutDataCnt As Long)に
当たる部分です。
 
今なぜかスタック領域が不足のエラーが出なくなってしまって、どこでエラーが起きているかが調べれないです。
 
GetRev_Rangeでループがありますが、無限ループに入ることはないのではないかと思っています。エラーが発生しないので、実際に本当に無限ループになっていないかは確認ができていませんが。。。
 

Private Sub GetRevPrc(storyRng As Word.Range, revOutData() As REVINFO, revOutDataCnt As Long)

  Dim shp As Word.Shape
  
  
  Call GetRev_Range(storyRng, revOutData, revOutDataCnt)
  
  If storyRng.ShapeRange.Count > 0 Then
    
    For Each shp In storyRng.ShapeRange
      
      Call GetRev_Shape(shp, revOutData, revOutDataCnt)

    Next
  
  End If
  
  Set shp = Nothing
  
End Sub

Private Sub GetRev_Range(rng As Word.Range, revOutData() As REVINFO, revOutDataCnt As Long)

  Dim rev As Word.Revision
  Dim revType As String
  Dim cnt As Long
  Dim beforeCnt As Long
  
  
  If rng.Revisions.Count = 0 Then: Exit Sub

  cnt = 0
  beforeCnt = rng.Revisions.Count
  Do While (rng.Revisions.Count > 0)
  
    For Each rev In rng.Revisions
    
      cnt = cnt + 1
      Application.StatusBar = "Get revision " & cnt & " in range"
      DoEvents
      
      ' 変更履歴のタイプを取得
      revType = GetRevType(rev.Type)
      
      ReDim Preserve revOutData(revOutDataCnt)
      
      ' 変更履歴のタイプをセット
      revOutData(revOutDataCnt).revType = revType
      
      ' 変更履歴のタイプ別処理
      Select Case revType
  
        Case "Insert", "CellInsertion", "ConflictInsert", "Replace"
          
          Call SetRevInfo_Insert(rev, revOutData(revOutDataCnt))
          
        Case "Delete"
          
          Call SetRevInfo_Delete(rev, revOutData(revOutDataCnt))
          
        Case Else
          
          Call SetRevInfo_Others(rev, revOutData(revOutDataCnt))
          
      End Select
      
      revOutDataCnt = revOutDataCnt + 1
      
      rev.Accept
        
    Next
  
    ' 上のfor文で変更履歴を全て承諾した後、なぜか変更履歴が残る時がある。
    ' もう一回for文を実行して、それでも変更履歴が残るなら処理を終了
    If beforeCnt = rng.Revisions.Count Then
      Exit Do
    Else
      beforeCnt = rng.Revisions.Count
    End If
    
  Loop
  
  Set rev = Nothing
  
End Sub

Private Sub GetRev_Shape(shp As Word.Shape, revOutData() As REVINFO, revOutDataCnt As Long)

  Dim rng As Word.Range
  Dim i As Long
  
  Select Case shp.Type
  
    Case msoGroup
      
      For i = 1 To shp.GroupItems.Count
        Call prc(shp.GroupItems.Item(i))
      Next
    
    Case msoCanvas
      
      For i = 1 To shp.CanvasItems.Count
        Call prc(shp.CanvasItems.Item(i))
      Next
    
    Case Else

      If shp.TextFrame.HasText = True Then
      
        Set rng = shp.TextFrame.TextRange
        
        Call GetRev_Range(rng, revOutData, revOutDataCnt)

      End If

  End Select
  
  Set rng = Nothing
  
End Sub

回答
投稿日時: 20/02/17 21:41:42
投稿者: simple

GetRev_Shapeの中にある prcプロシージャって何ですか?
修正のうえ、書き込み用の構造体などはなくして、動かしてみましたが、
正常動作し、特段エラー的なものは見受けられませでした。
 
>エラーが発生しないので、実際に本当に無限ループになっていないかは確認ができていませんが。。。
質問者のところで、エラーが起きていないなら、こちらで見つからないのは自然なことですね。
 
今度、手元でエラーが発生したときに、その内容を精査してください。
 
こちらも余り時間を掛けるわけにもいきませんので、私はこれまでとします。
引き続き、他の回答者の回答をお待ちください。

トピックに返信