PowerPoint Hyperlinks?

[panrad]

Hallo Leute,
ich habe da ein Problem mit VBA-PowerPoint. Wie kann ich die Folien dynamisch verlinken (Hyperlinks)? Die Folien werden mit der Hilfe einer Texttabelle erstellt (mit mehreren hundert Zeilen und mit beliebiger Ebenentiefe). Auf jede Folie kommt jeweils ein "Vater" und darunter die dazugehörigen "Kinder" (es handelt sich um verschiedene Personen, die zu einer bestimmten Hierarchiestufe gehören) wie z.B.

01
02 02

02
03 03 03

02
03 03

Wie kann ich die Folien dynamisch verlinken, so dass beim Klicken auf dem ersten "02" Shape ich direkt auf die zweite (dazugehörige) Folie springe usw. Ich habe es herausgefunden, dass man nur schon existierende Folien verlinken kann...und dazu ein kleiner Ausschnitt.. :=)

Option Explicit
Option Base 1

Const satzlaenge As Integer = 942
Const Adresse As String _
    = "C:\WINNT\Profiles\imrpa\Desktop\2004\Powerpoint_Org\Orgplan.txt"
Const Template As String _
    = "C:\WINNT\Profiles\imrpa\Desktop\2004\Powerpoint_Org\template.pot"

Type OrgDatensatz
    O_Tiefe     As String * 2
    S_Tiefe     As String * 2
    Deckblatt   As String * 1
    Struktur    As String * 10
    Struktur_2  As String * 20
    Otype       As String * 2
    Objid       As String * 8
    SText       As String * 40
    SShort      As String * 12
    Einsatz     As String * 1
    Pernr       As String * 8
    Nachname    As String * 40
    Vorname     As String * 40
    Vorsw       As String * 15
    Namzu       As String * 15
    Gesname     As String * 50
    Gesname2    As String * 50
    Persg       As String * 1
    Persk       As String * 2
    Status      As String * 1
    Gebaeude    As String * 6
    Raum        As String * 6
    Telefon     As String * 30
    Vakanz      As String * 8
    Prio        As String * 2
    FE          As String * 3
    Telefon2    As String * 30
    Gebdatum    As String * 8
    Alter       As String * 5
    Vertragsst  As String * 8
    Vollmacht   As String * 40
    Kst         As String * 10
    Werks       As String * 4
    Werks_T     As String * 30
    Status1     As String * 1
    Userid      As String * 30
    O_Relat     As String * 3
    Chief_Typ   As String * 1
    Chief_Nr    As String * 8
    Fachtext    As String * 40
    Fachrelat   As String * 8
    Line_Code   As String * 10
    Gesell      As String * 3
    Fax         As String * 30
    Taetig      As String * 40
    Kuerzel     As String * 40
    email       As String * 96
    jobdetail   As String * 25
    bukrs       As String * 4
    butxt       As String * 25
    land1       As String * 3
    landx       As String * 15
    o_bukrs     As String * 4
    o_butxt     As String * 25
    o_land1     As String * 3
    o_landx     As String * 15
    Finish      As String * 1
End Type


Dim OrgDSatz As OrgDatensatz

Dim i As Integer
Dim x As Integer
Dim y As Integer
Dim z As Integer
Dim s As Integer
Dim Counter_2 As Integer
Dim prev_otype As String * 2
Dim prev_objid As String * 8
Dim MAX_Tiefe As String * 2
Dim MAX_Shapes As Integer
Dim PPP As Presentation
Dim breite_abstand As Integer
Dim erste_reihe As Integer
Dim zweite_reihe As Integer
Dim Check As Integer
Dim abstand_zeile1 As Integer
Dim abstand_zeile2 As Integer
Dim Breite_Allgemein As Integer
Dim Font_Size_Allgemein As Integer
Dim ausn_gesname As String * 50
Dim Arr_Tiefe As Variant
Dim arr As Integer
Dim Checking As Integer
Dim aktuell_otype As String * 2
Dim aktuell_objid As String * 8
Dim Level_1 As Integer
Dim Level_2 As Integer

