허접한 소스이지만 표시된 부분을 제외하고는 저에게 저작권이 있습니다.
All rights reserved.
'Const MAX = 100
Const DELIMITER = ".?!" & vbNewLine ' delimiters that split the paragraph
Const DEFAULT_SLIDE = 1 ' the slide to copy the layout style from
Const MARGIN = 40 ' margin of the generated textbox
Sub generate()
Dim txtFile As String ' text file name
Dim fileNo As Integer ' file handle
Dim FSO, TF As Object ' file system object
Dim buffer As String ' temporary string buffer
Dim sentence() As String ' the main array to save sentences
Dim i, total As Long
Dim myLayout As CustomLayout
Dim mySlide As Slide
Dim myShape As Shape
Dim myWidth, myHeight As Integer 'slide width and height
Dim slideCount As Integer
'txtFile = "text2sample.txt"
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Filters.Clear
.Filters.Add "Word text file", "*.txt"
.InitialFileName = ActivePresentation.Path & "\" 'Environ("USERPROFILE") & "\Desktop\"
.AllowMultiSelect = False
If .Show = True Then txtFile = .SelectedItems(1)
End With
If Len(txtFile) = 0 Or Len(Dir$(txtFile)) = 0 Then
MsgBox txtFile & " not found!", vbCritical
Exit Sub
End If
'Initialize array
'ReDim sentence()
'get file handle number
'fileNo = FreeFile()
'Open txtFile For Input As #fileNo
'
'i = 0
'Do While Not EOF(fileNo)
' Line Input #fileNo, buffer 'read & save sentences line by line
' ReDim Preserve sentence(i + 1) ' increase 1 more array
' sentence(i) = LTrim(RTrim(buffer))
' i = i + 1
'Loop
'Close #fileNo
Set FSO = CreateObject("Scripting.FileSystemObject")
Set TF = FSO.OpenTextFile(txtFile, 1)
buffer = TF.ReadAll
'MsgBox buffer
TF.Close
Set FSO = Nothing
'sentence() = Split(buffer, DELIMITER)
sentence() = mySplit(buffer, DELIMITER)
total = UBound(sentence)
'MsgBox total
Randomize ' for random color
With ActivePresentation.PageSetup
myWidth = .SlideWidth - MARGIN 'get width and height
myHeight = .SlideHeight - MARGIN
End With
For i = LBound(sentence) To total
'MsgBox i & ")" & sentence(i)
If Len(sentence(i)) > 2 Then 'if only the sentence contains more than 2 characters (CR+LF)
slideCount = ActivePresentation.Slides.Count
Set myLayout = ActivePresentation.Slides(DEFAULT_SLIDE).CustomLayout
'add a slide like slide #1
Set mySlide = ActivePresentation.Slides.AddSlide(slideCount + 1, myLayout)
'add a textbox with margin
Set myShape = ActivePresentation.Slides(slideCount + 1).Shapes. _
AddTextbox(msoTextOrientationHorizontal, MARGIN, MARGIN, myWidth, myHeight)
With myShape
'add a sentence in the textbox
.TextFrame.TextRange.Text = sentence(i)
.TextFrame.TextRange.Font.Size = 60
' color 255 is too bright. So pick a less bright color (200)
.TextFrame.TextRange.Font.Color.RGB = RGB(Int(Rnd * 200), Int(Rnd * 200), Int(Rnd * 200))
.TextFrame.TextRange.Font.Bold = msoTrue
.TextFrame.TextRange.Font.Shadow = msoTrue
' If you want to change the color of the shape,
'.Fill.ForeColor.RGB = RGB(Int(Rnd * 200), Int(Rnd * 200), Int(Rnd * 200))
'.Fill.BackColor.RGB = RGB(Int(Rnd * 200), Int(Rnd * 200), Int(Rnd * 200))
'.Fill.Solid
End With
'add a textbox for slideshow progress ex) 1/100
Set myShape = ActivePresentation.Slides(slideCount + 1).Shapes. _
AddTextbox(msoTextOrientationHorizontal, 0, 0, 150, 20)
With myShape
.TextFrame.TextRange.Text = "( " & i & " /" & total & " )"
.TextFrame.TextRange.Font.Size = 20
.TextFrame.TextRange.Font.Color.RGB = RGB(100, 100, 100)
End With
End If
Next
MsgBox i & " sentecnes were read and " & slideCount + 1 & " Slides were added.", vbInformation
End Sub
'remove all the generated slides and go back to original
Sub revert()
Dim answer As Integer
Dim i, j As Integer
If ActivePresentation.Slides.Count > 1 Then
answer = MsgBox("Are you sure to delete all the slides after #1", vbOKCancel, "Confirm", "", 1000)
j = 0
If answer = vbOK Then
For i = ActivePresentation.Slides.Count To 2 Step -1
ActivePresentation.Slides(i).Delete
j = j + 1
Next
MsgBox j & " Slides were deleted!"
End If
Else
MsgBox "ERROR) Nothing to revert!" & vbCr & vbCr & "Generate a new slideshow first.", vbCritical
End If
End Sub
' Same as VB split(). But, keep the delimiter
' A little changed from the code by CPearson
' ( http://www.cpearson.com/excel/splitondelimiters.aspx )
Function mySplit(Text As String, DelimChars As String) As String()
Dim Pos1 As Long
Dim N As Long
Dim M As Long
Dim Arr() As String
Dim x As Long
If Len(Text) = 0 Then
Exit Function
End If
If DelimChars = vbNullString Then
mySplit = Array(Text)
Exit Function
End If
ReDim Arr(1 To Len(Text))
x = 0
N = 0
Pos1 = 1
For N = 1 To Len(Text)
For M = 1 To Len(DelimChars)
If StrComp(Mid(Text, N, 1), Mid(DelimChars, M, 1), vbTextCompare) = 0 Then
x = x + 1
Arr(x) = Mid(Text, Pos1, N - Pos1 + 1) 'N - Pos1 ' changed to include the Delimiter also
Pos1 = N + 1
N = N + 1
End If
Next M
Next N
If Pos1 <= Len(Text) Then
x = x + 1
Arr(x) = Mid(Text, Pos1)
End If
ReDim Preserve Arr(1 To x)
mySplit = Arr
End Function
sentence2slide.pptm
sentence2sample.txt
최근댓글