teratail
回答率
85.35%
teratail header banner
teratail header banner
質問するログイン新規登録
トップVBAに関する質問VBA でパワーポイントの画像形式を調べる方法

編集履歴

回答編集履歴

2

サンプルコードを修正

2021/10/27 22:30

投稿

cx20
cx20

スコア4648

test CHANGED
@@ -60,33 +60,37 @@
60
60
 
61
61
  Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
62
62
 
63
- Private Declare PtrSafe Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
63
+ Private Declare PtrSafe Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
64
64
 
65
65
 
66
66
 
67
- Private Function GetData(ByVal format&, abData() As Byte) As Boolean
67
+ Private Function GetClipboardRawData(ByVal format As Long, bytes() As Byte) As Boolean
68
68
 
69
+ Dim hWnd As Long
70
+
71
+ Dim nSize As Long
72
+
69
- Dim hWnd&, Size&, Ptr&
73
+ Dim hClipMemory As Long
70
74
 
71
75
  If OpenClipboard(0&) Then
72
76
 
73
77
  hWnd = GetClipboardData(format)
74
78
 
75
- If hWnd Then Size = GlobalSize(hWnd)
79
+ If hWnd Then nSize = GlobalSize(hWnd)
76
80
 
77
- If Size Then Ptr = GlobalLock(hWnd)
81
+ If nSize Then hClipMemory = GlobalLock(hWnd)
78
82
 
79
-
80
83
 
81
- If Ptr Then
82
84
 
83
- ReDim abData(0 To Size - 1) As Byte
85
+ If hClipMemory Then
84
86
 
87
+ ReDim bytes(0 To nSize - 1) As Byte
88
+
85
- CopyMem abData(0), ByVal Ptr, Size
89
+ MoveMemory bytes(0), ByVal hClipMemory, nSize
86
90
 
87
91
  Call GlobalUnlock(hWnd)
88
92
 
89
- GetData = True
93
+ GetClipboardRawData = True
90
94
 
91
95
  End If
92
96
 
@@ -102,27 +106,19 @@
102
106
 
103
107
 
104
108
 
105
- Sub ShapeToZip(ByVal n, ByVal strOutputPath)
109
+ Sub ClipboardToZip(ByVal format As Long, ByVal strZipFileName As String)
106
110
 
107
- Dim format As Long
111
+ Dim bytes() As Byte
108
112
 
109
- format = 50173 ' Art::GVML ClipFormat
113
+ Dim result As Boolean
110
114
 
111
- Dim abData() As Byte
115
+ result = GetClipboardRawData(format, bytes)
112
116
 
113
- Dim result
114
117
 
115
- result = GetData(format, abData)
116
118
 
117
-
119
+ Open strZipFileName For Binary As #1
118
120
 
119
- Dim strFileName As String
120
-
121
- strFileName = strOutputPath & "\clip" & n & ".zip"
122
-
123
- Open strFileName For Binary As #1
124
-
125
- Put #1, , abData
121
+ Put #1, , bytes
126
122
 
127
123
  Close #1
128
124
 
@@ -138,11 +134,19 @@
138
134
 
139
135
 
140
136
 
137
+ Dim format As Long
138
+
139
+ format = 50173 ' Art::GVML ClipFormat
140
+
141
+
142
+
141
143
  Dim strOutputPath As String
142
144
 
143
145
  strOutputPath = "C:\TEMP" ' 任意の出力先に変更下さい。
144
146
 
145
-
147
+ Dim strZipFileName As String
148
+
149
+
146
150
 
147
151
  Dim n As Long
148
152
 
@@ -156,9 +160,17 @@
156
160
 
157
161
  n = n + 1
158
162
 
163
+ ' 画像をクリップボードにコピー
164
+
159
165
  sh.Copy
160
166
 
167
+ ' 出力先のファイル名を設定
168
+
169
+ strZipFileName = strOutputPath & "\clip" & n & ".zip"
170
+
171
+ ' クリップボードの内容をファイル出力
172
+
161
- Call ShapeToZip(n, strOutputPath)
173
+ Call ClipboardToZip(format, strZipFileName)
162
174
 
163
175
  End If
164
176
 