********************************************************
Sub Start()

    Arr_Tiefe = Array("01", "02", "03", "04", "05", "06", "07", "08", "09", "10", "11", "12", "13", "14", "15", "16", _
                  "17", "18", "19", "20", "21", "22", "23", "24", "25", "26", "27", "28", "29", "30", "31", "32", _
                  "33", "34", "35", "36", "37", "38", "39", "40", "41", "42", "43", "44", "45", "46", "47", "48", _
                  "49", "50")

Call Maximale_Tiefe
Call Maximale_Anzahl_Shapes
Call Format_Shapes_Allgemein

Call Folien_Erstellen

'AddIns.Remove "OrgChart.ppa"

End Sub
'***********************************************************************************
' Anzeige von Hierarchiestufen
'***********************************************************************************
Sub Folien_Erstellen()

Set PPP = Presentations.Add(msoTrue)
PPP.ApplyTemplate (Template)

prev_otype = ""
prev_objid = ""
Level_1 = 0
Level_2 = 0
x = 0
y = 0
i = 0
Check = 0
arr = 0

Do
arr = arr + 1
    Open Adresse For Random As #1 Len = satzlaenge
        Do While Not EOF(1)
            i = i + 1
            Get #1, i, OrgDSatz
                aktuell_otype = OrgDSatz.Otype
                aktuell_objid = OrgDSatz.Objid
            If i = 1 Then
                prev_otype = OrgDSatz.Otype
            End If

        If ((OrgDSatz.Otype = "O ") Or _
            OrgDSatz.Otype = "0O" Or OrgDSatz.Otype = "11" Or OrgDSatz.Otype = "12") And _
            ((prev_otype = OrgDSatz.Otype And prev_objid <> OrgDSatz.Objid) Or _
            (prev_otype <> OrgDSatz.Otype And prev_objid <> OrgDSatz.Objid) Or _
            (prev_otype <> OrgDSatz.Otype And prev_objid = OrgDSatz.Objid)) Then
            
            Select Case OrgDSatz.O_Tiefe
            Case Is = Arr_Tiefe(arr)
                    Checking = 0
                    Level_1 = 0
                    Level_2 = 0
                    x = 0
                    y = 0
                    Check = 0
            Case Is = Arr_Tiefe(arr + 1)
                    If Checking = 0 Then
                    i = i - 1
                        Call Shapes_Anzahl_Folie
                        Call Format_Shapes_Folie
                        
                        Get #1, i, OrgDSatz
                            aktuell_otype = OrgDSatz.Otype
                            aktuell_objid = OrgDSatz.Objid
                                If i > 1 Then
                                Call Ausnahme_Besetzung
                                End If
                        Get #1, i, OrgDSatz
                                                   
                            With PPP.Slides
                                   .Add .Count + 1, ppLayoutBlank
                            End With
                        z = PPP.Slides.Count
                            Call Text_Format_HauptShape
                            Level_1 = 1
                            Checking = Checking + 1
                            ausn_gesname = ""
                            '*****************************************
                            'HYPERLINK IF i > 1

                    Else
                            Call Ausnahme_Besetzung
                            Get #1, i, OrgDSatz
                            Call Text_Format_UnterShapes
                            
                            'arr = arr + 1
                            'Call Shapes_Anzahl_Folie
                            'If Counter_2 > 0 Then
                            'Dim zz As Integer
                            'zz = z + 1
                            '    With PPP.Slides(z).Shapes(s).ActionSettings(ppMouseClick)
                            '        .Action = ppActionHyperlink
                            '        With .Hyperlink
                            '        .Address = ""
                            '        .SubAddress = "Slides(zz)"
                            '        End With
                            '    End With
                            'End If
                            'arr = arr - 1
                            
                            ausn_gesname = ""
                    End If
            End Select
        End If
        prev_otype = OrgDSatz.Otype
        prev_objid = OrgDSatz.Objid
        Loop

    Close #1

i = 0
Checking = 0
Level_1 = 0
Level_2 = 0
x = 0
y = 0
Check = 0
Loop Until Arr_Tiefe(arr + 1) = MAX_Tiefe

