TPE

Tavvafi@gmail.com

≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡

هنگامی که لینکی را به Shapeی در اسلایدی اضافه می کنید، و فایل پرزنتیشن را به PDF تبدیل می کنید، ممکن است لینک ها  در کل درست کار نکنند، کد زیر این مشکل را تا حدود بسیار زیادی حل می کند.

پس از اجرای کد زیر می توانید فایل را به فرمت PDF ذخیره (... Save as) کنید.

Sub FixForAcrobat()


    On Error GoTo ErrorHandler

    Dim oSl As Slide
    Dim oHl As Hyperlink
    Dim sSlideID As String
    Dim sSlideIndex As String
    Dim sSlideTitle As String
    Dim sTemp As String

    For Each oSl In ActivePresentation.Slides
        For Each oHl In oSl.Hyperlinks
            With oHl
                If .Address = "" Then
                    ' it's a link to another slide in this pres
                    ' verify that the slide number and ID of the link target match

                    ' parse out slide number and slideID
                    sSlideID = Mid$(.SubAddress, 1, InStr(.SubAddress, ",") - 1)
                    sTemp = Mid$(.SubAddress, InStr(.SubAddress, sSlideID) + Len(sSlideID) + 1)
                    sSlideIndex = Mid$(sTemp, 1, InStr(sTemp, ",") - 1)
                    sSlideTitle = Mid$(sTemp, InStr(sTemp, ",") + 1)

                    ' If the linked slide isn't present, we get an error so test first:
                    On Error Resume Next
                    If ActivePresentation.Slides.FindBySlideID(CLng(sSlideID)) Is Nothing Then
                        MsgBox "Link to missing slide on slide: " & CStr(oSl.SlideIndex) _
                            & vbCrLf _
                            & "Link points to: " & .SubAddress
                        ' stop processing this hyperlink
                        Exit For
                    End If
                    On Error GoTo ErrorHandler

                    If ActivePresentation.Slides.FindBySlideID(CLng(sSlideID)).SlideIndex <> sSlideIndex Then
                        ' the link will confuse Acrobat so fix it
                        Debug.Print "Originally:" & vbTab & .SubAddress
                            On Error Resume Next
                            sTemp = sSlideID & "," _
                            & ActivePresentation.Slides.FindBySlideID(CLng(sSlideID)).SlideIndex & "," _
                            & sSlideTitle
                         ' If target slide not present, don't reset link
                         If Err.Number = 0 Then
                             .SubAddress = sTemp
                        End If
                        Debug.Print "Now:" & vbTab & sTemp
                    End If

                End If
            End With
        Next
    Next

NormalExit:
    Exit Sub

ErrorHandler:
    MsgBox "Error:" & vbCrLf & Err.Number & vbTab & Err.Description
    Resume NormalExit

End Sub