AW: Object in Cells
bauer
Hi, bist Du noch da :-) ?
*************************
Option Explicit
Sub main()
On Error GoTo errh
Dim ole As OLEObject
Set ole = AktiveXInActiveCell(ActiveCell)
If (Not ole Is Nothing) Then
ole.Activate
MsgBox "In der aktieven Zelle befindet sich Objekt " & ole.Name, vbInformation, "Objekt gefunden"
Else
MsgBox "In der aktieven Zelle befindet sich kein Objekt", vbInformation, "Kein Objekt"
End If
Exit Sub
errh:
MsgBox Err.Description & vbCrLf & "Source : " & Err.Source, vbCritical, "error"
End Sub
Private Function AktiveXInActiveCell(ByVal zelle As Range) As OLEObject
' testet ob in der aktieven Zelle ein ActiveX Objekt befindet
' falls ja, dann gibt die funktion den ole objekt zuruck, sonnst nothing
' nur eine zelle darf rein
If ((zelle.Rows.Count > 1) Or (zelle.Columns.Count > 1)) Then Err.Raise Number:=vbObjectError + 513, _
Source:="Function AktiveXInActiveCell", _
Description:="Parameter invalid."
Dim tabelle As Worksheet
Dim ole_objects As OLEObjects
Dim ole_object As OLEObject
Set AktiveXInActiveCell = Nothing
Set tabelle = ActiveSheet
Set ole_objects = tabelle.OLEObjects
' positionen vergleichen, testen ob sich der rechte obere eck des ole ob. in dem bereich
' der zelle befindet.
' man kann die bedingung noch veschaerfen und testen, ob der ganze ole ob. in die zelle passt ...
For Each ole_object In ole_objects
If ((ole_object.Top >= zelle.Top) And _
(ole_object.Left >= zelle.Left) And _
(ole_object.Top <= zelle.Top + zelle.Height) And _
(ole_object.Left <= zelle.Left + zelle.Width)) Then
Set AktiveXInActiveCell = ole_object
Exit Function
End If
Next ole_object
End Function