人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

再質問ポイントアップ
PowerPointのVBA:PowerPointスライドへの画像読み込みを次の条件でできませんでしょうか?


・フォルダに画像ファイルが数枚〜数十枚単位で入っている
・入力ダイアログで画像の横幅を入力してリサイズした画像をスライドに読み込みたい
※1:ダイアログに入力する数値の単位は、cmで小数点一桁までにしたい
※2:横幅に合わせて高さは自動調整したい
・ダイアログでフォルダを選択するようにしたい
・アクティブなスライドに画像を読み込むようにしたい
・画像サイズが大きい順番に読み込むようにしたい
・左上から下へ画像を読み込み、画像が多い場合は2列、3列になるようにしたい
・1枚の画像は、Topから30、Leftから10にしたい
・画像と画像の間隔は3にしたい
・画像が1枚のスライドに収まらないときは、メッセージを表示して、
画像をクリアにするようにしたい

回答内容によっては、さらにポイント増も考えています。よろしくお願いします。

●質問者: にゃんころね
●カテゴリ:コンピュータ 学習・教育
○ 状態 :終了
└ 回答数 : 1/1件

▽最新の回答へ

1 ● Mook
●1500ポイント ベストアンサー

PowerPoint の VBA です(Office 2010、2013 で動作確認)。

Option Explicit

'// 対象のフォーマットを指定
'//----------------------------------
Const PIC_FORMAT = "JPG,GIF,BMP"

'//----------------------------------
Const PIC_ORDER_VERTICAL = 1
Const PIC_ORDER_HORIZONTAL = 2
Const PIC_ORDER = PIC_ORDER_VERTICAL

'//----------------------------------
Const 開始位置_横 = 10
Const 開始位置_縦 = 30
Const デフォルト画像幅 = 30
Const 画像間隔_横 = 3
Const 画像間隔_縦 = 3

'//----------------------------------
Const TO_MILL = 3

'//------------------------------------------------------------------------------
Sub 画像を読み込み()
'//------------------------------------------------------------------------------
 Dim picFolder
 With Application.FileDialog(msoFileDialogFolderPicker)
 If .Show = True Then
 picFolder = .SelectedItems(1)
 Else
 Exit Sub
 End If
 End With
 
 Dim topPos As Double
 topPos = 開始位置_縦 * TO_MILL
 
 Dim LeftPos As Double
 LeftPos = 開始位置_横 * TO_MILL
 
 Dim pw As Double
 pw = InputBox("画像の幅を入力してください", "画像幅", デフォルト画像幅)
 If IsNumeric(pw) = False Then Exit Sub
 Dim picWidth As Double
 picWidth = pw * TO_MILL
 
 Dim picMarginX As Double
 picMarginX = 画像間隔_横 * TO_MILL
 
 Dim picMarginY As Double
 picMarginY = 画像間隔_縦 * TO_MILL
 
 Dim currentSlide As Slide
 Set currentSlide = ActiveWindow.Selection.SlideRange(1)
 
 Dim picList As Object
 Set picList = CreateObject("System.Collections.SortedList")

 Dim objFso As Object
 Set objFso = CreateObject("Scripting.FileSystemObject")
 
 Dim file
 Dim ph As Double
 For Each file In objFso.GetFolder(picFolder).Files
 If InStr(PIC_FORMAT, UCase(objFso.GetExtensionName(file.Name))) > 0 Then
 ph = getPicHight(file.Path, picWidth)
 Do While picList.Contains(ph) = True
 ph = ph + 10 ^ -5
 Loop
 picList.Add ph, file.Path
 End If
 Next
 
 Dim px As Double
 px = LeftPos
 Dim py As Double
 py = topPos
 
 Dim dy As Double
 dy = picList.GetKey(picList.Count - 1)
 
 Dim picIndex As Long
 For picIndex = picList.Count - 1 To 0 Step -1
 If (px + picWidth) > ActivePresentation.PageSetup.SlideWidth Then Exit For
 If (py + picList.GetKey(picIndex)) > ActivePresentation.PageSetup.SlideHeight Then Exit For
 AddPicLink picList.GetByIndex(picIndex), currentSlide, px, py, picWidth, picList.GetKey(picIndex)
 
 If picIndex = 0 Then Exit For
 Select Case PIC_ORDER
 Case PIC_ORDER_VERTICAL
 py = py + picMarginY + picList.GetKey(picIndex)
 If (py + picList.GetKey(picIndex - 1)) > ActivePresentation.PageSetup.SlideHeight Then
 px = px + picMarginX + picWidth
 py = topPos
 End If
 Case PIC_ORDER_HORIZONTAL
 px = px + picMarginX + picWidth
 If (px + picMarginX + picWidth) > ActivePresentation.PageSetup.SlideWidth Then
 px = LeftPos
 py = py + dy + picMarginY
 dy = picList.GetKey(picIndex - 1)
 End If
 End Select
 Next

 If picIndex > 0 Then
 MsgBox "画像が現在のスライドにおさまりません"
 RemoveAllPics currentSlide
 End If
End Sub

'//------------------------------------------------------------------------------
Sub AddPicLink(filePath As String, currentSlide As Slide, x, y, cwidth, cheight)
'//------------------------------------------------------------------------------
 currentSlide.Shapes.AddPicture _
 FileName:=filePath, LinkToFile:=True, SaveWithDocument:=False, _
 Left:=x, Top:=y, width:=cwidth, Height:=cheight
End Sub

'//------------------------------------------------------------------------------
Sub RemoveAllPics(currentSlide)
'//------------------------------------------------------------------------------
 Dim noPic As Boolean
 Dim sh
 Do While noPic = False
 noPic = True
 For Each sh In currentSlide.Shapes
 If sh.Type = msoLinkedPicture Then
 sh.Delete
 noPic = False
 End If
 Next
 Loop
End Sub

'//------------------------------------------------------------------------------
Function getPicHight(filePath As String, width As Double) As Double
'//------------------------------------------------------------------------------
 Dim p As Object
 Set p = LoadPicture(filePath)
 getPicHight = width / p.width * p.Height
End Function

Mookさんのコメント
バグ修正しました。

質問者から

Mookさん
いつもありがとうございます。
ほぼ希望通りですが、高さが違う画像が混在した際に、重なってしまいます。
重ならないようにはなりますでしょうか?


関連質問

●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