Word VBA質問箱 IV

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

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


3 / 829 ←次へ | 前へ→

【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列目に記載したいと思います
  ぜひお知恵をお借りしたくよろしくお願いいたします
 一覧表にできないでしょうか

21 hits

【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 発言[未読]

3 / 829 ←次へ | 前へ→
ページ:  ┃  記事番号:
197558
(SS)C-BOARD v3.8 is Free