AW: externe Verknüpfungen
31.08.2006 21:38:03
Josef
Hallo Reinhard!
Beitrag-Funktion
Zeigt einen Hinweis darauf, dass
ein Forum-Teilnehmer eine Frage hat, eine Antwort geben möchte, eine
allgemeine Bemerkung geben möchte.
Syntax
Beitrag begrüßungsformel, [ Name ], Text, Schlussformel,
Die Syntax der Beitrag-Funktion verwendet die folgenden Argumente:
| Teil | Beschreibung |
| begrüßungsformel | Erforderlich. Ein Zeichenfolgenausdruck, der den landesüblichen Geflogenheiten entspricht.
Eine Auswahl möglicher Werte kann der folgenden Zeile entnommen werden.
"Hallo", "Hi", "Guten Tag"
Auch die Verwendung von umgangssprachlichen Angaben, wie z Bsp "Moin" oder "Tach" ist möglich.
|
| name | Optional. Ein Zeichenfolgenausdruck, der mit Hilfe des Argumentes
begrüßungsformel die gewünschte Zielgruppe einschränkt.
|
| text | Erforderlich. Ein Zeichenfolgenausdruck, der Auskunft über das eigentliche Anliegen des Fragenden gibt.
Der Inhalt ist frei wählbar, sollte jedoch freundlich und qualifiziert gestaltet werden.
|
| schlussformel | Erforderlich. Ein Zeichenfolgenausdruck, der den landesüblichen Geflogenheiten entspricht.
Eine Auswahl möglicher Werte kann der folgenden Zeile entnommen werden.
"Ciao", "Gruß", "viele Grüße", "Tschüss"
Auch hier ist die Verwendung von umgangssprachlichen Angaben, wie z Bsp "und wech..." möglich.
Zusätzlich möglich ist es, dass schlussformel den eigenen Namen und/oder den Wert aus name enthält. |
Vielleicht versteht auch der Ersteller dieses Threads jetzt,
dass ein Beitrag ohne Begrüßungs- und Schlussformel nicht wirklich vollständig ist.
Und nun zu deinem Problem.
Viielleicht hilft dir das.
' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Dim iFound As Integer
'
'Quelle unbekannt Wenn jemand diesen Code erkennt und den Author kennt,
' bitte mitteilen! j.ehrensberger@aon.at
'
'Source unknown If someone recognizes this code and knows the Author,
' please tell me! j.ehrensberger@aon.at
'
Private Function CheckDelete(Where As String, What As String)
Dim iResp As Integer
iFound = iFound + 1
iResp = MsgBox("Found a link in " & Where & ":" & Chr(10) & What & Chr(10) & "Shall I delete it?", vbYesNoCancel, "Link Finder")
Select Case iResp
Case vbCancel
Application.StatusBar = False
End
Case vbYes
CheckDelete = True
Case vbNo
CheckDelete = False
End Select
End Function
Sub FindLinks()
Dim obj As Object, oSheet As Object, oSeries As Object
Dim iOLEfound As Integer, stMsg As String
Dim rCell As Range, rFirst As Range, rToDo As Range
Dim rDone As Range, rAll As Range, rArea As Range
Static LinkString As String
iFound = 0
If IsEmpty(ActiveWorkbook.LinkSources()) Then
MsgBox "There are no links from this workbook"
Exit Sub
End If
LinkString = InputBox("Name of file to which links refer?" & _
Chr(10) & "Do not include path if file is open", Default:=LinkString, _
Title:="Link Finder")
If LinkString = "" Then Exit Sub
Application.StatusBar = "Looking for links in workbook names"
' first look for names
For Each obj In ActiveWorkbook.Names
If InStr(obj.RefersTo, LinkString) > 0 Then
stMsg = ""
If obj.Visible = False Then stMsg = stMsg & "hidden "
If CheckDelete(stMsg & "name " & obj.Name, obj.RefersTo) Then obj.Delete
End If
Next obj
' now scan each sheet in turn
For Each oSheet In ActiveWorkbook.Sheets
Application.StatusBar = "Looking for links in sheet " & oSheet.Name
iOLEfound = 0
If TypeName(oSheet) <> "Module" Then
For Each obj In oSheet.DrawingObjects
' any drawing object could be linked to a macro
If InStr(obj.OnAction, LinkString) > 0 Then
If CheckDelete("OnAction of " & TypeName(obj) & " '" & obj.Name & "' in " & oSheet.Name, obj.OnAction) Then obj.OnAction = ""
End If
' some drawing objects have formula properties
Select Case TypeName(obj)
Case "TextBox", "Picture", "Button"
If InStr(obj.Formula, LinkString) > 0 Then
If CheckDelete("formula of " & TypeName(obj) & " '" & obj.Name & "' in " & oSheet.Name, obj.Formula) Then obj.Formula = ""
End If
Case "OLEObject"
' can't get to the formula of an OLEObject - so report at end
iOLEfound = iOLEfound + 1
Case "ChartObject"
For Each oSeries In obj.Chart.SeriesCollection
If InStr(oSeries.Formula, LinkString) > 0 Then
If CheckDelete("series " & oSeries.Name & " in Chart " & obj.Name & " on sheet " & oSheet.Name, oSeries.Formula) Then oSeries.Formula = ""
End If
Next oSeries
End Select
Next
If TypeName(oSheet) = "Worksheet" Then
' look in cell formulae
Application.ScreenUpdating = False ' otherwise screen flashes
Set rCell = Nothing
On Error Resume Next
Set rCell = oSheet.UsedRange.Find(LinkString, oSheet.UsedRange.Range("A1"), xlFormulas, xlPart, xlByRows, xlNext)
On Error GoTo 0
If Not rCell Is Nothing Then
Set rFirst = rCell
Set rAll = rCell
Do
Set rCell = oSheet.UsedRange.FindNext(rCell)
Set rAll = Union(rAll, rCell)
Loop Until rCell.Address = rFirst.Address
Application.ScreenUpdating = True
For Each rArea In rAll.Areas
Set rDone = rArea.Cells(1, 1)
Set rToDo = rArea.Cells(1, 1)
Do
For Each rCell In rArea.Cells
If Intersect(rDone, rCell) Is Nothing Then
If rToDo Is Nothing Then
Set rToDo = rCell
ElseIf rCell.FormulaR1C1 = rToDo.Cells(1, 1).FormulaR1C1 Then
Set rToDo = Union(rToDo, rCell)
End If
End If
Next rCell
stMsg = "cell "
If rToDo.Cells.Count > 1 Then stMsg = "cells "
If CheckDelete(stMsg & oSheet.Name & "!" & rToDo.Address, rToDo.Range("A1").Formula) Then
rToDo.Formula = rToDo.Value
End If
Set rDone = Union(rDone, rToDo)
Set rToDo = Nothing
Loop Until rDone.Address = rArea.Address
Next rArea
End If
ElseIf TypeName(oSheet) = "Chart" Then
' look in chart series
For Each oSeries In oSheet.SeriesCollection
If InStr(oSeries.Formula, LinkString) > 0 Then
If CheckDelete("series " & oSeries.Name & " in Chart " & _
obj.Name, oSeries.Formula) Then oSeries.Formula = ""
End If
Next oSeries
ElseIf TypeName(oSheet) = "DialogSheet" Then
' look in on action of dialog frame
If InStr(oSheet.DialogFrame.OnAction, LinkString) > 0 Then
If CheckDelete("dialog frame of " & oSheet.Name, oSheet.DialogFrame.OnAction) Then oSheet.DialogFrame.OnAction = ""
End If
End If
End If
If iOLEfound = 1 Then
MsgBox "There is an OLE Object on sheet " & oSheet.Name & " which I could not check"
oSheet.OLEObjects.Select
ElseIf iOLEfound > 1 Then
MsgBox "There are " & iOLEfound & " OLE Objects on sheet " & oSheet.Name & " which I could not check"
oSheet.OLEObjects.Select
End If
Next oSheet
If iFound = 0 Then MsgBox "No links found to " & LinkString, vbInformation, "Link Finder"
Application.StatusBar = False
End Sub
Gruß Sepp