Liebe Kollegen
Ich habe in Excel2000 eine grössere Tabelle angelegt und einelne Felder mit anderen Dokumenten verlinkt. Führt der Link z.B. zu einem PDF-Dokument, bleibt die Excel-Tabelle am Bildschirm stehen. Führt der Link aber zu einem Word-Dokument, wird die Excel-Tabelle beim Aufruf desselben heruntergeklappt. Ich möchte, dass die Excel-Tabelle immer am Bildschirm stehen bleibt. Wie und wo kann ich das einstellen?
Besten Dank für Tipps!
Felix Kirchhofer
Ich habe in Excel2000 eine grössere Tabelle angelegt und
einelne Felder mit anderen Dokumenten verlinkt. Führt der Link
z.B. zu einem PDF-Dokument, bleibt die Excel-Tabelle am
Bildschirm stehen. Führt der Link aber zu einem Word-Dokument,
wird die Excel-Tabelle beim Aufruf desselben heruntergeklappt.
Ich möchte, dass die Excel-Tabelle immer am Bildschirm stehen
bleibt. Wie und wo kann ich das einstellen?
Grüezi Felix,
ich hab da was gebastelt, steht im Anhang, lief auf Xl97 und Xl2000.
Problem ist noch, in Word fehlen die Symbolleisten, k.A. warum.
Und trotz Screenupdating =false sieht man noch Bildschirmaufbauten.
Hauptproblematik deiner Anfrage ist, daß man zwar das Ereignis Followhyperlink, also den Aufruf des Hyperlinks automatisch auswerten kann, aber man kann ihn nicht mit Cancel=true stoppen und je nach Hyperlink der aufrufenden Zelle, pdf , doc oder sonstwas unterschiedlich was tun kann.
Deshalb meine Variante, rufe einmalig die Sub Einmalig() auf, sie löscht alle Hyperlinks zu docs und pdfs, anstelle dessen wird ein durchsichtiges Rechteck über die Zellen gelegt, wenn man nun auf eine dieser Zellen klickt startet ien makro was je nachdem winword oder acrord32 aufruft.
Gruß
Reinhard
Option Explicit
#If VBA6 = 0 Then
Const XL97 As Boolean = True 'XL97
#Else
Const XL97 As Boolean = False 'XL2000
#End If
'
Sub Einmalig()
Dim H, Ziel, T, A
Call VerweisSetzen ' setzt Verweis auf mswordX.olb
For Each H In ActiveSheet.Hyperlinks
If UCase(Right(H.Address, 4)) = ".DOC" Or UCase(Right(H.Address, 4)) = ".PDF" Then
Ziel = H.Address
T = IIf(XL97 = True, H.Address, H.TextToDisplay)
A = H.Range.Address(0, 0)
H.Delete
With Range(A)
.Value = T
.Font.ColorIndex = 5
.Font.Underline = xlUnderlineStyleSingle
ActiveSheet.Shapes.AddShape(msoShapeRectangle, .Left, .Top, .Width, .Height).Select
ActiveWorkbook.Names.Add Name:="Zelle" & A, RefersToR1C1:="=" & Chr(34) & Ziel & Chr(34)
End With
With Selection
.Name = "Zelle" & A
.ShapeRange.Fill.Transparency = 1
.ShapeRange.Line.Visible = msoFalse
.OnAction = "Hyper"
End With
End If
Next H
Range("A1").Select
End Sub
'
Sub Hyper()
Dim AppW As New Word.Application, AppA, PfadDatei As String
Application.ScreenUpdating = False
PfadDatei = ThisWorkbook.Names(Application.Caller).RefersTo
Select Case UCase(Left(Right(PfadDatei, 4), 3))
Case "DOC"
On Error Resume Next
Set AppW = GetObject(, "Word.Application")
If Err.Number 0 Then Set AppW = CreateObject("Word.Application")
On Error GoTo 0
AppW.ScreenUpdating = False
Range(Mid(Application.Caller, 6)).Font.ColorIndex = 3
AppW.Documents.Open Filename:=Mid(PfadDatei, 2)
'AppW.Documents.Open FileName:="f:\ootest.doc", ConfirmConversions:=False, \_
' ReadOnly:=False, AddToRecentFiles:=False, PasswordDocument:="", \_
' PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", \_
' WritePasswordTemplate:="", Format:=wdOpenFormatAuto
AppW.WindowState = wdWindowStateMaximize
AppW.WindowState = wdWindowStateMinimize
AppW.Visible = True
AppW.ScreenUpdating = True
Application.Visible = True
Case "PDF"
Range(Mid(Application.Caller, 6)).Font.ColorIndex = 3
AppA = Shell("c:\programme\adobe\acrobat 7.0\reader\acrord32.exe " & Mid(PfadDatei, 2))
DoEvents
Application.Visible = True
Case Else
MsgBox "kann nicht sein"
End Select
Application.ScreenUpdating = True
End Sub
'
Sub VerweisSetzen()
Dim intIndex As Integer, blnFound As Boolean, Dateipfad As String
Dateipfad = Application.Path & "\MSWORD" & Left(Application.Version, \_
InStr(Application.Version, ".") - 1) & ".OLB"
On Error GoTo err\_exit
With ThisWorkbook.VBProject.References
For intIndex = 1 To .Count
If .Item(intIndex).Name = "Word" Then .Remove .Item(intIndex)
Next
.AddFromFile Dateipfad
End With
Exit Sub
err\_exit:
MsgBox "Fehler " & CStr(Err.Number) & vbLf & vbLf & Err.Description, vbCritical, "Fehler"
End Sub