End Sub
********************************************************************************
'*****************************************************************************************
Sub Shapes_Anzahl_Folie()

Dim i_sh As Integer
Dim a As Integer
Dim chk As Integer
Dim p_ot As String * 2
Dim p_ob As String * 8
p_ot = prev_otype
p_ob = prev_objid

i_sh = i
a = arr
chk = 1
Counter_2 = 0

Open Adresse For Random As #4 Len = satzlaenge
Do While Not EOF(4)
i_sh = i_sh + 1

Get #4, i_sh, OrgDSatz

    
    If ((OrgDSatz.Otype = "O ") Or _
          OrgDSatz.Otype = "0O" Or OrgDSatz.Otype = "11" Or OrgDSatz.Otype = "12") And _
          ((p_ot = OrgDSatz.Otype And p_ob <> OrgDSatz.Objid) Or _
          (p_ot <> OrgDSatz.Otype And p_ob <> OrgDSatz.Objid) Or _
          (p_ot <> OrgDSatz.Otype And p_ob = OrgDSatz.Objid)) Then

    Select Case OrgDSatz.O_Tiefe     
        Case Is = Arr_Tiefe(a)          
            chk = 0          
        Case Is = Arr_Tiefe(a + 1)      
            If chk = 1 Then
            Counter_2 = Counter_2 + 1
            End If
    End Select
   End If
    p_ot = OrgDSatz.Otype
    p_ob = OrgDSatz.Objid

Loop
Close #4
End Sub

***********************************************************************
Sub Text_Format_HauptShape()
If z = 1 Then

    With PPP.Slides(z).Shapes.AddShape _
        (msoShapeRectangle, 50, 60, 650, 50)
        .Fill.ForeColor.RGB = RGB(0, 74, 139)
        .TextFrame.WordWrap = msoTrue
        .TextFrame.TextRange.Text = OrgDSatz.SText _
        + Chr$(CharCode:=13) + OrgDSatz.Gesname _
        + Chr$(CharCode:=13) + OrgDSatz.Telefon _
        + Chr$(CharCode:=13) + ausn_gesname
        With .TextFrame.TextRange.Font
            .Size = 12
            .name = "Arial"
            .Bold = True
            .Color.RGB = RGB(255, 255, 255)
        End With
        .Line.DashStyle = msoLineSolid
    End With
s = PPP.Slides(z).Shapes.Count

Else

    With PPP.Slides(z).Shapes.AddShape _
        (msoShapeRectangle, 50, 60, 500, 50)
        .Fill.ForeColor.RGB = RGB(0, 70, 130)
        .TextFrame.WordWrap = msoTrue
        .TextFrame.TextRange.Text = OrgDSatz.SText _
        + Chr$(CharCode:=13) + OrgDSatz.Gesname _
        + Chr$(CharCode:=13) + OrgDSatz.Telefon + _
        Chr$(CharCode:=13) + ausn_gesname
        With .TextFrame.TextRange.Font
            .Size = 12
            .name = "Arial"
            .Bold = True
            .Color.RGB = RGB(255, 255, 255)
        End With
        .Line.DashStyle = msoLineSolid
        .IncrementLeft 75#
    End With
s = PPP.Slides(z).Shapes.Count

End If

End Sub

