Dim file(50) As String
Sub start()
Form1.Show
End Sub
Sub 合併投影片(file, fn)
Dim path As String
Dim inputFileName As String
Dim outputFileName As String
Dim slideNum As Integer
Dim x As Design '宣告 x 為 Design 物件.
Dim add, newadd As String
Dim hylk As Long
Dim page(50), pagetotal As Long
outputFileName = "allinone.pptx"
Set pptApp = New PowerPoint.Application
pptApp.Visible = msoTrue
Set pptOutput = pptApp.Presentations.Open("d:\" & outputFileName)
If pptOutput.Slides.Count = 0 Then
Set newSlide = pptOutput.Slides.add(1, ppLayoutBlank)
End If
For k = 1 To fn
Set pptInput = pptApp.Presentations.Open(file(k))
page(k) = pptInput.Slides.Count
pagetotal = pagetotal + page(k)
For j = 1 To pptInput.Slides.Count 'j為input檔案(k)的投影片數
If k = 1 Then '如為第1個input檔案,不需改變超連結位置,直接複製投影片及來源格式(含母片)即可
pptInput.Slides(j).Copy
Set x = pptInput.Slides(j).Design '將該投影片格式設定用x物件保存.
pptOutput.Slides.Paste(pptOutput.Slides.Count).Design = x
Else
pptInput.Slides(j).Copy
Set x = pptInput.Slides(j).Design '將該投影片格式設定用x物件保存.
pptOutput.Slides.Paste(pptOutput.Slides.Count).Design = x
M = pptOutput.Slides.Count
With pptOutput.Slides(M - 1)
For Each oHl In pptOutput.Slides(M - 1).Hyperlinks
With oHl
sSubaddress = .SubAddress
mystr = Replace(sSubaddress, ",", ".")
Value = Val(mystr)
ID1 = Int(Value) '取得subaddress中第1碼
strID2 = Replace(sSubaddress, ID1 & ",", "")
ID2 = Val(strID2) '取得subaddress中第2碼, 頁數
newID = ID2 + pagetotal - page(k)
newadd = Str(ID1) & "," & Str(newID) & ","
.SubAddress = newadd '修正超連結之頁碼
End With
Next
End With
End If
Next j
Next k
End Sub