Corel Draw X6 Verknüpfungen

Code:

Sub Feld5cdr2Cmx()

    Dim Verkn() As String, Dateipfad As String, Dateiname As String

    Dim CMXDateiname As String, CDRDateiname As String

    Dim doc1 As Document

    Dim SaveOptions As StructSaveAsOptions

    Set SaveOptions = CreateStructSaveAsOptions

    With SaveOptions

        .Filter = cdrCDR

        .IncludeCMXData = False

    End With

    Dim expopt As StructExportOptions

    Set expopt = CreateStructExportOptions

    expopt.UseColorProfile = False

    Dim expflt As ExportFilter

    Dateipfad = ActiveDocument.FilePath

    Dateiname = ActiveDocument.FileName

    Debug.Print Dateipfad

    CMXDateiname = Dateipfad & Left(Dateiname, Len(Dateiname) - 4) & "_temp.cmx"

    CDRDateiname = Dateipfad & Left(Dateiname, Len(Dateiname) - 4) & "_temp.cdr"

    

    For i = 1 To ActiveLayer.Shapes.Count

        ReDim Preserve Verkn(i)

        Verkn(i) = ""

        Debug.Print i

        If ActiveLayer.Shapes(i).URL.Address <> "" Then

            Verkn(i) = ActiveLayer.Shapes(i).URL.Address

        End If

    Next i

    Set expflt = ActiveDocument.ExportEx(CMXDateiname, cdrCMX6, cdrCurrentPage, expopt)

    expflt.Finish

    ActiveDocument.Close

    Set doc1 = OpenDocument(CMXDateiname)

    doc1.SaveAs CDRDateiname, SaveOptions

    For i = 1 To UBound(Verkn)

        If Verkn(i) <> "" Then

            ActivePage.Shapes(i).URL.Address = Verkn(i)

        End If

    Next i

    doc1.Save

End Sub

Code:

Sub hyperlinkEbene()

    Dim s As Shape, hl As Layer, al As Layer, r As Rectangle

    Set al = ActiveLayer

    Set hl = ActivePage.CreateLayer("Hyperlinks")

    Dim x As Double, y As Double, w As Double, h As Double

    For Each s In al.Shapes

        If s.URL.Address <> "" Then

            s.GetBoundingBox x, y, w, h

            hl.CreateRectangle2 x, y, s.SizeWidth, s.SizeHeight

            ActiveShape.URL.Address = s.URL.Address

        End If

    Next

    hl.Shapes.All.SetOutlineProperties Color:=CreateCMYKColor(0, 0, 0, 100)

    hl.Shapes.All.SetOutlineProperties 0.003

    hl.Shapes.All.ApplyNoFill

End Sub