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

編集履歴

回答編集履歴

2

サンプルコードを修正

2021/10/27 22:30

投稿

cx20
cx20

スコア4700

answer CHANGED
@@ -29,20 +29,22 @@
29
29
  Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
30
30
  Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
31
31
  Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
32
- Private Declare PtrSafe Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
32
+ Private Declare PtrSafe Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
33
33
 
34
- Private Function GetData(ByVal format&, abData() As Byte) As Boolean
34
+ Private Function GetClipboardRawData(ByVal format As Long, bytes() As Byte) As Boolean
35
+ Dim hWnd As Long
36
+ Dim nSize As Long
35
- Dim hWnd&, Size&, Ptr&
37
+ Dim hClipMemory As Long
36
38
  If OpenClipboard(0&) Then
37
39
  hWnd = GetClipboardData(format)
38
- If hWnd Then Size = GlobalSize(hWnd)
40
+ If hWnd Then nSize = GlobalSize(hWnd)
39
- If Size Then Ptr = GlobalLock(hWnd)
41
+ If nSize Then hClipMemory = GlobalLock(hWnd)
40
-
42
+
41
- If Ptr Then
43
+ If hClipMemory Then
42
- ReDim abData(0 To Size - 1) As Byte
44
+ ReDim bytes(0 To nSize - 1) As Byte
43
- CopyMem abData(0), ByVal Ptr, Size
45
+ MoveMemory bytes(0), ByVal hClipMemory, nSize
44
46
  Call GlobalUnlock(hWnd)
45
- GetData = True
47
+ GetClipboardRawData = True
46
48
  End If
47
49
  EmptyClipboard
48
50
  CloseClipboard
@@ -50,17 +52,13 @@
50
52
  End If
51
53
  End Function
52
54
 
53
- Sub ShapeToZip(ByVal n, ByVal strOutputPath)
55
+ Sub ClipboardToZip(ByVal format As Long, ByVal strZipFileName As String)
54
- Dim format As Long
55
- format = 50173 ' Art::GVML ClipFormat
56
- Dim abData() As Byte
56
+ Dim bytes() As Byte
57
- Dim result
57
+ Dim result As Boolean
58
- result = GetData(format, abData)
58
+ result = GetClipboardRawData(format, bytes)
59
-
60
- Dim strFileName As String
59
+
61
- strFileName = strOutputPath & "\clip" & n & ".zip"
62
- Open strFileName For Binary As #1
60
+ Open strZipFileName For Binary As #1
63
- Put #1, , abData
61
+ Put #1, , bytes
64
62
  Close #1
65
63
  End Sub
66
64
 
@@ -68,19 +66,31 @@
68
66
  Dim sld As Slide
69
67
  Dim sh As Shape
70
68
 
69
+ Dim format As Long
70
+ format = 50173 ' Art::GVML ClipFormat
71
+
71
72
  Dim strOutputPath As String
72
73
  strOutputPath = "C:\TEMP" ' 任意の出力先に変更下さい。
73
-
74
+ Dim strZipFileName As String
75
+
74
76
  Dim n As Long
75
77
  n = 0
76
78
  For Each sld In ActivePresentation.Slides
77
79
  For Each sh In sld.Shapes
78
80
  If sh.Type = 13 Then
79
81
  n = n + 1
82
+ ' 画像をクリップボードにコピー
80
83
  sh.Copy
84
+ ' 出力先のファイル名を設定
85
+ strZipFileName = strOutputPath & "\clip" & n & ".zip"
86
+ ' クリップボードの内容をファイル出力
81
- Call ShapeToZip(n, strOutputPath)
87
+ Call ClipboardToZip(format, strZipFileName)
82
88
  End If
83
89
  Next
84
90
  Next
85
91
  End Sub
86
- ```
92
+ ```
93
+
94
+ ＜参考情報２＞
95
+ ■ クリップボードのデータを取り出す方法
96
+ [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

スコア4700

answer CHANGED
@@ -11,4 +11,76 @@
11
11
 
12
12
  ＜参考情報＞
13
13
  ■ InsideClipboard - Nirsoft
14
- [https://www.nirsoft.net/utils/inside_clipboard.html](https://www.nirsoft.net/utils/inside_clipboard.html)
14
+ [https://www.nirsoft.net/utils/inside_clipboard.html](https://www.nirsoft.net/utils/inside_clipboard.html)
15
+
16
+ ＜追記（2021.10.28＞
17
+ `Art::GVML ClipFormat` 形式のクリップボードデータを zip ファイルで出力するサンプルを書いてみました。
18
+ C:\TEMP 配下に clip1.zip のようなファイル名で保存するようにしてあります。必要に応じて変更下さい。
19
+ なお、このプログラムは自己責任でご利用下さい。
20
+ Win32 APIを使用しており、十分なテストも行っていない為、予期しないクラッシュ等が発生する可能性があります。
21
+
22
+ ```VBA
23
+ Option Explicit
24
+
25
+ Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
26
+ Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
27
+ Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
28
+ Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
29
+ Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
30
+ Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
31
+ Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
32
+ Private Declare PtrSafe Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
33
+
34
+ Private Function GetData(ByVal format&, abData() As Byte) As Boolean
35
+ Dim hWnd&, Size&, Ptr&
36
+ If OpenClipboard(0&) Then
37
+ hWnd = GetClipboardData(format)
38
+ If hWnd Then Size = GlobalSize(hWnd)
39
+ If Size Then Ptr = GlobalLock(hWnd)
40
+
41
+ If Ptr Then
42
+ ReDim abData(0 To Size - 1) As Byte
43
+ CopyMem abData(0), ByVal Ptr, Size
44
+ Call GlobalUnlock(hWnd)
45
+ GetData = True
46
+ End If
47
+ EmptyClipboard
48
+ CloseClipboard
49
+ DoEvents
50
+ End If
51
+ End Function
52
+
53
+ Sub ShapeToZip(ByVal n, ByVal strOutputPath)
54
+ Dim format As Long
55
+ format = 50173 ' Art::GVML ClipFormat
56
+ Dim abData() As Byte
57
+ Dim result
58
+ result = GetData(format, abData)
59
+
60
+ Dim strFileName As String
61
+ strFileName = strOutputPath & "\clip" & n & ".zip"
62
+ Open strFileName For Binary As #1
63
+ Put #1, , abData
64
+ Close #1
65
+ End Sub
66
+
67
+ Sub Main()
68
+ Dim sld As Slide
69
+ Dim sh As Shape
70
+
71
+ Dim strOutputPath As String
72
+ strOutputPath = "C:\TEMP" ' 任意の出力先に変更下さい。
73
+
74
+ Dim n As Long
75
+ n = 0
76
+ For Each sld In ActivePresentation.Slides
77
+ For Each sh In sld.Shapes
78
+ If sh.Type = 13 Then
79
+ n = n + 1
80
+ sh.Copy
81
+ Call ShapeToZip(n, strOutputPath)
82
+ End If
83
+ Next
84
+ Next
85
+ End Sub
86
+ ```