- 帖子
- 3
- 主題
- 1
- 精華
- 0
- 積分
- 20
- 點名
- 0
- 作業系統
- win7
- 軟體版本
- office2010
- 閱讀權限
- 10
- 性別
- 男
- 來自
- Taiwan
- 註冊時間
- 2014-7-12
- 最後登錄
- 2017-1-11
|
2#
發表於 2014-7-17 08:13
| 只看該作者
好吧，我就先自問自答，PO一段目前的解結方式
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
不過有個問題還沒解決，就是如果都用超連結是OK，但是如果有的是用動作按鈕設定的方式，合併後仍無法正確連結，我想問題應是SUBADDRESS的編碼我還不是那麼清楚，尤其是第1碼 |
|
