G
Guest
run time error '462'
the remote server machine does not exist or is unavailable.
i have a macro within powerpoint which opens a word document formats it and
writes a whole document into it. if i run this powerpoint macro once, then
close the microsoft word completely, then run this macro a second time run
time error '462' occurs. if microsoft word application stays open (even
though the document created might be closed) the error does not occur.
the code is below...
Sub DumpTextAndFormatInWord(Folderspec, IncludeAlphabeticIndex,
IncludeNumericIndex, SlidestoPrint, Format)
Dim appWD As Word.Application
Dim Document As Word.Document
Dim fs, f, f1, fc, S
Dim oPres As Presentation
Dim oSlides As Slides
Dim oSld As Slide 'Slide Object
Dim oShp As Shape 'Shape Object
Dim PathSep As String
Dim x As Integer
Dim y As Integer
Dim Sections As Integer
Dim Heading As String
Dim SubHeading As String
Dim FilestoGrab() As Integer
Dim FilesInBetween() As Integer
Dim ArrayLength As Integer
Dim File As Integer
Dim Songlist As New Collection
Dim DoThisFile As Boolean
Dim oSlidestoPrint As String
Dim Criterion As String
Dim oSlidestoPrintFrom As Integer
Dim oSlidestoPrintTo As Integer
Dim SlideChecking As Integer 'Set to 0 for no checking, 1 for from to
checking, 2 for list checking
MsgBox ("This may take some time - please wait until i tell you i'm
finished")
If Len(SlidestoPrint) > 0 Then
Heading = "List of " & Folderspec & " (" & SlidestoPrint & ")"
Else
Heading = "List of " & Folderspec
End If
SubHeading = "from folder:" & GetDatabaseFolder & "\" & Folderspec & " on
" & Date & Chr(13) & " by Username: " & Environ("UserName") & " on computer:
" & Environ("userdomain")
#If Mac Then
PathSep = ":"
#Else
PathSep = "\"
#End If
'Open Microsoft Word
Set appWD = New Word.Application
appWD.Visible = True
appWD.Options.CheckGrammarAsYouType = False
appWD.Options.CheckSpellingAsYouType = False
'Open new Word Document
Set Document = appWD.Documents.Add
Document.ShowSpellingErrors = False
Document.ShowGrammaticalErrors = False
Sections = 2
If IncludeAlphabeticIndex Then Sections = Sections + 1
If IncludeNumericIndex Then Sections = Sections + 1
If Format = 1 Then 'if formatting is for A4 format
'Set up the page formatting for the document
Document.Sections(1).PageSetup.PaperSize = wdPaperA4
With Document.Sections(1).PageSetup
.BottomMargin = InchesToPoints(0.8)
.TopMargin = InchesToPoints(0.8)
.RightMargin = InchesToPoints(0.8)
.LeftMargin = InchesToPoints(0.8)
End With
'Set up styles to use in document
With Document.Styles(wdStyleHeading1)
.Font.Size = 24
.ParagraphFormat.KeepWithNext = True
End With
With Document.Styles(wdStyleHeading2)
.Font.Size = 20
.Font.Bold = True
.ParagraphFormat.SpaceAfter = 0
.ParagraphFormat.SpaceBefore = 12
.ParagraphFormat.KeepWithNext = True
.Borders.Item(wdBorderTop).LineStyle = wdLineStyleSingle
.Borders.DistanceFromTop = 4
End With
With Document.Styles(wdStyleHeading3)
.Font.Size = 20
.Font.Bold = False
.Font.Underline = wdUnderlineSingle
.ParagraphFormat.SpaceAfter = 0
.ParagraphFormat.SpaceBefore = 6
.ParagraphFormat.KeepWithNext = True
End With
With Document.Styles(wdStyleNormal)
.Font.Size = 18
.ParagraphFormat.SpaceAfter = 0
.ParagraphFormat.SpaceBefore = 0
End With
Document.ActiveWindow.Selection.EndOf Unit:=wdStory, Extend:=wdMove
Document.ActiveWindow.Selection.InsertBreak
Type:=wdSectionBreakContinuous
If Sections > 2 Then
Document.ActiveWindow.Selection.EndOf Unit:=wdStory,
Extend:=wdMove
Document.ActiveWindow.Selection.InsertBreak
Type:=wdSectionBreakNextPage
End If
If Sections > 3 Then
Document.ActiveWindow.Selection.EndOf Unit:=wdStory,
Extend:=wdMove
Document.ActiveWindow.Selection.InsertBreak
Type:=wdSectionBreakNextPage
End If
Else 'if formatting is for A5 format
'Set up the page formatting for the document
Document.Sections(1).PageSetup.PaperSize = wdPaperA5
With Document.Sections(1).PageSetup
.MirrorMargins = True
.BottomMargin = InchesToPoints(0.4)
.TopMargin = InchesToPoints(0.4)
.RightMargin = InchesToPoints(0.3)
.LeftMargin = InchesToPoints(0.8)
End With
'Set up styles to use in document
With Document.Styles(wdStyleHeading1)
.Font.Size = 14
.ParagraphFormat.KeepWithNext = True
End With
With Document.Styles(wdStyleHeading2)
.Font.Size = 9
.Font.Bold = True
.ParagraphFormat.SpaceAfter = 0
.ParagraphFormat.SpaceBefore = 12
.ParagraphFormat.KeepWithNext = True
.Borders.Item(wdBorderTop).LineStyle = wdLineStyleSingle
.Borders.DistanceFromTop = 4
End With
With Document.Styles(wdStyleHeading3)
.Font.Size = 8
.Font.Bold = False
.Font.Underline = wdUnderlineSingle
.ParagraphFormat.SpaceAfter = 0
.ParagraphFormat.SpaceBefore = 6
.ParagraphFormat.KeepWithNext = True
End With
With Document.Styles(wdStyleNormal)
.Font.Size = 8
.ParagraphFormat.SpaceAfter = 0
.ParagraphFormat.SpaceBefore = 0
End With
Document.ActiveWindow.Selection.EndOf Unit:=wdStory, Extend:=wdMove
Document.ActiveWindow.Selection.InsertBreak
Type:=wdSectionBreakNextPage
Document.Sections(2).PageSetup.TextColumns.SetCount NumColumns:=1
Document.Sections(2).PageSetup.TextColumns.Add EvenlySpaced:=True
Document.Sections(2).PageSetup.TextColumns.Spacing =
InchesToPoints(0.4)
If Sections > 2 Then
Document.ActiveWindow.Selection.EndOf Unit:=wdStory,
Extend:=wdMove
Document.ActiveWindow.Selection.InsertBreak
Type:=wdSectionBreakNextPage
End If
If Sections > 3 Then
Document.ActiveWindow.Selection.EndOf Unit:=wdStory,
Extend:=wdMove
Document.ActiveWindow.Selection.InsertBreak
Type:=wdSectionBreakNextPage
End If
End If
'Add Heading
Document.ActiveWindow.Selection.StartOf Unit:=wdStory, Extend:=wdMove
Document.ActiveWindow.Selection.Style = wdStyleHeading1
Document.ActiveWindow.Selection.Text = Heading & Chr(13)
Document.ActiveWindow.Selection.MoveDown Unit:=wdParagraph, Count:=1
Document.ActiveWindow.Selection.Style = wdStyleNormal
Document.ActiveWindow.Selection.EndOf Unit:=wdSection, Extend:=wdMove
Document.ActiveWindow.Selection.Text = SubHeading & Chr(13) & Chr(13)
Document.ActiveWindow.Selection.Borders.Item(wdBorderTop).LineStyle =
wdLineStyleSingle
SlideChecking = 0
oSlidestoPrint = SlidestoPrint
'If seeking a list of files then create that list in FilestoGrab
collection
If Len(oSlidestoPrint) > 0 Then
SlideChecking = 1
x = 0
y = 0
Do While InStr(1, oSlidestoPrint, ",") > 0
x = x + 1
oSlidestoPrint = Right(oSlidestoPrint, Len(oSlidestoPrint) -
InStr(1, oSlidestoPrint, ","))
Loop
oSlidestoPrint = SlidestoPrint
Do While InStr(1, oSlidestoPrint, "-") > 0
y = y + 1
oSlidestoPrint = Right(oSlidestoPrint, Len(oSlidestoPrint) -
InStr(1, oSlidestoPrint, "-"))
Loop
ArrayLength = y
ReDim FilestoGrab(x - y + 1)
ReDim FilesInBetween(y, 2)
oSlidestoPrint = SlidestoPrint
x = 0
y = 0
oSlidestoPrint = Trim(oSlidestoPrint)
Do While InStr(1, oSlidestoPrint, ",") > 0
Criterion = Mid(oSlidestoPrint, 1, InStr(1, oSlidestoPrint, ",")
- 1)
If InStr(1, Criterion, "-") > 0 Then
FilesInBetween(y, 0) = CInt(Left(Criterion, InStr(1,
Criterion, "-") - 1))
FilesInBetween(y, 1) = CInt(Right(Criterion, Len(Criterion)
- InStr(1, Criterion, "-")))
y = y + 1
Else
FilestoGrab(x) = CInt(Mid(oSlidestoPrint, 1,
InStr(oSlidestoPrint, ",") - 1))
x = x + 1
End If
oSlidestoPrint = Right(oSlidestoPrint, Len(oSlidestoPrint) -
InStr(1, oSlidestoPrint, ","))
oSlidestoPrint = Trim(oSlidestoPrint)
Loop
Criterion = oSlidestoPrint
If InStr(1, Criterion, "-") > 0 Then
FilesInBetween(y, 0) = CInt(Left(Criterion, InStr(1, Criterion,
"-") - 1))
FilesInBetween(y, 1) = CInt(Right(Criterion, Len(Criterion) -
InStr(1, Criterion, "-")))
y = y + 1
Else
FilestoGrab(x) = CInt(Criterion)
x = x + 1
End If
End If
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(GetDatabaseFolder & "\" & Folderspec)
Set fc = f.Files
x = 0
Document.Sections(Sections).Range.Select
'Go through each file in the folder
For Each f1 In fc
'check that it is a powerpoint file
If InStr(f1.Name, ".ppt") > 0 Or InStr(f1.Name, ".pps") > 0 Then
DoThisFile = True
Else
DoThisFile = False
End If
'Check if it fits with SlidestoPrint criteria
If SlideChecking = 1 And DoThisFile Then 'if slidechecking is required
If IsNumeric(Mid(f1.Name, 2, 4)) Then
x = CInt(Mid(f1.Name, 2, 4))
DoThisFile = False
'Check if it is inbetween any barriers
For y = 0 To ArrayLength
If x > FilesInBetween(y, 0) And x < FilesInBetween(y, 1)
Then DoThisFile = True
Next y
'Check if it is equal to any specified numbers
For Each f In FilestoGrab
If f = x Then DoThisFile = True
Next f
Else
DoThisFile = False
End If
End If
If DoThisFile Then
Songlist.Add Item:=f1.Name
'Open the presentation to get words from
Presentations.Open FileName:=GetDatabaseFolder & "\" & Folderspec &
"\" & f1.Name, ReadOnly:=msoTrue
Set oPres = ActivePresentation
Set oSlides = oPres.Slides
'Insert Heading in heading2 style
Document.ActiveWindow.Selection.Style = wdStyleHeading2
Document.ActiveWindow.Selection.Text = oPres.Name & Chr(13)
Document.ActiveWindow.Selection.MoveDown Unit:=wdParagraph, Count:=1
x = 0
For Each oSld In oSlides 'Loop thru each slide
x = x + 1
Document.ActiveWindow.Selection.Style = wdStyleHeading3
Document.ActiveWindow.Selection.Text = "Slide " & x & Chr(13)
Document.ActiveWindow.Selection.MoveDown Unit:=wdParagraph,
Count:=1
For Each oShp In oSld.Shapes 'Loop thru each
shape on slide
'Check to see if shape has a text frame and text
If oShp.HasTextFrame And oShp.TextFrame.HasText Then
If oShp.Type = msoPlaceholder Then
If oShp.PlaceholderFormat.Type = ppPlaceholderBody
Then
Document.ActiveWindow.Selection.Style =
wdStyleNormal
Document.ActiveWindow.Selection.Text =
oShp.TextFrame.TextRange
Document.ActiveWindow.Selection.EndOf
Unit:=wdStory, Extend:=wdExtend
Document.ActiveWindow.Selection.MoveEnd
Unit:=wdLine, Count:=-2
Document.ActiveWindow.Selection.ParagraphFormat.KeepWithNext = True
Document.ActiveWindow.Selection.EndOf
Unit:=wdStory, Extend:=wdMove
End If
End If ' msoPlaceholder
End If ' Has text frame/Has text
Next oShp
Next oSld
oPres.Close
End If
Next f1
'Type out the Song index's
If IncludeAlphabeticIndex = True Then
If IncludeNumericIndex = True Then
'Include both alphabetic and numeric indexes
Document.Sections(2).Range.Select
Document.ActiveWindow.Selection.EndOf Unit:=wdSection, Extend:=wdMove
Document.ActiveWindow.Selection.Style = wdStyleHeading2
Document.ActiveWindow.Selection.Text = "Alphabetic " & Folderspec &
" Index" & Chr(13)
Document.ActiveWindow.Selection.Borders.Item(wdBorderTop).Visible =
False
Document.ActiveWindow.Selection.EndOf Unit:=wdSection, Extend:=wdMove
Document.ActiveWindow.Selection.Style = wdStyleNormal
For Each Title In Songlist
Document.ActiveWindow.Selection.Text = Title & Chr(13)
Document.ActiveWindow.Selection.EndOf Unit:=wdSection,
Extend:=wdMove
Next Title
Document.ActiveWindow.Selection.Text = Chr(13) & Chr(13)
Document.ActiveWindow.Selection.EndOf Unit:=wdSection, Extend:=wdMove
Document.Sections(2).Range.Select
Document.ActiveWindow.Selection.MoveUp Unit:=wdLine, Extend:=wdExtend
Document.ActiveWindow.Selection.Copy
Document.Sections(3).Range.Select
Document.ActiveWindow.Selection.StartOf Unit:=wdSection,
Extend:=wdMove
Document.ActiveWindow.Selection.Paste
Document.Sections(2).Range.Select
Document.ActiveWindow.Selection.MoveStart Unit:=wdParagraph, Count:=1
Document.ActiveWindow.Selection.MoveEnd Unit:=wdParagraph, Count:=-2
Set myrange = Document.ActiveWindow.Selection.Range
For Each P In myrange.Paragraphs
P.Range.Select
If InStr(1, P, " ") > 0 Then
CharCount = InStr(1, P, " ")
Document.ActiveWindow.Selection.StartOf
Document.ActiveWindow.Selection.MoveRight Unit:=wdCharacter,
Count:=CharCount
Document.ActiveWindow.Selection.MoveLeft Unit:=wdCharacter,
Count:=1, Extend:=wdExtend
Document.ActiveWindow.Selection.TypeText Text:=vbTab
End If
Next P
myrange.Select
Document.ActiveWindow.Selection.Sort ExcludeHeader:=False,
FieldNumber:=2, Separator:=wdSortSeparateByTabs
Document.Sections(3).Range.Select
Document.ActiveWindow.Selection.StartOf Unit:=wdSection,
Extend:=wdMove
Document.ActiveWindow.Selection.MoveRight Unit:=wdWord, Count:=1,
Extend:=wdExtend
Document.ActiveWindow.Selection.Text = "Numeric "
Else
'include alphabetic index but not numeric index
Document.Sections(2).Range.Select
Document.ActiveWindow.Selection.EndOf Unit:=wdSection, Extend:=wdMove
Document.ActiveWindow.Selection.Style = wdStyleHeading2
Document.ActiveWindow.Selection.Text = "Alphabetic " & Folderspec &
" Index" & Chr(13)
Document.ActiveWindow.Selection.Borders.Item(wdBorderTop).Visible =
False
Document.ActiveWindow.Selection.EndOf Unit:=wdSection, Extend:=wdMove
Document.ActiveWindow.Selection.Style = wdStyleNormal
For Each Title In Songlist
Document.ActiveWindow.Selection.Text = Title & Chr(13)
Document.ActiveWindow.Selection.EndOf Unit:=wdSection,
Extend:=wdMove
Next Title
Document.ActiveWindow.Selection.Text = Chr(13)
Document.ActiveWindow.Selection.EndOf Unit:=wdSection, Extend:=wdMove
Document.Sections(2).Range.Select
Document.ActiveWindow.Selection.MoveStart Unit:=wdParagraph, Count:=1
Document.ActiveWindow.Selection.MoveEnd Unit:=wdParagraph, Count:=-2
Set myrange = Document.ActiveWindow.Selection.Range
For Each P In myrange.Paragraphs
P.Range.Select
If InStr(1, P, " ") > 0 Then
CharCount = InStr(1, P, " ")
Document.ActiveWindow.Selection.StartOf
Document.ActiveWindow.Selection.MoveRight Unit:=wdCharacter,
Count:=CharCount
Document.ActiveWindow.Selection.MoveLeft Unit:=wdCharacter,
Count:=1, Extend:=wdExtend
Document.ActiveWindow.Selection.TypeText Text:=vbTab
End If
Next P
myrange.Select
Document.ActiveWindow.Selection.Sort ExcludeHeader:=False,
FieldNumber:=2, Separator:=wdSortSeparateByTabs
End If
Else
If IncludeNumericIndex = True Then
'include numeric index but not alphabetic index
Document.Sections(2).Range.Select
Document.ActiveWindow.Selection.EndOf Unit:=wdSection, Extend:=wdMove
Document.ActiveWindow.Selection.Style = wdStyleHeading2
Document.ActiveWindow.Selection.Text = "Alphabetic " & Folderspec &
" Index" & Chr(13)
Document.ActiveWindow.Selection.Borders.Item(wdBorderTop).Visible =
False
Document.ActiveWindow.Selection.EndOf Unit:=wdSection, Extend:=wdMove
Document.ActiveWindow.Selection.Style = wdStyleNormal
For Each Title In Songlist
Document.ActiveWindow.Selection.Text = Title & Chr(13)
Document.ActiveWindow.Selection.EndOf Unit:=wdSection,
Extend:=wdMove
Next Title
Document.ActiveWindow.Selection.Text = Chr(13)
Document.ActiveWindow.Selection.EndOf Unit:=wdSection, Extend:=wdMove
Document.Sections(2).Range.Select
Document.ActiveWindow.Selection.StartOf Unit:=wdSection,
Extend:=wdMove
Document.ActiveWindow.Selection.MoveRight Unit:=wdWord, Count:=1,
Extend:=wdExtend
Document.ActiveWindow.Selection.Text = "Numeric "
Else
End If
End If
appWD.Visible = True
appWD.Options.CheckGrammarAsYouType = True
appWD.Options.CheckSpellingAsYouType = True
Document.ShowSpellingErrors = True
Document.ShowGrammaticalErrors = True
Set appWD = Nothing
Set Document = Nothing
Set fs = Nothing
Set f = Nothing
Set fc = Nothing
Set oPres = Nothing
Set oSlides = Nothing
Set myrange = Nothing
MsgBox ("Finished - please remember to save this document if you need to")
End Sub
the remote server machine does not exist or is unavailable.
i have a macro within powerpoint which opens a word document formats it and
writes a whole document into it. if i run this powerpoint macro once, then
close the microsoft word completely, then run this macro a second time run
time error '462' occurs. if microsoft word application stays open (even
though the document created might be closed) the error does not occur.
the code is below...
Sub DumpTextAndFormatInWord(Folderspec, IncludeAlphabeticIndex,
IncludeNumericIndex, SlidestoPrint, Format)
Dim appWD As Word.Application
Dim Document As Word.Document
Dim fs, f, f1, fc, S
Dim oPres As Presentation
Dim oSlides As Slides
Dim oSld As Slide 'Slide Object
Dim oShp As Shape 'Shape Object
Dim PathSep As String
Dim x As Integer
Dim y As Integer
Dim Sections As Integer
Dim Heading As String
Dim SubHeading As String
Dim FilestoGrab() As Integer
Dim FilesInBetween() As Integer
Dim ArrayLength As Integer
Dim File As Integer
Dim Songlist As New Collection
Dim DoThisFile As Boolean
Dim oSlidestoPrint As String
Dim Criterion As String
Dim oSlidestoPrintFrom As Integer
Dim oSlidestoPrintTo As Integer
Dim SlideChecking As Integer 'Set to 0 for no checking, 1 for from to
checking, 2 for list checking
MsgBox ("This may take some time - please wait until i tell you i'm
finished")
If Len(SlidestoPrint) > 0 Then
Heading = "List of " & Folderspec & " (" & SlidestoPrint & ")"
Else
Heading = "List of " & Folderspec
End If
SubHeading = "from folder:" & GetDatabaseFolder & "\" & Folderspec & " on
" & Date & Chr(13) & " by Username: " & Environ("UserName") & " on computer:
" & Environ("userdomain")
#If Mac Then
PathSep = ":"
#Else
PathSep = "\"
#End If
'Open Microsoft Word
Set appWD = New Word.Application
appWD.Visible = True
appWD.Options.CheckGrammarAsYouType = False
appWD.Options.CheckSpellingAsYouType = False
'Open new Word Document
Set Document = appWD.Documents.Add
Document.ShowSpellingErrors = False
Document.ShowGrammaticalErrors = False
Sections = 2
If IncludeAlphabeticIndex Then Sections = Sections + 1
If IncludeNumericIndex Then Sections = Sections + 1
If Format = 1 Then 'if formatting is for A4 format
'Set up the page formatting for the document
Document.Sections(1).PageSetup.PaperSize = wdPaperA4
With Document.Sections(1).PageSetup
.BottomMargin = InchesToPoints(0.8)
.TopMargin = InchesToPoints(0.8)
.RightMargin = InchesToPoints(0.8)
.LeftMargin = InchesToPoints(0.8)
End With
'Set up styles to use in document
With Document.Styles(wdStyleHeading1)
.Font.Size = 24
.ParagraphFormat.KeepWithNext = True
End With
With Document.Styles(wdStyleHeading2)
.Font.Size = 20
.Font.Bold = True
.ParagraphFormat.SpaceAfter = 0
.ParagraphFormat.SpaceBefore = 12
.ParagraphFormat.KeepWithNext = True
.Borders.Item(wdBorderTop).LineStyle = wdLineStyleSingle
.Borders.DistanceFromTop = 4
End With
With Document.Styles(wdStyleHeading3)
.Font.Size = 20
.Font.Bold = False
.Font.Underline = wdUnderlineSingle
.ParagraphFormat.SpaceAfter = 0
.ParagraphFormat.SpaceBefore = 6
.ParagraphFormat.KeepWithNext = True
End With
With Document.Styles(wdStyleNormal)
.Font.Size = 18
.ParagraphFormat.SpaceAfter = 0
.ParagraphFormat.SpaceBefore = 0
End With
Document.ActiveWindow.Selection.EndOf Unit:=wdStory, Extend:=wdMove
Document.ActiveWindow.Selection.InsertBreak
Type:=wdSectionBreakContinuous
If Sections > 2 Then
Document.ActiveWindow.Selection.EndOf Unit:=wdStory,
Extend:=wdMove
Document.ActiveWindow.Selection.InsertBreak
Type:=wdSectionBreakNextPage
End If
If Sections > 3 Then
Document.ActiveWindow.Selection.EndOf Unit:=wdStory,
Extend:=wdMove
Document.ActiveWindow.Selection.InsertBreak
Type:=wdSectionBreakNextPage
End If
Else 'if formatting is for A5 format
'Set up the page formatting for the document
Document.Sections(1).PageSetup.PaperSize = wdPaperA5
With Document.Sections(1).PageSetup
.MirrorMargins = True
.BottomMargin = InchesToPoints(0.4)
.TopMargin = InchesToPoints(0.4)
.RightMargin = InchesToPoints(0.3)
.LeftMargin = InchesToPoints(0.8)
End With
'Set up styles to use in document
With Document.Styles(wdStyleHeading1)
.Font.Size = 14
.ParagraphFormat.KeepWithNext = True
End With
With Document.Styles(wdStyleHeading2)
.Font.Size = 9
.Font.Bold = True
.ParagraphFormat.SpaceAfter = 0
.ParagraphFormat.SpaceBefore = 12
.ParagraphFormat.KeepWithNext = True
.Borders.Item(wdBorderTop).LineStyle = wdLineStyleSingle
.Borders.DistanceFromTop = 4
End With
With Document.Styles(wdStyleHeading3)
.Font.Size = 8
.Font.Bold = False
.Font.Underline = wdUnderlineSingle
.ParagraphFormat.SpaceAfter = 0
.ParagraphFormat.SpaceBefore = 6
.ParagraphFormat.KeepWithNext = True
End With
With Document.Styles(wdStyleNormal)
.Font.Size = 8
.ParagraphFormat.SpaceAfter = 0
.ParagraphFormat.SpaceBefore = 0
End With
Document.ActiveWindow.Selection.EndOf Unit:=wdStory, Extend:=wdMove
Document.ActiveWindow.Selection.InsertBreak
Type:=wdSectionBreakNextPage
Document.Sections(2).PageSetup.TextColumns.SetCount NumColumns:=1
Document.Sections(2).PageSetup.TextColumns.Add EvenlySpaced:=True
Document.Sections(2).PageSetup.TextColumns.Spacing =
InchesToPoints(0.4)
If Sections > 2 Then
Document.ActiveWindow.Selection.EndOf Unit:=wdStory,
Extend:=wdMove
Document.ActiveWindow.Selection.InsertBreak
Type:=wdSectionBreakNextPage
End If
If Sections > 3 Then
Document.ActiveWindow.Selection.EndOf Unit:=wdStory,
Extend:=wdMove
Document.ActiveWindow.Selection.InsertBreak
Type:=wdSectionBreakNextPage
End If
End If
'Add Heading
Document.ActiveWindow.Selection.StartOf Unit:=wdStory, Extend:=wdMove
Document.ActiveWindow.Selection.Style = wdStyleHeading1
Document.ActiveWindow.Selection.Text = Heading & Chr(13)
Document.ActiveWindow.Selection.MoveDown Unit:=wdParagraph, Count:=1
Document.ActiveWindow.Selection.Style = wdStyleNormal
Document.ActiveWindow.Selection.EndOf Unit:=wdSection, Extend:=wdMove
Document.ActiveWindow.Selection.Text = SubHeading & Chr(13) & Chr(13)
Document.ActiveWindow.Selection.Borders.Item(wdBorderTop).LineStyle =
wdLineStyleSingle
SlideChecking = 0
oSlidestoPrint = SlidestoPrint
'If seeking a list of files then create that list in FilestoGrab
collection
If Len(oSlidestoPrint) > 0 Then
SlideChecking = 1
x = 0
y = 0
Do While InStr(1, oSlidestoPrint, ",") > 0
x = x + 1
oSlidestoPrint = Right(oSlidestoPrint, Len(oSlidestoPrint) -
InStr(1, oSlidestoPrint, ","))
Loop
oSlidestoPrint = SlidestoPrint
Do While InStr(1, oSlidestoPrint, "-") > 0
y = y + 1
oSlidestoPrint = Right(oSlidestoPrint, Len(oSlidestoPrint) -
InStr(1, oSlidestoPrint, "-"))
Loop
ArrayLength = y
ReDim FilestoGrab(x - y + 1)
ReDim FilesInBetween(y, 2)
oSlidestoPrint = SlidestoPrint
x = 0
y = 0
oSlidestoPrint = Trim(oSlidestoPrint)
Do While InStr(1, oSlidestoPrint, ",") > 0
Criterion = Mid(oSlidestoPrint, 1, InStr(1, oSlidestoPrint, ",")
- 1)
If InStr(1, Criterion, "-") > 0 Then
FilesInBetween(y, 0) = CInt(Left(Criterion, InStr(1,
Criterion, "-") - 1))
FilesInBetween(y, 1) = CInt(Right(Criterion, Len(Criterion)
- InStr(1, Criterion, "-")))
y = y + 1
Else
FilestoGrab(x) = CInt(Mid(oSlidestoPrint, 1,
InStr(oSlidestoPrint, ",") - 1))
x = x + 1
End If
oSlidestoPrint = Right(oSlidestoPrint, Len(oSlidestoPrint) -
InStr(1, oSlidestoPrint, ","))
oSlidestoPrint = Trim(oSlidestoPrint)
Loop
Criterion = oSlidestoPrint
If InStr(1, Criterion, "-") > 0 Then
FilesInBetween(y, 0) = CInt(Left(Criterion, InStr(1, Criterion,
"-") - 1))
FilesInBetween(y, 1) = CInt(Right(Criterion, Len(Criterion) -
InStr(1, Criterion, "-")))
y = y + 1
Else
FilestoGrab(x) = CInt(Criterion)
x = x + 1
End If
End If
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(GetDatabaseFolder & "\" & Folderspec)
Set fc = f.Files
x = 0
Document.Sections(Sections).Range.Select
'Go through each file in the folder
For Each f1 In fc
'check that it is a powerpoint file
If InStr(f1.Name, ".ppt") > 0 Or InStr(f1.Name, ".pps") > 0 Then
DoThisFile = True
Else
DoThisFile = False
End If
'Check if it fits with SlidestoPrint criteria
If SlideChecking = 1 And DoThisFile Then 'if slidechecking is required
If IsNumeric(Mid(f1.Name, 2, 4)) Then
x = CInt(Mid(f1.Name, 2, 4))
DoThisFile = False
'Check if it is inbetween any barriers
For y = 0 To ArrayLength
If x > FilesInBetween(y, 0) And x < FilesInBetween(y, 1)
Then DoThisFile = True
Next y
'Check if it is equal to any specified numbers
For Each f In FilestoGrab
If f = x Then DoThisFile = True
Next f
Else
DoThisFile = False
End If
End If
If DoThisFile Then
Songlist.Add Item:=f1.Name
'Open the presentation to get words from
Presentations.Open FileName:=GetDatabaseFolder & "\" & Folderspec &
"\" & f1.Name, ReadOnly:=msoTrue
Set oPres = ActivePresentation
Set oSlides = oPres.Slides
'Insert Heading in heading2 style
Document.ActiveWindow.Selection.Style = wdStyleHeading2
Document.ActiveWindow.Selection.Text = oPres.Name & Chr(13)
Document.ActiveWindow.Selection.MoveDown Unit:=wdParagraph, Count:=1
x = 0
For Each oSld In oSlides 'Loop thru each slide
x = x + 1
Document.ActiveWindow.Selection.Style = wdStyleHeading3
Document.ActiveWindow.Selection.Text = "Slide " & x & Chr(13)
Document.ActiveWindow.Selection.MoveDown Unit:=wdParagraph,
Count:=1
For Each oShp In oSld.Shapes 'Loop thru each
shape on slide
'Check to see if shape has a text frame and text
If oShp.HasTextFrame And oShp.TextFrame.HasText Then
If oShp.Type = msoPlaceholder Then
If oShp.PlaceholderFormat.Type = ppPlaceholderBody
Then
Document.ActiveWindow.Selection.Style =
wdStyleNormal
Document.ActiveWindow.Selection.Text =
oShp.TextFrame.TextRange
Document.ActiveWindow.Selection.EndOf
Unit:=wdStory, Extend:=wdExtend
Document.ActiveWindow.Selection.MoveEnd
Unit:=wdLine, Count:=-2
Document.ActiveWindow.Selection.ParagraphFormat.KeepWithNext = True
Document.ActiveWindow.Selection.EndOf
Unit:=wdStory, Extend:=wdMove
End If
End If ' msoPlaceholder
End If ' Has text frame/Has text
Next oShp
Next oSld
oPres.Close
End If
Next f1
'Type out the Song index's
If IncludeAlphabeticIndex = True Then
If IncludeNumericIndex = True Then
'Include both alphabetic and numeric indexes
Document.Sections(2).Range.Select
Document.ActiveWindow.Selection.EndOf Unit:=wdSection, Extend:=wdMove
Document.ActiveWindow.Selection.Style = wdStyleHeading2
Document.ActiveWindow.Selection.Text = "Alphabetic " & Folderspec &
" Index" & Chr(13)
Document.ActiveWindow.Selection.Borders.Item(wdBorderTop).Visible =
False
Document.ActiveWindow.Selection.EndOf Unit:=wdSection, Extend:=wdMove
Document.ActiveWindow.Selection.Style = wdStyleNormal
For Each Title In Songlist
Document.ActiveWindow.Selection.Text = Title & Chr(13)
Document.ActiveWindow.Selection.EndOf Unit:=wdSection,
Extend:=wdMove
Next Title
Document.ActiveWindow.Selection.Text = Chr(13) & Chr(13)
Document.ActiveWindow.Selection.EndOf Unit:=wdSection, Extend:=wdMove
Document.Sections(2).Range.Select
Document.ActiveWindow.Selection.MoveUp Unit:=wdLine, Extend:=wdExtend
Document.ActiveWindow.Selection.Copy
Document.Sections(3).Range.Select
Document.ActiveWindow.Selection.StartOf Unit:=wdSection,
Extend:=wdMove
Document.ActiveWindow.Selection.Paste
Document.Sections(2).Range.Select
Document.ActiveWindow.Selection.MoveStart Unit:=wdParagraph, Count:=1
Document.ActiveWindow.Selection.MoveEnd Unit:=wdParagraph, Count:=-2
Set myrange = Document.ActiveWindow.Selection.Range
For Each P In myrange.Paragraphs
P.Range.Select
If InStr(1, P, " ") > 0 Then
CharCount = InStr(1, P, " ")
Document.ActiveWindow.Selection.StartOf
Document.ActiveWindow.Selection.MoveRight Unit:=wdCharacter,
Count:=CharCount
Document.ActiveWindow.Selection.MoveLeft Unit:=wdCharacter,
Count:=1, Extend:=wdExtend
Document.ActiveWindow.Selection.TypeText Text:=vbTab
End If
Next P
myrange.Select
Document.ActiveWindow.Selection.Sort ExcludeHeader:=False,
FieldNumber:=2, Separator:=wdSortSeparateByTabs
Document.Sections(3).Range.Select
Document.ActiveWindow.Selection.StartOf Unit:=wdSection,
Extend:=wdMove
Document.ActiveWindow.Selection.MoveRight Unit:=wdWord, Count:=1,
Extend:=wdExtend
Document.ActiveWindow.Selection.Text = "Numeric "
Else
'include alphabetic index but not numeric index
Document.Sections(2).Range.Select
Document.ActiveWindow.Selection.EndOf Unit:=wdSection, Extend:=wdMove
Document.ActiveWindow.Selection.Style = wdStyleHeading2
Document.ActiveWindow.Selection.Text = "Alphabetic " & Folderspec &
" Index" & Chr(13)
Document.ActiveWindow.Selection.Borders.Item(wdBorderTop).Visible =
False
Document.ActiveWindow.Selection.EndOf Unit:=wdSection, Extend:=wdMove
Document.ActiveWindow.Selection.Style = wdStyleNormal
For Each Title In Songlist
Document.ActiveWindow.Selection.Text = Title & Chr(13)
Document.ActiveWindow.Selection.EndOf Unit:=wdSection,
Extend:=wdMove
Next Title
Document.ActiveWindow.Selection.Text = Chr(13)
Document.ActiveWindow.Selection.EndOf Unit:=wdSection, Extend:=wdMove
Document.Sections(2).Range.Select
Document.ActiveWindow.Selection.MoveStart Unit:=wdParagraph, Count:=1
Document.ActiveWindow.Selection.MoveEnd Unit:=wdParagraph, Count:=-2
Set myrange = Document.ActiveWindow.Selection.Range
For Each P In myrange.Paragraphs
P.Range.Select
If InStr(1, P, " ") > 0 Then
CharCount = InStr(1, P, " ")
Document.ActiveWindow.Selection.StartOf
Document.ActiveWindow.Selection.MoveRight Unit:=wdCharacter,
Count:=CharCount
Document.ActiveWindow.Selection.MoveLeft Unit:=wdCharacter,
Count:=1, Extend:=wdExtend
Document.ActiveWindow.Selection.TypeText Text:=vbTab
End If
Next P
myrange.Select
Document.ActiveWindow.Selection.Sort ExcludeHeader:=False,
FieldNumber:=2, Separator:=wdSortSeparateByTabs
End If
Else
If IncludeNumericIndex = True Then
'include numeric index but not alphabetic index
Document.Sections(2).Range.Select
Document.ActiveWindow.Selection.EndOf Unit:=wdSection, Extend:=wdMove
Document.ActiveWindow.Selection.Style = wdStyleHeading2
Document.ActiveWindow.Selection.Text = "Alphabetic " & Folderspec &
" Index" & Chr(13)
Document.ActiveWindow.Selection.Borders.Item(wdBorderTop).Visible =
False
Document.ActiveWindow.Selection.EndOf Unit:=wdSection, Extend:=wdMove
Document.ActiveWindow.Selection.Style = wdStyleNormal
For Each Title In Songlist
Document.ActiveWindow.Selection.Text = Title & Chr(13)
Document.ActiveWindow.Selection.EndOf Unit:=wdSection,
Extend:=wdMove
Next Title
Document.ActiveWindow.Selection.Text = Chr(13)
Document.ActiveWindow.Selection.EndOf Unit:=wdSection, Extend:=wdMove
Document.Sections(2).Range.Select
Document.ActiveWindow.Selection.StartOf Unit:=wdSection,
Extend:=wdMove
Document.ActiveWindow.Selection.MoveRight Unit:=wdWord, Count:=1,
Extend:=wdExtend
Document.ActiveWindow.Selection.Text = "Numeric "
Else
End If
End If
appWD.Visible = True
appWD.Options.CheckGrammarAsYouType = True
appWD.Options.CheckSpellingAsYouType = True
Document.ShowSpellingErrors = True
Document.ShowGrammaticalErrors = True
Set appWD = Nothing
Set Document = Nothing
Set fs = Nothing
Set f = Nothing
Set fc = Nothing
Set oPres = Nothing
Set oSlides = Nothing
Set myrange = Nothing
MsgBox ("Finished - please remember to save this document if you need to")
End Sub