| |
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列目に記載したいと思います
ぜひお知恵をお借りしたくよろしくお願いいたします
一覧表にできないでしょうか
|
|
![[未読]](./data/word/image/read_icon.gif){kind=icon}
