本文共 4632 字，大约阅读时间需要 15 分钟。
| 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 | ' ' 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 If End Sub Sub 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 ' Only shapes - we shouldn't come here End Select End If ' >>>>>>>>>>>>>>>>>>>> End With Next Idx End Sub |