Word VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


4 / 296 ツリー ←次へ | 前へ→

【852】ExcelからWord図形を検索する かず 18/3/17(土) 23:55 質問[未読]
【853】Re:ExcelからWord図形を検索する マナ 18/3/21(水) 13:20 発言[未読]
【854】Re:ExcelからWord図形を検索する マナ 18/3/21(水) 13:31 発言[未読]

【852】ExcelからWord図形を検索する
質問  かず  - 18/3/17(土) 23:55 -

引用なし
パスワード
   Word文書の納品前チェックをしており、本来は削除されているはずの
吹き出しが残っていないか、チェックするマクロを組みたいと思って
います。

Q1
自宅Windows10 Excel2007 Word2007 の環境で
Excel VBAからWordを起動してWordの図形=Shape の
中から 吹きだしを 取り出して リストすることまでできたのですが
これを会社(Windows7 Excel2010) で実行すると 図形の
判定=> AutoShapeTypeでの判定ができず そこを書き換えが必要なようです
★印部分です

Word のバージョンが2010 になると AutoShapeType プロパティ
が使えるオブジェクトを変えないといけないのでしょうか?
Word2013や2016 でも変えないといけないとすると少々面倒ですが
そういうものでしょうか?
----リスト-----------------
Sub test()
  Dim doc As Document
  Dim x As Word.Shape
  Dim y As Shape
  
  Dim wb As Workbook
  Dim wk As Worksheet
  Dim cFiles As Variant
  Dim C As Comment
  Dim cPath As String
  Dim cFile As String
  Dim i As Long
  Dim j As Long
  Dim iR As Long

  Dim w As Variant
  Dim sh As Worksheet
  Dim cc As Range
  Dim r As Range
  Dim z As Variant
  Dim flag As Boolean
  
  Dim isp As InlineShape
  Dim msg As String

  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Application.ShowWindowsInTaskbar = False
  Application.EnableEvents = False

  Set wk = ActiveSheet
  Cells.Delete
  iR = 1
  wk.Range("A" & iR & ":" & "D" & iR).Value = Array("種類", "パス", "文字列", "リンク")
  
  cPath = ThisWorkbook.Path & "\"
  cFiles = Split(CreateObject("WScript.Shell").Exec("CMD /C DIR /A:-D/B/S """ & cPath & "*.doc*""").StdOut().ReadAll(), vbNewLine)
  For i = 0 To UBound(cFiles) - 1
      cFile = Mid(cFiles(i), InStrRev(cFiles(i), "\") + 1)
      If Left(cFile, 2) <> "~$" Then

         With CreateObject("word.application")
           '.Visible = True
           .documents.Open Filename:=cFiles(i), ReadOnly:=True
          
           Set doc = ActiveDocument
           ' アクティブ文書の全Shapeにループを回す
           For Each x In ActiveDocument.Shapes
             ' ★ ↑会社ではActiveDocument.Range.ShapeRange 
             ' Shapeが吹き出しだったら
             If ((x.AutoShapeType >= 53 And x.AutoShapeType <= 59) Or _
               (x.AutoShapeType >= 105 And x.AutoShapeType <= 124) Or _
               x.AutoShapeType = 137) Then
               iR = iR + 1
               wk.Cells(iR, "A").Value = "吹出し"
               wk.Cells(iR, "B").Value = cFiles(i)
               wk.Cells(iR, "C").Value = x.TextFrame.TextRange.Text
               'wk.Cells(iR, "D").Value = x.Top
               wk.Hyperlinks.Add Anchor:=wk.Cells(iR, "D"), Address:=cFiles(i), SubAddress:="'" & .Name '&  "'!" & x.TopLeft.Address(False, False)
                  
               wk.Cells(iR, "D").Font.Underline = xlUnderlineStyleSingle
               wk.Cells(iR, "D").Font.ColorIndex = 5
             End If
           Next x

        
         End With

      End If
  Next i
  Columns("A:D").AutoFit
  Rows("1:" & iR).AutoFit
  
  'ThisWorkbook.Activate
  Range("B2").Select
  ActiveWindow.FreezePanes = False
  ActiveWindow.FreezePanes = True
  
  Application.EnableEvents = True
  Application.ShowWindowsInTaskbar = True
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub

Q2 吹き出しがある箇所を、何ページの何行目科の位置と、
  その図形自体へのハイパーリンクとして、上記リストでは
  4列目と5列目に記載したいと思います
  ぜひお知恵をお借りしたくよろしくお願いいたします
 一覧表にできないでしょうか

【853】Re:ExcelからWord図形を検索する
発言  マナ  - 18/3/21(水) 13:20 -

引用なし
パスワード
   ▼かず さん:

>Q1
>Word のバージョンが2010 になると AutoShapeType プロパティ
>が使えるオブジェクトを変えないといけないのでしょうか?

グループ化された図形で試して、使えないと判断しただけでは?
わたしの2010では判定できています。

>Q2 吹き出しがある箇所を、何ページの何行目科の位置と、
>  その図形自体へのハイパーリンクとして、上記リストでは
>  4列目と5列目に記載したいと思います

わたしにはできません。
解決したら、報告お願いします。

【854】Re:ExcelからWord図形を検索する
発言  マナ  - 18/3/21(水) 13:31 -

引用なし
パスワード
   ▼かず さん:

>わたしの2010では判定できています。

こんな感じで確認しました。

Sub 動作確認()
  Dim doc As Document
  Dim sp As Shape
  
  Set doc = ActiveDocument

  For Each sp In doc.Range.ShapeRange
    If sp.Type = msoGroup Then
      グループ内調査 sp
    Else
      吹き出し取得 sp
     End If
  Next
  
End Sub

Private Sub 吹き出し取得(sp As Shape)

  Select Case sp.AutoShapeType
    Case 53 To 59, 105 To 124, 137
      MsgBox sp.TextFrame.TextRange.Text
      MsgBox sp.Anchor.Information(wdActiveEndPageNumber)
  End Select

End Sub

ところで、吹き出し以外でも、図形にコメント挿入できますが問題ないのでしょうか。

4 / 296 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
199360
(SS)C-BOARD v3.8 is Free