**************************************************************************************
Sub Text_Format_UnterShapes()

                        If Check = erste_reihe Then
                            y = 150
                            x = 0
                            breite_abstand = abstand_zeile2
                        End If
        
                        With PPP.Slides(z).Shapes.AddShape _
                            (msoShapeRectangle, 50 + x, 160 + y, Breite_Allgemein, 80)
                            .Fill.ForeColor.RGB = RGB(4, 138, 251)
                            .Line.DashStyle = msoLineSolid
                        With .TextFrame
                        With .TextRange
                            .Text = OrgDSatz.SText + _
                            Chr$(CharCode:=13) + OrgDSatz.Gesname + _
                            Chr$(CharCode:=13) + OrgDSatz.Telefon + _
                            Chr$(CharCode:=13) + ausn_gesname
                            .Font.Size = Font_Size_Allgemein
                            .Font.name = "Arial"
                            .Font.Bold = False
                            .Font.Color.RGB = RGB(255, 255, 255)
                            
                        End With
                            .WordWrap = msoTrue
                            .HorizontalAnchor = msoAnchorNone
                            .VerticalAnchor = msoAnchorTop
                            .MarginLeft = 1#
                            .MarginRight = 1#
                            .MarginTop = 0.85
                            .MarginBottom = 0.85
                        End With
                        End With
        
                        x = x + Breite_Allgemein + breite_abstand
                        Level_2 = Level_2 + 1
                        
                        With PPP.Slides(z).Shapes.AddConnector _
                            (msoConnectorElbow, 0, 0, 100, 100).ConnectorFormat
                            .BeginConnect ConnectedShape:=PPP.Slides(z) _
                            .Shapes.Item(1), ConnectionSite:=3
                            .EndConnect ConnectedShape:=PPP.Slides(z) _
                            .Shapes.Item(1 + Level_2), ConnectionSite:=1
                        End With
                    
                            Level_2 = Level_2 + 1
            
                        If Check >= erste_reihe Then
                            On Error Resume Next
                            PPP.Slides(z).Shapes(Level_2 + 1) _
                            .Adjustments.Item(1) = 0.8076
                        End If
                        Check = Check + 1
                        
                        s = PPP.Slides(z).Shapes.Count

End Sub:-) :-) :-) :)

 

[thekorn]

.tag -Eigenschaft

Guten abend,
Also zunächsteinmal liegt es mir fern dich zu kritisieren, aber aufgrund des etwas wirren und oft leider auch umständlichen Programmierstiels viel es mir schwer durch den Code durchzusteigen, denke aber, dass ich dein Problem verstanden habe.
Dir hilft auf jeden Fall die Tag-Eigenschaft einer Folie (am besten mal in der Visual-Basic-Hilfe nachschlagen). du kannst hier jeder Folie also zum Beispiel ein Tag "Ebene" zuweisen und anschließend diesem Tag die "Ebenentiefe" zuweisen:

PPP.Slides(z).Tags.Add "Ebene", Arr_Tiefe(arr) 'bei Folie_erstellen einfügen

Anschließend muss natürlich jedem "Shape" ein "Click"-Ereignis hinzugefügt werden, zum Beispiel so:

With ActivePresentation.Slides(z).Shapes(1) _
        .ActionSettings(ppMouseClick)
    .Action = ppActionRunMacro
    .Run = "NaechsteFolie" 'dieses Makro spring auf die nächste Folie
    .AnimateAction = True
End With

Das Makro "Naechste Folie beinhaltet dann eine for...each-Schleife, die den Tag jeder Folie auf die entsprechende Ebene checkt.

For Each s In Application.ActivePresentation.Slides
    With s.Tags
        For i = 1 To .Count
          If (.Name(i) = "Ebene" and .value(i)= Arr_Tiefe(arr+1)) Then
             s.hyperlinks.subaddress(i)
          End If
        Next
    End With
Next

Ich denke so ungefähr müsste es funktionieren.
hoffe es hilft weiter

gruß
thekorn

 

[panrad]

Danke

Einen wunderschönen guten Morgen,
bedanke mich sehr für die eingehende Hilfe Tut mir leid für den Code, aber ich wusste nicht, wie ich ihn richtig einfügen soll Ausserdem sollte ich (wegen der 15000 Zeichen Begrenzung) einige Teile wegschneiden. Vielleicht liegt es aber auch daran, dass ich mit VBA erst seit einem Monat angefangen habe...und sich alles noch in der Entwurfsphase befindet...Ich habe mir am Wochenende auch Gedanken drüber gemacht, wie das zu lösen wäre...Die Name-Eigenschaft gibt mir auch die Möglichkeit jedes Objekt direkt anzusprechen, werde erst mit der ausprobieren (weil sie einfacher ist, glaube ich), aber wenn das nicht klappt, werde ich die Tag-Eigenschaft benutzen
Vielen Dank