Private Sub cmdGo_Click()
'
' constants
' presentation
Dim ppOld As Presentation, ppNew As Presentation
' controls
Const kiPageOrientationLandscape = msoOrientationHorizontal
Const kiPageOrientationPortrait = msoOrientationVertical
Const kiPageDistributionSingle = 1
Const kiPageDistributionMulti = 2
Const kiImageTypeStaticPng = 1
Const kiImageTypeAnimatedGif = 2
' others
Const kiRatioVertical = 3
Const kiRatioHorizontal = 4
Const knDot5 As Single = 0.499999
Const kn1 As Single = 1
Const ksAlphabet = "abcdefghijklmnopqrstuvwxyz "
Const ksSlide = "Slide_"
'
' declarations
Dim sText As String, iClean As Integer
Dim iPageOrientation As Integer, iPageDistribution As Integer
Dim sImageLayout As String, iImageType As Integer
Dim iRatioVertical As Integer, iRatioHorizontal As Integer
Dim iVertical As Integer, iHorizontal As Integer
Dim iV As Integer, iH As Integer, iDelta As Integer
Dim iSlides As Integer, iSlide As Integer
Dim iWidthSlide As Integer, iHeightSlide As Integer
Dim iWidthImage As Integer, iHeightImage As Integer
Dim iImage As Integer, iPosX As Integer, iPosY As Integer
Dim I As Integer, J As Integer, K As Integer, N As Single, A As String, bOk As Boolean
'
' start
bOk = True
If txtText.Text = "" Then bOk = False
If IsNull(optLandscape.Value) Then bOk = False
If IsNull(optPortrait.Value) Then bOk = False
If IsNull(optSinglePage.Value) Then bOk = False
If IsNull(optMultiPage.Value) Then bOk = False
If lstLayout.ListIndex = -1 Then bOk = False
If IsNull(optStaticPng.Value) Then bOk = False
If IsNull(optAnimatedGif.Value) Then bOk = False
If Not bOk Then
Beep
Exit Sub
End If
'
' process
' new presentation
With Application
Set ppOld = ActivePresentation
.Presentations.Add msoTrue
Set ppNew = .Presentations(.Presentations.Count)
End With
With ppNew
gsPresentationNewName = .Name
.SlideShowSettings.LoopUntilStopped = msoTrue
.Windows(1).ViewType = ppViewSlideSorter
End With
' control values
...
...
' presentation setup
With ActivePresentation.PageSetup
.SlideOrientation = iPageOrientation
iWidthSlide = .SlideWidth
iHeightSlide = .SlideHeight
End With
' text clean
sText = LCase(sText)
gsTextClean = ""
For I = 1 To Len(sText)
If InStr(ksAlphabet, Mid(sText, I, 1)) <> 0 Then _
gsTextClean = gsTextClean & Mid(sText, I, 1)
Next I
iClean = Len(gsTextClean)
' ratios
Select Case iPageOrientation
Case msoOrientationHorizontal
iRatioVertical = kiRatioVertical
iRatioHorizontal = kiRatioHorizontal
Case msoOrientationVertical
iRatioVertical = kiRatioHorizontal
iRatioHorizontal = kiRatioVertical
Case Else
iRatioVertical = 0
iRatioHorizontal = 0
End Select
' no. of slides
Select Case iPageDistribution
Case 1
N = iClean / kiRatioHorizontal / kiRatioVertical
iVertical = Round(Sqr(N) * iRatioVertical, 0)
iHorizontal = Round(Sqr(N) * iRatioHorizontal, 0)
iV = 0
iH = 0
iDelta = iClean
For J = iVertical To iVertical + 1
For K = iHorizontal To iHorizontal + 1
If Abs(J * K - iClean) < iDelta Then
iV = J
iH = K
iDelta = Abs(J * K - iClean)
End If
Next K
Next J
iVertical = iV
iHorizontal = iH
Case 2
iVertical = Val(Left(sImageLayout, InStr(sImageLayout, gksX) - 1))
iHorizontal = _
Val(Right(sImageLayout, Len(sImageLayout) - InStr(sImageLayout, gksX)))
End Select
iSlides = Round((Len(gsTextClean) / (iHorizontal * iVertical) + knDot5))
iWidthImage = Int(iWidthSlide / iHorizontal)
iHeightImage = Int(iHeightSlide / iVertical)
' slides
With ActivePresentation
' delete old
InitializeSlides
' create new
iSlide = 0
iImage = 0
bOk = False
For I = 1 To iSlides
iSlide = iSlide + 1
.Slides.Add iSlide, ppLayoutBlank
With .Slides(iSlide)
' rename
.Name = ksSlide & Format(I, "000")
' fill
iPosY = -iHeightImage
For J = 1 To iVertical
iPosY = iPosY + iHeightImage
iPosX = -iWidthImage
For K = 1 To iHorizontal
If iImage < Len(gsTextClean) Then
' letter
iImage = iImage + 1
iPosX = iPosX + iWidthImage
A = Mid$(gsTextClean, iImage, 1)
If A = Space(1) Then
' empty image (rectangle)
.Shapes.AddShape msoShapeRectangle, _
iPosX, iPosY, iWidthImage, iHeightImage
With .Shapes(.Shapes.Count)
With .Fill
.Solid
.ForeColor.RGB = RGB(0, 0, 0)
End With
With .Line
.ForeColor.RGB = RGB(0, 0, 0)
End With
End With
Else
' image from slide
Select Case iImageType
Case 1
A = pgksSlidesFixed & pgksBackSlash & A & pgksPng
Case 2
A = pgksAnimatedGif & pgksBackSlash & A & pgksGif
End Select
A = ppOld.Path & pgksBackSlash & A
.Shapes.AddPicture A, msoFalse, msoTrue, _
iPosX, iPosY, iWidthImage, iHeightImage
End If
Else
bOk = True
Exit For
End If
If bOk Then Exit For
Next K
If bOk Then Exit For
Next J
End With
Next I
End With
'
' end
Beep
With ActivePresentation.SlideShowSettings
.LoopUntilStopped = msoTrue
.Run
End With
'
End Sub
Private Sub cmdSaveCopyxxxx_Click()
Dim ppOld As Presentation, ppNew As Presentation
Dim I As Integer
' copy slides
With ppOld
.Windows(1).ViewType = ppViewSlide
For I = .Slides.Count To 1 Step -1
If Not (.Slides(I).Name Like pgksSlidesFixed & pgksAsterisk) Then
' copy & paste
.Slides(I).Copy
ppNew.Windows(1).View.Paste
' backcolor
ppNew.Slides(ppNew.Slides.Count).FollowMasterBackground = False
ppNew.Slides(ppNew.Slides.Count).Background.Fill.Solid
ppNew.Slides(ppNew.Slides.Count).Background.Fill.ForeColor.RGB = RGB(0, 0, 0)
End If
Next I
End With
End Sub
Private Sub cmdSave_Click()
' constants
Const ksDot = "."
Const ksUnderscore = "_"
' declarations
Dim ppNew As Presentation
Dim sFilename As String, sFilenameClean As String
' start
Set ppNew = Application.Presentations(gsPresentationNewName)
' process
With ActivePresentation
sFilenameClean = Replace(gsTextClean, Space(1), "")
sFilename = .Path & pgksBackSlash & Left(.Name, InStr(.Name, ksDot) - 1) & _
ksUnderscore & sFilenameClean
End With
With ppNew
.SaveAs sFilename, ppSaveAsOpenXMLShow, msoTrue
.SaveAs sFilename, ppSaveAsShow, msoTrue
.SaveAs sFilename, ppSaveAsPDF, msoTrue
.Close
End With
' end
Set ppNew = Nothing
InitializeControls False, False
Beep
End Sub
Private Sub cmdExit_Click()
With ActivePresentation
.PageSetup.SlideOrientation = msoOrientationHorizontal
.Save
If Application.Presentations.Count = 1 Then
Application.Quit
Else
.Close
End If
End With
End Sub
