function not recognised for object

[BenB]

When i run these two procedures seperately they work fine...

however if i run SetDatabaseFolder and then CopyWithSoureFormattingEnd i get
the error
run time error '438'
object doesn't support this property or method

on the line:
.Filters.Add "Presentations", "*.ppt,*.pps"

in CopyWithSourceFormattingEnd



Sub CopyWithSourceFormattingEnd(DatabaseFolder As String)
Dim oSource As Presentation
Dim oTarget As Presentation
Dim oSlide As Slide
Dim dlgOpen As FileDialog
Dim bMasterShapes As Boolean
Dim SlideCount As Integer
Set oTarget = ActivePresentation
Set dlgOpen = Application.FileDialog(msoFileDialogOpen)

With dlgOpen
.AllowMultiSelect = False
.Filters.Clear
.InitialFileName = DatabaseFolder
.Filters.Add "Presentations", "*.ppt,*.pps"
.Title = "Select Presentation to import"
If .Show = -1 Then
Set oSource = Presentations.Open(.SelectedItems(1), , , False)
End If
If oSource Is Nothing Then Exit Sub
' SlideCount = oSource.Slides.Slide
End With
For Each oSlide In oSource.Slides
SlideCount = SlideCount + 1
oSlide.Copy
With oTarget.Slides.Paste()
.Design = oSlide.Design
' Apply the color scheme only after you have applied
' the design, else it won't give the desired results.
.ColorScheme = oSlide.ColorScheme
' Additional processing for slides which don't follow
' the master background
If oSlide.FollowMasterBackground = False Then
.FollowMasterBackground = False
With .Background.Fill
.Visible = oSlide.Background.Fill.Visible
.ForeColor = oSlide.Background.Fill.ForeColor
.BackColor = oSlide.Background.Fill.BackColor
End With
Select Case oSlide.Background.Fill.Type
Case Is = msoFillTextured
Select Case oSlide.Background.Fill.TextureType
Case Is = msoTexturePreset
.Background.Fill.PresetTextured _
(oSlide.Background.Fill.PresetTexture)
Case Is = msoTextureUserDefined
' TextureName gives only the filename
' and not the path to the custom texture file used.
' We could do it the same way we handle picture fill.
End Select
Case Is = msoFillSolid
.Background.Fill.Transparency = 0#
.Background.Fill.Solid
Case Is = msoFillPicture
' No way to get the picture so export the slide image.
With oSlide
If .Shapes.Count > 0 Then .Shapes.Range.Visible = False
bMasterShapes = .DisplayMasterShapes
.DisplayMasterShapes = False
.Export oSource.Path & .SlideID & ".png", "PNG"
End With
.Background.Fill.UserPicture _
oSource.Path & oSlide.SlideID & ".png"
Kill (oSource.Path & oSlide.SlideID & ".png")
With oSlide
.DisplayMasterShapes = bMasterShapes
If .Shapes.Count > 0 Then .Shapes.Range.Visible = True
End With

Case Is = msoFillPatterned
.Background.Fill.Patterned _
(oSlide.Background.Fill.Pattern)
Case Is = msoFillGradient
Select Case oSlide.Background.Fill.GradientColorType
Case Is = msoGradientTwoColors
.Background.Fill.TwoColorGradient _
oSlide.Background.Fill.GradientStyle, _
oSlide.Background.Fill.GradientVariant
Case Is = msoGradientPresetColors
.Background.Fill.PresetGradient _
oSlide.Background.Fill.GradientStyle, _
oSlide.Background.Fill.GradientVariant, _
oSlide.Background.Fill.PresetGradientType
Case Is = msoGradientOneColor
.Background.Fill.OneColorGradient _
oSlide.Background.Fill.GradientStyle, _
oSlide.Background.Fill.GradientVariant, _
oSlide.Background.Fill.GradientDegree
End Select
Case Is = msoFillBackground
' Only applicable to shapes.
End Select
End If
End With
Next oSlide
If DoWeNeedNewSlide Then
newslide (Application.ActivePresentation.Slides.Count + 1)
End If
oSource.Close
Set oSource = Nothing
End Sub



Sub SetDatabaseFolder()
Dim DatabaseFolder As String
Dim FilePath As String
Set dlgOpen = Application.FileDialog(msoFileDialogFolderPicker)
With dlgOpen
.AllowMultiSelect = False
.Filters.Clear
.Title = "Select Folder to set as Database Folder"
If .Show = -1 Then
DatabaseFolder = .SelectedItems(1)

Application.CommandBars("order of service").Controls(16).Caption
= "Locates the folder where all the powerpoint files are stored, currently is
" & DatabaseFolder
Application.CommandBars("Order of
Service").Controls(16).DescriptionText = DatabaseFolder

' Set customdocument property named databasefolder to folder
that was selected
'If IsDatabaseFolderDefined Then
'
Application.ActivePresentation.CustomDocumentProperties("databasefolder").Delete
' Application.ActivePresentation.CustomDocumentProperties.Add
Name:="databasefolder", LinkToContent:=False, Type:=msoPropertyTypeString,
Value:=DatabaseFolder
'Else
' Application.ActivePresentation.CustomDocumentProperties.Add
Name:="databasefolder", LinkToContent:=False, Type:=msoPropertyTypeString,
Value:=DatabaseFolder
'End If
MsgBox ("DatabaseFolder set to " + DatabaseFolder)
End If
End With
Set dlgOpen = Nothing
End Sub

 

[Shyam Pillai]

Comment out the following two lines from the SetDatabaseFolder routine, they
do not apply to folder picker.

.AllowMultiSelect = False
.Filters.Clear

Then restart PowerPoint and try again.