パワーポイントで画像を一括挿入する方法について

質問

パワーポイントに画像を一括で挿入したいと考えています。
ドラッグ＆ドロップでは一つずつしか挿入できません。

良い方法を知っていれば教えてください。

よろしくお願いします。

回答No.3

n_na_tto · ベストアンサー

★マークのところはご自分で変えてください。

Sub 画像複数挿入2000_2()
Dim cntL As Integer, cntT As Integer
Dim flgAspect As Boolean
Dim SL As Single, SR As Single, ST As Single, SB As Single
Dim ML As Single, MT As Single
Dim xlApp As Object
Dim dlgOpen As Variant
Dim myPre As Presentation
Dim Sld As Slide
Dim n As Long
Dim i As Integer, j As Integer
Dim sldWidth As Single, sldHeight As Single
Dim realWidth As Single, realHeight As Single
Dim myWidth As Single, myHeight As Single
Dim myLeft As Single, myTop As Single
Dim myPic As Shape
cntL = 2 '★横方向枚数2～6などで変更
cntT = 1 '★縦方向枚数2～6などで変更
flgAspect = True '★縦横比を固定するときはTrue,しないときはFalseで変更
SL = 0 'スライド左余白
SR = 0 'スライド右余白
ST = 0 'スライド上余白
SB = 0 'スライド下余白
ML = 0 '左右間隔
MT = 0 '上下間隔

Set myPre = ActivePresentation
With myPre
sldHeight = .SlideMaster.Height
sldWidth = .SlideMaster.Width
End With
realWidth = sldWidth - SL - SR
realHeight = sldHeight - ST - SB
myWidth = realWidth / cntL - ML
myHeight = realHeight / cntT - MT
Set xlApp = CreateObject("Excel.Application")
dlgOpen = xlApp.GetOpenFileName("gif,*.gif,jpg,*.jpg,jpg,*.jpeg,bmp,*.bmp,png,*.png,wmf,*.wmf,tiff,*.tiff", , , , True)
With myPre.Slides '新規スライド
j = 1
i = 1
Set Sld = .Add(.Count + 1, ppLayoutBlank)
End With
If IsArray(dlgOpen) Then
For n = LBound(dlgOpen) To UBound(dlgOpen)
If i > cntT Then 'さらに新規スライド
i = 1
With myPre.Slides
Set Sld = .Add(.Count + 1, ppLayoutBlank)
End With
End If
myLeft = SL + (j - 1) * realWidth / cntL
myTop = ST + (i - 1) * realHeight / cntT
Set myPic = Sld.Shapes.AddPicture _
(FileName:=dlgOpen(n), _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=myLeft, Top:=myTop)
With myPic
.LockAspectRatio = flgAspect
.Height = myHeight
If flgAspect = False Then
.Width = myWidth
Else
If .Width > myWidth Then
.Width = myWidth
End If
End If
End With
If j < cntL Then '横にずらす
j = j + 1
Else '改行
j = 1
i = i + 1
End If
Next n
End If
xlApp.Quit
Set dlgOpen = Nothing
Set xlApp = Nothing
Set Sld = Nothing
Set myPre = Nothing
End Sub

回答No.4

n_na_tto

複数の画像ファイルをマウスで選択するとき、
人によって癖があるので、思い通りの順番に
ならないことがあります。
そこまでコードで対応するの面倒なので、
いろいろ試してください。

以下の3通りの方法があります。
意外と難しいと思います。
・Ctrl+Aの「全選択」が可能ならそうする
・「逆順に」ひとつひとつCtrl+クリックする
・一番上のファイルの「右の白いあいているところから」
斜め左下方向にマウスをドラッグして連続範囲選択する

回答No.2

n_na_tto

水面下で、Excelに手伝ってもらっています。

《準備》
0.「ツール」 →「マクロ」 →「セキュリティー」
　→セキュリティレベル「中」にチェックを入れる
　→パワーポイントをいったん終了して、またすぐ起動
　※マクロを動かすためです。

1.Alt+F11キーでVisual Basic Editor 画面に
→挿入
→標準モジュール
→右の真っ白な大きいところに以下のコードをコピー&ペースト

Sub 画像複数挿入2000()
Dim xlApp As Object
Dim dlgOpen As Variant
Dim myPre As Presentation
Dim Sld As Slide
Dim n As Long
Dim myHeight As Single
Dim myWidth As Single
Dim myPic As Shape
Set myPre = ActivePresentation
With myPre
myHeight = .SlideMaster.Height
myWidth = .SlideMaster.Width
End With
Set xlApp = CreateObject("Excel.Application")
dlgOpen = xlApp.GetOpenFileName("gif,*.gif,jpg,*.jpg,jpg,*.jpeg,bmp,*.bmp,png,*.png,wmf,*.wmf,tiff,*.tiff", , , , True)
If IsArray(dlgOpen) Then
For n = LBound(dlgOpen) To UBound(dlgOpen)
With myPre.Slides
Set Sld = .Add(.Count + 1, ppLayoutBlank)
End With
Set myPic = Sld.Shapes.AddPicture _
(FileName:=dlgOpen(n), _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=11, Top:=0)
With myPic
.LockAspectRatio = msoTrue
.Height = myHeight
If .Width > myWidth Then .Width = myWidth
.Left = (myWidth - .Width) / 2
End With
Next n
End If
xlApp.Quit
Set dlgOpen = Nothing
Set xlApp = Nothing
Set Sld = Nothing
Set myPre = Nothing
End Sub

2. 標準画面に戻ります。
念のためテスト用として別名で保存してください。

3.ツール→マクロ→マクロ
→1.のマクロ画像複数挿入2000を選択
→実行
→ダイアログが出ますので、ファイルの種類を
*.jpgや*.bmpなどに変更して探し、複数選択
→開く　としてください。

4. マクロを使わないときは、0.で変更したセキュリティレベルを元に戻す

お礼

ありがとうございます。

もう一つおねがいしていいですか？
今のものですと、1ページに１枚貼り付けられるのですが、
１ページに複数貼り付けられるようにできませんか？
（できればサイズも合わせて）

もしよければコードのアップよろしくお願いします。

回答No.1

n_na_tto

1枚のスライドに画像を1枚ずつの場合で説明します。

●PowerPoint2002以降の場合
フォトアルバムを使いましょう。
【手順】
挿入
→図
→新しいフォトアルバム
→写真の挿入元：
....ファイル/ディスク
→挿入したい写真たちをShiftキー+マウスで複数選択
[またはCtrl+Aで全選択]
→挿入
→写真のレイアウト：
....スライドに合わせる が最大、ほかでもいい
→作成

●PowerPoint2000の場合
VBAを使うことになるかと思います。
必要でしたらコードをアップします。

お礼

回答ありがとうございます。

現在PowerPoint2000使用しているため、
コードをアップしていただけないでしょうか。

よろしくお願いします。