Word VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃ホーム

51 / 877

←次へ　｜　前へ→


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

207 hits

▼

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