彰化一整天的論壇

 找回密碼
 立即註冊
查看: 253|回復: 0

【轉貼】將目錄內的所有檔案放在powerpoint中的每一頁

[複製鏈接]
發表於 2017-9-12 09:05:16 | 顯示全部樓層 |閱讀模式
Powerpoint VBA - Inserting all jpg images in a folder, each image on new & separte slide
  1. Sub ImportABunch()

  2. Dim strTemp As String
  3. Dim strPath As String
  4. Dim strFileSpec As String
  5. Dim oSld As Slide
  6. Dim oPic As Shape

  7. ' Edit these to suit:
  8. strPath = "c:\JpgLoaderTest"
  9. strFileSpec = "*.jpg"

  10. strTemp = Dir(strPath & strFileSpec)

  11. Do While strTemp <> ""
  12.     Set oSld = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ppLayoutBlank)
  13.     Set oPic = oSld.Shapes.AddPicture(FileName:=strPath & strTemp, _
  14.     LinkToFile:=msoFalse, _
  15.     SaveWithDocument:=msoTrue, _
  16.     Left:=0, _
  17.     Top:=0, _
  18.     Width:=100, _
  19.     Height:=100)

  20.     ' Reset it to its "real" size
  21.     With oPic
  22.         .ScaleHeight 1, msoTrue
  23.         .ScaleWidth 1, msoTrue
  24.     End With

  25. ' Optionally, make it fill the slide - even if that means changing the proportions of the picture
  26. ' To do that, uncomment the following:
  27. '  With oPic
  28. '      .LockAspectRatio = msoFalse
  29. '      .height = ActivePresentation.PageSetup.Slideheight
  30. '      .width = ActivePresentation.PageSetup. Slidewidth
  31. '  End With

  32. ' Or (with thanks to David Marcovitz) make the picture as big as possible on the slide
  33. ' without changing the proportions
  34. ' Leave the above commented out, uncomment this instead:
  35. '   With oPic
  36. '     If 3 * .width > 4 * .height Then
  37. '         .width = ActivePresentation.PageSetup.Slidewidth
  38. '         .Top = 0.5 * (ActivePresentation.PageSetup.Slideheight - .height)
  39. '     Else
  40. '       .height = ActivePresentation.PageSetup.Slideheight
  41. '         .Left = 0.5 * (ActivePresentation.PageSetup.Slidewidth - .width)
  42. '     End If
  43. '   End With


  44.     ' Get the next file that meets the spec and go round again
  45.     strTemp = Dir
  46. Loop

  47. End Sub
複製代碼
1 Centimeter = 28.3464567 Points [Postscript]
1 Point = 0.0352777778 Centimeters
文章出處: https://www.experts-exchange.com ... -separte-slide.html
回復

使用道具 舉報

您需要登錄後才可以回帖 登錄 | 立即註冊

本版積分規則

Archiver|手機版|小黑屋|彰化一整天的論壇(Excel,Office)  |网站地图

GMT+8, 2018-9-24 23:58 , Processed in 0.144535 second(s), 19 queries .

Powered by Discuz! X3.2

© 2001-2013 Comsenz Inc.

快速回復 返回頂部 返回列表