再質問ポイントアップ

PowerPointのVBA:PowerPointスライドへの画像読み込みを次の条件でできませんでしょうか?


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

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

回答の条件
  • 1人10回まで
  • 13歳以上
  • 登録:2014/02/06 19:47:10
  • 終了:2014/02/09 20:09:05

ベストアンサー

id:Mook No.1

Mook回答回数1312ベストアンサー獲得回数3912014/02/08 20:34:56

ポイント1500pt

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
id:Mook

バグ修正しました。

2014/02/09 00:40:26

その他の回答(0件)

id:Mook No.1

Mook回答回数1312ベストアンサー獲得回数3912014/02/08 20:34:56ここでベストアンサー

ポイント1500pt

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
id:Mook

バグ修正しました。

2014/02/09 00:40:26
id:sunfkin22

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

  • id:sunfkin22
    重ならないようになりました。
    最後に、もう一つ、下に10の隙間を取るにはどうしたらよいでしょうか?
  • id:Mook
    とりあえずですが、
       ActivePresentation.PageSetup.SlideHeight

      (ActivePresentation.PageSetup.SlideHeight - 10 * TO_MILL )
    にすればできるかと思います。

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません