-----------------------------------------------
Sub fontStyle()
Dim osld As Slide, oshp As Shape
For Each osld In ActivePresentation.Slides
For Each oshp In osld.Shapes
'MsgBox "shape " & oshp.Type
On Error Resume Next
With oshp.TextFrame.TextRange.Font
.Name = "MS PGothic"
.Shadow = False
End With
Next oshp
Next osld
End Sub
MACRO TO GET TEXT OF 'Click to Add Note' FROM ALL THE SLIDES AND SAVE IN UTF
---------------------------------------------------------
Sub test()
Dim oSl As Slide
Dim oSh As Shape
Dim strNotesText As String
Dim strFileName As String
Dim intFileNum As Integer
Dim lngReturn As Long
' Get a filename to store the collected text
strFileName = "C:\notes.xml"
strNotesText = strNotesText & "
' is the path valid? crude but effective test: try to create the file.
intFileNum = FreeFile()
On Error Resume Next
Open strFileName For Output As intFileNum
If Err.Number <> 0 Then ' we have a problem
MsgBox "Couldn't create the file: " & strFileName & vbCrLf _
& "Please try again."
Exit Sub
End If
Close #intFileNum ' temporarily
' Get the notes text
Set oSlides = ActivePresentation.Slides
For Each oSl In oSlides
For Each oSh In oSl.NotesPage.Shapes
If oSh.PlaceholderFormat.Type = ppPlaceholderBody Then
If oSh.HasTextFrame Then
'If oSh.TextFrame.HasText Then
Dim str, data
str = oSh.TextFrame.TextRange.Text
data = ""
For i = 0 To Len(str)
str1 = Mid$(str, i, 1)
Select Case Asc(str1)
Case 13:
data = data & "<br>"
Case 146:
data = data & "'"
Case 147:
data = data & """
Case 148:
data = data & """
Case 151:
data = data & "-"
Case 160:
data = data & ""
Case Else
data = data & str1
End Select
Next i
strNotesText = strNotesText & vbCrLf & "
'End If
End If
End If
Next oSh
Next oSl
strNotesText = strNotesText & vbCrLf & "
' now write the text to file
'Open strFileName For Output As intFileNum
'Print #intFileNum, strNotesText
'Close #intFileNum
writeOut strNotesText, strFileName
' show what we've done
lngReturn = Shell("NOTEPAD.EXE " & strFileName, vbNormalFocus)
End Sub
Public Function writeOut(cText As String, file As String) As Integer
On Error GoTo errHandler
Dim fsT, tFilePath As String
tFilePath = file
Set fsT = CreateObject("ADODB.Stream")
fsT.Type = 2
fsT.Charset = "utf-8"
fsT.Open
fsT.writetext cText
fsT.SaveToFile tFilePath, 2
GoTo finish
errHandler:
MsgBox (Err.Description)
writeOut = 0
Exit Function
finish:
writeOut = 1
End Function
---------------------------------------------------------
