回答編集履歴
3
アクティブな文書内の全ての描画レイヤーの図を差し替えるよう、コードを修正しました。
test
CHANGED
|
@@ -1,26 +1,52 @@
|
|
|
1
|
+
> 1つの文書内にあるすべての画像を全く同一の画像に差し替えようとしています。
|
|
2
|
+
|
|
3
|
+
以上のコメントを受けて、次のように変更しました（2023/06/27 10:53）。
|
|
4
|
+
|
|
1
5
|
```vba
|
|
2
|
-
Sub ResetPicture()
|
|
6
|
+
Sub ResetAllPicturesInActiveDocument()
|
|
3
7
|
|
|
4
8
|
Dim strPicturePath As String
|
|
5
|
-
|
|
9
|
+
Dim lngResetCount As Long
|
|
10
|
+
|
|
6
11
|
strPicturePath = "C:\FolderName\FileName.png"
|
|
7
|
-
|
|
8
|
-
If Dir(strPicturePath) = "" Then
|
|
9
|
-
MsgBox "そんなファイルはない。", vbExclamation
|
|
10
|
-
Exit Sub
|
|
11
|
-
End If
|
|
12
12
|
|
|
13
13
|
Dim wrdShape As Word.Shape
|
|
14
14
|
|
|
15
|
+
For Each wrdShape In ActiveDocument.Shapes
|
|
15
|
-
Select Case Se
|
|
16
|
+
Select Case wrdShape.Type
|
|
16
|
-
Case
|
|
17
|
+
Case msoPicture, msoLinkedPicture
|
|
17
|
-
|
|
18
|
+
If ResetPicture(wrdShape, strPicturePath) Is Nothing Then
|
|
19
|
+
Exit Sub
|
|
20
|
+
End If
|
|
18
|
-
|
|
21
|
+
lngResetCount = lngResetCount + 1
|
|
19
|
-
Case Else
|
|
22
|
+
Case Else
|
|
20
|
-
MsgBox "選択されているオブジェクトは描画レイヤーの図形ではない。", vbExclamation
|
|
21
|
-
|
|
23
|
+
'何もしない
|
|
22
|
-
End Select
|
|
24
|
+
End Select
|
|
23
|
-
|
|
25
|
+
Next
|
|
26
|
+
|
|
27
|
+
If lngResetCount > 0 Then
|
|
28
|
+
MsgBox "この文書の描画レイヤーの図を " & lngResetCount & " 個差し替えました。", _
|
|
29
|
+
vbInformation, _
|
|
30
|
+
"実行完了 (ResetAllPicturesInActiveDocument)"
|
|
31
|
+
Else
|
|
32
|
+
MsgBox "この文書の描画レイヤーに挿入されている図はありません。", _
|
|
33
|
+
vbInformation, _
|
|
34
|
+
"実行完了 (ResetAllPicturesInActiveDocument)"
|
|
35
|
+
End If
|
|
36
|
+
|
|
37
|
+
End Sub
|
|
38
|
+
|
|
39
|
+
Function ResetPicture(TargetShape As Word.Shape, NewPicturePath As String) As Word.Shape
|
|
40
|
+
On Error GoTo Err_ResetPicture
|
|
41
|
+
|
|
42
|
+
If Dir(NewPicturePath) = "" Then
|
|
43
|
+
MsgBox "指定されたパス""" & NewPicturePath & """に該当するファイルが見つかりません。", _
|
|
44
|
+
vbExclamation, _
|
|
45
|
+
"ファイル参照エラー (ResetPicture)"
|
|
46
|
+
Exit Function
|
|
47
|
+
End If
|
|
48
|
+
|
|
49
|
+
Dim strShapeName As String
|
|
24
50
|
Dim varLeftRelative As Variant
|
|
25
51
|
Dim varRelativeHorizontalPosition As Variant
|
|
26
52
|
Dim varLeft As Variant
|
|
@@ -28,17 +54,19 @@
|
|
|
28
54
|
Dim varRelativeVerticalPosition As Variant
|
|
29
55
|
Dim varTop As Variant
|
|
30
56
|
|
|
31
|
-
With
|
|
57
|
+
With TargetShape
|
|
32
|
-
|
|
33
58
|
Select Case .Type
|
|
34
59
|
Case msoPicture, msoLinkedPicture
|
|
35
60
|
'何もしない
|
|
36
61
|
Case Else
|
|
62
|
+
MsgBox "図形""" & .Name & """は図ではありません。", _
|
|
63
|
+
vbExclamation, _
|
|
37
|
-
|
|
64
|
+
"オブジェクト参照エラー (ResetPicture)"
|
|
38
|
-
Set wrdShape = Nothing
|
|
39
|
-
Exit
|
|
65
|
+
Exit Function
|
|
40
66
|
End Select
|
|
67
|
+
|
|
41
|
-
|
|
68
|
+
.Select
|
|
69
|
+
strShapeName = .Name
|
|
42
70
|
varLeftRelative = .LeftRelative
|
|
43
71
|
varRelativeHorizontalPosition = .RelativeHorizontalPosition
|
|
44
72
|
If .LeftRelative = wdShapePositionRelativeNone Then
|
|
@@ -55,10 +83,10 @@
|
|
|
55
83
|
|
|
56
84
|
Dim wrdNewShape As Word.Shape
|
|
57
85
|
|
|
58
|
-
Set wrdNewShape = ActiveDocument.Shapes.AddPicture(FileName:=
|
|
86
|
+
Set wrdNewShape = ActiveDocument.Shapes.AddPicture(FileName:=NewPicturePath, _
|
|
59
87
|
LinkToFile:=False)
|
|
60
88
|
|
|
61
|
-
With
|
|
89
|
+
With TargetShape
|
|
62
90
|
.LeftRelative = wdShapePositionRelativeNone
|
|
63
91
|
.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
|
|
64
92
|
.TopRelative = wdShapePositionRelativeNone
|
|
@@ -67,15 +95,15 @@
|
|
|
67
95
|
|
|
68
96
|
With wrdNewShape
|
|
69
97
|
|
|
70
|
-
.WrapFormat.Type =
|
|
98
|
+
.WrapFormat.Type = TargetShape.WrapFormat.Type
|
|
71
99
|
|
|
72
100
|
.LeftRelative = wdShapePositionRelativeNone
|
|
73
101
|
.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
|
|
74
|
-
.Left =
|
|
102
|
+
.Left = TargetShape.Left
|
|
75
103
|
|
|
76
104
|
.TopRelative = wdShapePositionRelativeNone
|
|
77
105
|
.RelativeVerticalPosition = wdRelativeVerticalPositionPage
|
|
78
|
-
.Top =
|
|
106
|
+
.Top = TargetShape.Top
|
|
79
107
|
|
|
80
108
|
.LeftRelative = varLeftRelative
|
|
81
109
|
.RelativeHorizontalPosition = varRelativeHorizontalPosition
|
|
@@ -89,24 +117,36 @@
|
|
|
89
117
|
.Top = varTop
|
|
90
118
|
End If
|
|
91
119
|
|
|
92
|
-
Do While .ZOrderPosition >
|
|
120
|
+
Do While .ZOrderPosition > TargetShape.ZOrderPosition
|
|
93
121
|
.ZOrder msoSendBackward
|
|
94
122
|
Loop
|
|
95
123
|
|
|
96
124
|
End With
|
|
97
125
|
|
|
126
|
+
Exit_ResetPicture:
|
|
98
|
-
|
|
127
|
+
On Error Resume Next
|
|
99
|
-
strShapeName = wrdShape.Name
|
|
100
128
|
|
|
129
|
+
If Not wrdNewShape Is Nothing Then
|
|
101
|
-
|
|
130
|
+
TargetShape.Delete
|
|
102
|
-
Set wrdShape = Nothing
|
|
103
|
-
|
|
104
|
-
wrdNewShape.Name = strShapeName
|
|
131
|
+
wrdNewShape.Name = strShapeName
|
|
105
|
-
Set wrdNewShape
|
|
132
|
+
Set ResetPicture = wrdNewShape
|
|
133
|
+
End If
|
|
106
134
|
|
|
107
135
|
Application.ScreenUpdating = True
|
|
108
136
|
|
|
137
|
+
Exit Function
|
|
138
|
+
|
|
139
|
+
Err_ResetPicture:
|
|
140
|
+
|
|
141
|
+
MsgBox Err.Number & ": " & Err.Description, _
|
|
142
|
+
vbCritical, _
|
|
143
|
+
"実行時エラー (ResetPicture)"
|
|
144
|
+
|
|
145
|
+
If Not wrdNewShape Is Nothing Then
|
|
146
|
+
wrdNewShape.Delete
|
|
147
|
+
Set wrdNewShape = Nothing
|
|
109
|
-
End
|
|
148
|
+
End If
|
|
149
|
+
|
|
150
|
+
Resume Exit_ResetPicture
|
|
151
|
+
End Function
|
|
110
152
|
```
|
|
111
|
-
|
|
112
|
-
以上のようなプロシージャを実行したい、ということでしょうか。
|
2
図形の種類による分岐処理を追加しました。
test
CHANGED
|
@@ -29,6 +29,16 @@
|
|
|
29
29
|
Dim varTop As Variant
|
|
30
30
|
|
|
31
31
|
With wrdShape
|
|
32
|
+
|
|
33
|
+
Select Case .Type
|
|
34
|
+
Case msoPicture, msoLinkedPicture
|
|
35
|
+
'何もしない
|
|
36
|
+
Case Else
|
|
37
|
+
MsgBox "選択中の図形は図ではない。", vbExclamation
|
|
38
|
+
Set wrdShape = Nothing
|
|
39
|
+
Exit Sub
|
|
40
|
+
End Select
|
|
41
|
+
|
|
32
42
|
varLeftRelative = .LeftRelative
|
|
33
43
|
varRelativeHorizontalPosition = .RelativeHorizontalPosition
|
|
34
44
|
If .LeftRelative = wdShapePositionRelativeNone Then
|
1
レイアウト設定のおける水平/垂直方向の基準や相対位置の指定を踏まえた形に修正しました。
test
CHANGED
|
@@ -11,26 +11,78 @@
|
|
|
11
11
|
End If
|
|
12
12
|
|
|
13
13
|
Dim wrdShape As Word.Shape
|
|
14
|
-
Dim wrdNewShape As Word.Shape
|
|
15
14
|
|
|
16
15
|
Select Case Selection.Type
|
|
17
16
|
Case wdSelectionShape
|
|
18
17
|
Set wrdShape = Selection.ShapeRange.Item(1)
|
|
18
|
+
Debug.Print wrdShape.Name
|
|
19
19
|
Case Else
|
|
20
20
|
MsgBox "選択されているオブジェクトは描画レイヤーの図形ではない。", vbExclamation
|
|
21
21
|
Exit Sub
|
|
22
22
|
End Select
|
|
23
23
|
|
|
24
|
+
Dim varLeftRelative As Variant
|
|
25
|
+
Dim varRelativeHorizontalPosition As Variant
|
|
26
|
+
Dim varLeft As Variant
|
|
27
|
+
Dim varTopRelative As Variant
|
|
28
|
+
Dim varRelativeVerticalPosition As Variant
|
|
29
|
+
Dim varTop As Variant
|
|
30
|
+
|
|
31
|
+
With wrdShape
|
|
32
|
+
varLeftRelative = .LeftRelative
|
|
33
|
+
varRelativeHorizontalPosition = .RelativeHorizontalPosition
|
|
34
|
+
If .LeftRelative = wdShapePositionRelativeNone Then
|
|
35
|
+
varLeft = .Left
|
|
36
|
+
End If
|
|
37
|
+
varTopRelative = .TopRelative
|
|
38
|
+
varRelativeVerticalPosition = .RelativeVerticalPosition
|
|
39
|
+
If .TopRelative = wdShapePositionRelativeNone Then
|
|
40
|
+
varTop = .Top
|
|
41
|
+
End If
|
|
42
|
+
End With
|
|
43
|
+
|
|
24
44
|
Application.ScreenUpdating = False
|
|
45
|
+
|
|
46
|
+
Dim wrdNewShape As Word.Shape
|
|
25
47
|
|
|
26
48
|
Set wrdNewShape = ActiveDocument.Shapes.AddPicture(FileName:=strPicturePath, _
|
|
27
49
|
LinkToFile:=False)
|
|
50
|
+
|
|
28
|
-
|
|
51
|
+
With wrdShape
|
|
52
|
+
.LeftRelative = wdShapePositionRelativeNone
|
|
53
|
+
.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
|
|
54
|
+
.TopRelative = wdShapePositionRelativeNone
|
|
55
|
+
.RelativeVerticalPosition = wdRelativeVerticalPositionPage
|
|
56
|
+
End With
|
|
57
|
+
|
|
29
58
|
With wrdNewShape
|
|
59
|
+
|
|
60
|
+
.WrapFormat.Type = wrdShape.WrapFormat.Type
|
|
61
|
+
|
|
62
|
+
.LeftRelative = wdShapePositionRelativeNone
|
|
63
|
+
.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
|
|
64
|
+
.Left = wrdShape.Left
|
|
65
|
+
|
|
30
|
-
.TopRelative = w
|
|
66
|
+
.TopRelative = wdShapePositionRelativeNone
|
|
67
|
+
.RelativeVerticalPosition = wdRelativeVerticalPositionPage
|
|
31
68
|
.Top = wrdShape.Top
|
|
69
|
+
|
|
32
|
-
.LeftRelative =
|
|
70
|
+
.LeftRelative = varLeftRelative
|
|
71
|
+
.RelativeHorizontalPosition = varRelativeHorizontalPosition
|
|
72
|
+
If .LeftRelative = wdShapePositionRelativeNone Then
|
|
33
|
-
.Left =
|
|
73
|
+
.Left = varLeft
|
|
74
|
+
End If
|
|
75
|
+
|
|
76
|
+
.TopRelative = varTopRelative
|
|
77
|
+
.RelativeVerticalPosition = varRelativeVerticalPosition
|
|
78
|
+
If .TopRelative = wdShapePositionRelativeNone Then
|
|
79
|
+
.Top = varTop
|
|
80
|
+
End If
|
|
81
|
+
|
|
82
|
+
Do While .ZOrderPosition > wrdShape.ZOrderPosition
|
|
83
|
+
.ZOrder msoSendBackward
|
|
84
|
+
Loop
|
|
85
|
+
|
|
34
86
|
End With
|
|
35
87
|
|
|
36
88
|
Dim strShapeName As String
|