@@ -169,3 +181,11 @@
169
181
  End Sub
170
182
 
171
183
  ```
184
+
185
+
186
+
187
+ ＜参考情報２＞
188
+
189
+ ■ クリップボードのデータを取り出す方法
190
+
191
+ [https://www.moug.net/tech/acvba/0020003.html](https://www.moug.net/tech/acvba/0020003.html)

1

クリップボードデータを zip ファイルに出力するサンプルを追加

2021/10/27 22:30

投稿

cx20
cx20

スコア4648

test CHANGED
@@ -25,3 +25,147 @@
25
25
  ■ InsideClipboard - Nirsoft
26
26
 
27
27
  [https://www.nirsoft.net/utils/inside_clipboard.html](https://www.nirsoft.net/utils/inside_clipboard.html)
28
+
29
+
30
+
31
+ ＜追記（2021.10.28＞
32
+
33
+ `Art::GVML ClipFormat` 形式のクリップボードデータを zip ファイルで出力するサンプルを書いてみました。
34
+
35
+ C:\TEMP 配下に clip1.zip のようなファイル名で保存するようにしてあります。必要に応じて変更下さい。
36
+
37
+ なお、このプログラムは自己責任でご利用下さい。
38
+
39
+ Win32 APIを使用しており、十分なテストも行っていない為、予期しないクラッシュ等が発生する可能性があります。
40
+
41
+
42
+
43
+ ```VBA
44
+
45
+ Option Explicit
46
+
47
+
48
+
49
+ Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
50
+
51
+ Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
52
+
53
+ Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
54
+
55
+ Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
56
+
57
+ Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
58
+
59
+ Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
60
+
61
+ Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
62
+
63
+ Private Declare PtrSafe Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
64
+
65
+
66
+
67
+ Private Function GetData(ByVal format&, abData() As Byte) As Boolean
68
+
69
+ Dim hWnd&, Size&, Ptr&
70
+
71
+ If OpenClipboard(0&) Then
72
+
73
+ hWnd = GetClipboardData(format)
74
+
75
+ If hWnd Then Size = GlobalSize(hWnd)
76
+
77
+ If Size Then Ptr = GlobalLock(hWnd)
78
+
79
+
80
+
81
+ If Ptr Then
82
+
83
+ ReDim abData(0 To Size - 1) As Byte
84
+
85
+ CopyMem abData(0), ByVal Ptr, Size
86
+
87
+ Call GlobalUnlock(hWnd)
88
+
89
+ GetData = True
90
+
91
+ End If
92
+
93
+ EmptyClipboard
94
+
95
+ CloseClipboard
96
+
97
+ DoEvents
98
+
99
+ End If
100
+
101
+ End Function
102
+
103
+
104
+
105
+ Sub ShapeToZip(ByVal n, ByVal strOutputPath)
106
+
107
+ Dim format As Long
108
+
109
+ format = 50173 ' Art::GVML ClipFormat
110
+
111
+ Dim abData() As Byte
112
+
113
+ Dim result
114
+
115
+ result = GetData(format, abData)
116
+
117
+
118
+
119
+ Dim strFileName As String
120
+
121
+ strFileName = strOutputPath & "\clip" & n & ".zip"
122
+
123
+ Open strFileName For Binary As #1
124
+
125
+ Put #1, , abData
126
+
127
+ Close #1
128
+
129
+ End Sub
130
+
131
+
132
+
133
+ Sub Main()
134
+
135
+ Dim sld As Slide
136
+
137
+ Dim sh As Shape
138
+
139
+
140
+
141
+ Dim strOutputPath As String
142
+
143
+ strOutputPath = "C:\TEMP" ' 任意の出力先に変更下さい。
144
+
145
+
146
+
147
+ Dim n As Long
148
+
149
+ n = 0
150
+
151
+ For Each sld In ActivePresentation.Slides
152
+
153
+ For Each sh In sld.Shapes
154
+
155
+ If sh.Type = 13 Then
156
+
157
+ n = n + 1
158
+
159
+ sh.Copy
160
+
161
+ Call ShapeToZip(n, strOutputPath)
162
+
163
+ End If
164
+
165
+ Next
166
+
167
+ Next
168
+
169
+ End Sub
170
+
171
+ ```