Automatically merge pptx files with PowerPoint for MacOS

'  references: '  https://www.rondebruin.nl/mac/mac015.htm '  https://stackoverflow.com/questions/ 5316459/programmatically-combine-slides-from-multiple-presentations-into-a-single-presen '  https:// MSDN.MICROSOFT.COM/EN-US/LIBRARY/OFFICE/HH710200 (v=office.14). aspx ' Sub mergepptx ()      on error resume next    mypath = macscript ("return  ( Path to documents folder)  as string ")      ' Or use mypath  =  "Macintosh hd:users:ron:desktop:testfolder:"      " In the  following statement, change true to false in the line  "multiple      '  selections allowed true '  if you do not want  to be able to select more     '  than one file .  additionally, if you want to filter for multiple files, change     '  {' "Com.microsoft.Excel.xls" "} to     '  {" "Com.microsoft.excel.xls" "," " Public.comma-separated-values-text ""}     '  if you want to filter  on xls and csv files, for example.    myscript =  _     "Set applescript ' s text item delimiters to " "," "   " & vbNewLine & _                 "set thefiles to  (choose file of type ")  & _              " {" " Org.openxmlformats.presentationml.presentation "} "  & _                 "with prompt " "Please select a file or files" "  default location alias  "" " & _                MyPath &  "" " multiple selections  allowed true)  as string " & vbNewLine & _                 "Set applescript ' S text item  delimiters to  "" " "  & vbNewLine & _                 "Return thefiles"      myfiles = macscript (MyScript)     On Error GoTo 0     If MyFiles <>  ""  Then         presentations.add        dim filename as string         mysplit = split (myfiles,  ",")          For n = lbound (Mysplit)  to ubound (mysplit)              filename = replace (Mysplit (N),  "SYS:",  "/")              filename = replace (fileName,  ":",   "/")             importfromppt filename,  1, 2        Next N    End  Ifend subsub importfromppt (filename as string, slidefrom as long,  Slideto as long)     Dim SrcPPT As Presentation, SrcSld  as slide, idx  as long, sldcnt as long    set srcppt =  Presentations.Open (Filename, , , msofalse)     SldCnt =  srcppt.slides.count    if slidefrom > sldcnt then exit  Sub    if slideto > sldcnt then slideto = sldcnt     For Idx = SlideFrom To SlideTo Step 1         set srcsld = srcppt.slides (IDX)          SrcSld.Copy        With  activepresentation.slides.paste            . design = srcsld.design            . Colorscheme = srcsld.colorscheme             '  if slide is not following its  master  (Design, color scheme)               '  we must collect all bits & pieces from the slide  itself             '  >>>> >>>>>>>>>>>>>>>>             If SrcSld.FollowMasterBackground = False Then                 . followmasterbackground = false                 . background.fill.visible = srcsld.background.fill.visible                  . background.fill.forecolor = srcsld.background.fill.forecolor                 . background.fill.backcolor = srcsld.background.fill.backcolor                  '  inspect the filltype object                 Select  case srcsld.background.fill.type                     Case Is = msoFillTextured                          Select Case SrcSld.Background.Fill.TextureType                         case is = msotexturepreset                              . background.fill.presettextured  (SrcSld.Background.Fill.PresetTexture)                           case is = msotextureuserdefined                          '  TextureName  gives a filename w/o path                          '  not  implemented, see picture handling                        end  Select                     Case Is = msoFillSolid                         . background.fill.transparency = 0#                         . background.fill.solid                     Case Is = msoFillPicture                           '  picture cannot be copied directly, need to export and re-import slide image                         If  srcsld.shapes.count > 0 then srcsld.shapes.range.visible = false                          bMasterShapes = SrcSld.DisplayMasterShapes                          SrcSld.DisplayMasterShapes = False                         SrcSld.Export  srcppt.path & srcsld.slideid &  ". png",  "PNG"                           . background.fill.userpicture srcppt.path & srcsld.slideid &  ". png"                           Kill  (srcppt.path & srcsld.slideid &  ". png")                           SrcSld.DisplayMasterShapes = bMasterShapes                          if srcsld.shapes.count > 0 then srcsld.shapes.range.visible =  True                     case is = msofillpatterned                         . background.fill.patterned  (SrcSld.Background.Fill.pattern)                      Case Is =  msofillgradient                          '  inspect gradient type                          Select Case SrcSld.Background.Fill.GradientColorType                          Case Is = msoGradientPresetColors                             . background.fill.presetgradient _                                  SrcSld.Background.Fill.GradientStyle, _                                  SrcSld.Background.Fill.GradientVariant, _                                  SrcSld.Background.Fill.PresetGradientType                          case is = msogradientonecolor                              . background.fill.onecolorgradient _                                  SrcSld.Background.Fill.GradientStyle, _                                  SrcSld.Background.Fill.GradientVariant, _                                  SrcSld.Background.Fill.GradientDegree                          End Select                     Case Is = msoFillBackground                           ' &NBSP;ONLY&NBSP;SHAPES&NBSP;-&NBSP;WE&NBSP;SHOULDN ' t come here                 End Select             End If              '  >>>>>>>>>>>>>>>>>>> >        end with    next idxend  sub

This article is from the "GONE with the Wind" blog, please be sure to keep this source http://h2appy.blog.51cto.com/609721/1941076

Automatically merge pptx files with PowerPoint for MacOS