すべてのグラフィックを数える（Microsoft Word）

Sub CountGraphics()

Const sBkMk = "ReturnHere"



Dim lngSections As Long     Dim lngSectionCounter As Long     Dim lngMainDocInlineShapes As Long     Dim lngMainDocShapes As Long     Dim lngHdrInlineShapes As Long     Dim lngHdrShapeRange As Long     Dim lngFtrInlineShapes As Long     Dim lngFtrShapeRange As Long     Dim lngTotalInlineShapes As Long     Dim lngTotalShapes As Long     Dim sMsgText As String

Application.ScreenUpdating = False

'Get the number of sections in the document.

lngSections = ActiveDocument.Sections.Count

'Get the number of inline objects and     'shape objects in the main document     lngMainDocInlineShapes = ActiveDocument.InlineShapes.Count     lngMainDocShapes = ActiveDocument.Shapes.Count

'Insert a bookmark to return to this place in the document.

ActiveDocument.Bookmarks.Add sBkMk, Selection.Range

'Go to the first page of the document.

Selection.HomeKey wdStory, wdMove

'Cycle through all of the sections in the document     'looking in headers and footers for graphics     For lngSectionCounter = 1 To lngSections         'Go to the header of the current page         ActiveDocument.ActiveWindow.View.SeekView = wdSeekCurrentPageHeader         Selection.WholeStory         'Get the number of inline objects and shape objects         lngHdrInlineShapes = lngHdrInlineShapes _           + Selection.Range.InlineShapes.Count         lngHdrShapeRange = lngHdrShapeRange _           + Selection.Range.ShapeRange.Count

'Go to the footer of the current page         ActiveDocument.ActiveWindow.View.SeekView = wdSeekCurrentPageFooter         Selection.WholeStory         'Get the number of inline objects and shape objects         lngFtrInlineShapes = lngFtrInlineShapes _           + Selection.Range.InlineShapes.Count         lngFtrShapeRange = lngFtrShapeRange _           + Selection.Range.ShapeRange.Count

Selection.GoTo wdGoToSection, wdGoToNext     Next

'Go to the main body of the document.

ActiveDocument.ActiveWindow.View.SeekView = wdSeekMainDocument

'Enable automatic screen updates     Application.ScreenUpdating = True     Application.ScreenRefresh

'Go to the bookmark that was inserted earlier.

If ActiveDocument.Bookmarks.Exists(sBkMk) Then         Selection.GoTo wdGoToBookmark, , , sBkMk         ActiveDocument.Bookmarks(sBkMk).Delete     Else         MsgBox "The bookmark '" & sBkMk & "' does not exist."

End If

'Calculate the total number of inlineshape objects     'and (shape and shaperange) objects     lngTotalInlineShapes = lngMainDocInlineShapes _       + lngHdrInlineShapes + lngFtrInlineShapes     lngTotalShapes = lngMainDocShapes _       + lngHdrShapeRange + lngFtrShapeRange

'Include the values from the variables into the     'text of the message     sMsgText = vbTab & vbTab & "Inline Shapes" _       & vbTab & "Other Shapes" & vbCr _       & "Main Document:" & vbTab & lngMainDocInlineShapes _       & vbTab & vbTab & lngMainDocShapes & vbCr _       & "Headers:" & vbTab & vbTab & lngHdrInlineShapes _       & vbTab & vbTab & lngHdrShapeRange & vbCr _       & "Footers:" & vbTab & vbTab & lngFtrInlineShapes _       & vbTab & vbTab & lngFtrShapeRange & vbCr _       & "Total:" & vbTab & vbTab & lngTotalInlineShapes _       & vbTab & vbTab & lngTotalShapes & vbCr & vbCr _       & "Note: The values for the headers and the footers " _       & "could include duplicates."



'Display the results of the procedure.

MsgBox sMsgText End Sub