Inhalt aus Textbox in Variable legen

Sub BestNr_in_Zwischanablage() If TypeName(Application.Caller) "String" Then Exit Sub With ActiveSheet.Shapes(Application.Caller) Select Case .Type Case 1, 17: BestNr = .DrawingObject.Text Case Else: MsgBox "Ungültiges Textfeld" End Select End With End Sub

Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Florian,
ich weiß jetzt nicht welches Unglück die 64-bit-Version des Betriebssystems hier noch über einem ausschütten kann.
Ich hatte aber auch schon Probleme mit Application.Caller. Und zwar dann, wenn man bei Shapes nicht den automatisch von Excel vergebenen Namen eines Shapes verwendet, sondern diesen individuell anpasst. Dann wird beim Kopieren auch der individuelle Name kopiert und Application.Caller liefert immer den Namen und die Eigenschaften des Orignals.
Das konnte ich nur bereinigen, indem ich die Namen der Shapes ohne doppelte vergeben hab.
Nachfolgend dein Makro inkl. MsgBox, die einige Eigenschaften des Caller-Shapes anzeigt.
Mit dem zweiten Makro werden die Eigenschaften von bestimmten Shapes in einem Tabellenblatt gelistet.
Gruß
Franz

Public Function fncNameBereich(Bereich As Range) As String
'Als Bereich muss die Zelle links-oben im Namenbereichs gewählt werden
'Probleme gibt es allerdings wenn sich Namensbereiche überlagern, d.h. _
die gleiche linke-obere Zelle haben)
Dim objName As Name
Application.Volatile
On Error GoTo Fehler
For Each objName In ThisWorkbook.Names
If Not Intersect(Bereich, objName.RefersToRange.Range("A1")) Is Nothing Then
fncNameBereich = objName.NameLocal
Exit For
End If
Next
Exit Function
Fehler:
End Function
Sub BestNr_in_Zwischanablage()
Dim objData As New MSForms.DataObject
Dim objShape As Shape
BestNr = ""
If TypeName(Application.Caller)  "String" Then Exit Sub
Set objShape = ActiveSheet.Shapes(Application.Caller)
With objShape
Select Case .Type
Case 1, 17: BestNr = .DrawingObject.Text
Case Else: MsgBox "Ungültiges Textfeld"
End Select
End With
MsgBox "Textbox/Rechteck-Name: " & objShape.Name & vbLf _
& "ID: " & objShape.ID & vbLf _
& "Text: " & BestNr
objData.SetText BestNr
objData.PutInClipboard
End Sub
Sub Shapes_Listen_OnAction()
'Liste Shapes mit einem bestimmten zugewiesenen Makro
Dim wks As Worksheet, wksListe As Worksheet, Zeile As Long
Dim strOnAction As String
strOnAction = "BestNr_in_Zwischanablage"
Dim objShape As Shape
Set wks = ActiveSheet
Application.Workbooks.Add Template:=xlWBATWorksheet
Set wksListe = ActiveWorkbook.Worksheets(1)
With wksListe
.Cells(1, 1) = "Datei"
.Cells(1, 2) = wks.Parent.Name
.Cells(2, 1) = "Blatt"
.Cells(2, 2) = "'" & wks.Name
.Cells(2, 5) = "OnAction"
.Cells(2, 6) = "'" & strOnAction
Zeile = 4
.Cells(Zeile, 1) = "ID"
.Cells(Zeile, 2) = "Shape-Name"
.Cells(Zeile, 3) = "TopLeftCell"
.Cells(Zeile, 4) = "Top-Zeile"
.Cells(Zeile, 5) = "Left-Spalte"
.Cells(Zeile, 6) = "Text"
End With
Cells(Zeile + 1, 1).Select
ActiveWindow.FreezePanes = True
For Each objShape In wks.Shapes
With objShape
Select Case .Type
Case 1, 17
If .OnAction  "" Then
If Mid(.OnAction, InStr(1, .OnAction, "!")) = "!" & strOnAction Then
Zeile = Zeile + 1
wksListe.Cells(Zeile, 1) = .ID
wksListe.Cells(Zeile, 2) = .Name
wksListe.Cells(Zeile, 3) = .TopLeftCell.Address(False, False, xlA1)
wksListe.Cells(Zeile, 4) = .TopLeftCell.Row
wksListe.Cells(Zeile, 5) = .TopLeftCell.Column
wksListe.Cells(Zeile, 6) = "'" & .DrawingObject.Text
End If
End If
Case Else
'do nothing
End Select
End With
Next
wksListe.Columns.AutoFit
End Sub

Beliebteste Forumthreads (12 Monate)

Inhalt aus Textbox in Variable legen

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread

304 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Inhalt aus Textbox in Variable legen

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

304 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread