Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
372to376
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
372to376
372to376
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

AutoShape finden

AutoShape finden
28.01.2004 11:37:44
Timo
Hallo Leute,
ich benötige Eure Hilfe, da ich selbst nicht weiter komme. Hab folgendes Problem:
In einer Excel-Datei mit drei Tabellen befindet sich in irgendeiner von den drei Tabellen eine Schaltfläche(AutoShape) mit der Überschrift ALT. Die muß ich finden und die Überschrift und den Hyperlink ändern. Kann mir da jemand helfen, da ich selbst es nicht hinbekomme. DANKE !

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: AutoShape finden
28.01.2004 14:09:48
q
Hallo,
hier ein Code, der versucht alle autoshapes in allen sheets des ActiveWorkbook durchzugehen und testet, ob der text mit einem ausgewahlten text (in der const AUTOSHAPEUBERSCHRIFFT, kann/soll man andern) ubereinstimmt. Wenn solches autoshape gefunden wird, wird es activiert und der user (du :-0) kann es dann andern. Hoffentlich ist es das was du brauchst und hoffentlich wird es gut funktionieren :-). Gruss q
(Man startet es mit dem public sub "Start")
' ************************************************************************************Code :
Option Explicit
Private Const AUTOSHAPEUBERSCHRIFFT As String = "ALT"
Public Sub Start()
Dim wrbAct As Workbook
Dim wshSome As Worksheet

On Local Error GoTo Start_Err

Set wrbAct = Application.ActiveWorkbook

For Each wshSome In wrbAct.Worksheets
If (AutoShape_Find(wshSome, AUTOSHAPEUBERSCHRIFFT) = True) Then
MsgBox "AutoShape gefunden und aktiviert.", vbInformation, "Auto-Shape suche"
End
End If
Next wshSome

MsgBox "AutoShape nicht gefunden.", vbInformation, "Auto-Shape suche"

Exit Sub

Start_Err:
MsgBox "Error Nr. " & Err.Number, vbCritical, "Error in Sub Start"
End Sub


Private Function AutoShape_Find(ByVal wshToLookIn As Worksheet, _
ByVal strAutoShText As String) As Boolean
Dim shpShape As Shape
Dim shpsAllShapes As Shapes
On Error Resume Next
Err.Clear
AutoShape_Find = False
Set shpsAllShapes = wshToLookIn.Shapes
For Each shpShape In shpsAllShapes
shpShape.Select
' nicht alle AutoShapes haben die Eigenschafft "Text"
' falls ein nAutoShape es nicht hat > Fehler
If (Selection.Characters.Text = strAutoShText) Then
If (Err.Number = 0) Then
AutoShape_Find = True
Exit Function
Else
' Err Object sauber machen, und weiter suchen
Err.Clear
End If
End If
Next shpShape
' nichts gefunden (mit dem gesuchten namen)
[a1].Select
End Function

Anzeige
AW: AutoShape finden
28.01.2004 14:19:19
q
Hallo,
etschuldige, ich habe da etwas "kleines" vergesen :-). Nimm diesen code, den vorigen wegwerfen :-). Gruss q
Option Explicit
Private Const AUTOSHAPEUBERSCHRIFFT As String = "ALT"
Public Sub Start()
Dim wrbAct As Workbook
Dim wshSome As Worksheet

On Local Error GoTo Start_Err

Set wrbAct = Application.ActiveWorkbook

For Each wshSome In wrbAct.Worksheets
If (AutoShape_Find(wshSome, AUTOSHAPEUBERSCHRIFFT) = True) Then
MsgBox "AutoShape gefunden und aktiviert.", vbInformation, "Auto-Shape suche"
End
End If
Next wshSome

MsgBox "AutoShape nicht gefunden.", vbInformation, "Auto-Shape suche"

Exit Sub

Start_Err:
MsgBox "Error Nr. " & Err.Number, vbCritical, "Error in Sub Start"
End Sub


Private Function AutoShape_Find(ByVal wshToLookIn As Worksheet, _
ByVal strAutoShText As String) As Boolean
Dim shpShape As Shape
Dim shpsAllShapes As Shapes
On Error Resume Next
Err.Clear
AutoShape_Find = False
wshSome.Activate
Set shpsAllShapes = wshToLookIn.Shapes
For Each shpShape In shpsAllShapes
shpShape.Select
' nicht alle AutoShapes haben die Eigenschafft "Text"
' falls ein nAutoShape es nicht hat > Fehler
If (Selection.Characters.Text = strAutoShText) Then
If (Err.Number = 0) Then
AutoShape_Find = True
Exit Function
Else
' Err Object sauber machen, und weiter suchen
Err.Clear
End If
End If
Next shpShape
' nichts gefunden (mit dem gesuchten namen)
[a1].Select
End Function

Anzeige
AW: AutoShape finden
29.01.2004 15:40:55
Timo
Hallo,
danke für die Antworten aber ich komme damit nicht klar. Ich wäre dir sehr dankbar wenn du dir mein Code anschauen würdest. Es funktioniert in Prinzip aber ich kann es nicht variabel gestalten d.H. es werden sowohl keine Shapes als auch keine Mappen durchsucht, nur das eine Shape und die aktuelle Arbeitsmappe. Ich danke schon im Voraus für Antwort, Viele Grüße
Timo

Sub Sichern()
Dim AlterName, Neuername
Dim Datei As String
Dim Active As Workbook
On Error GoTo Meldung
Monat = Month(Now)
If Day(Now) - 15 <= 10 Then
Monat = Monat - 1
End If
If Monat - 2 < 1 Then
Archivmonat = Monat - 2 + 12
Archivjahr = Year(Now) - 1
Else
Archivmonat = Monat - 2
Archivjahr = Year(Now)
End If
Archivname = "Stand_" & Archivmonat & "_" & Archivjahr & ".xls"
FileCopy "c:\aktuell.xls", "c:\Aktuell_alt.xls"
AlterName = "c:\Vormonat.xls": Neuername = "c:\" & Archivname
Name AlterName As Neuername
AlterName = "c:\Aktuell_alt.xls": Neuername = "c:\Vormonat.xls"
Name AlterName As Neuername
Datei = "c:\vormonat.xls"
Workbooks.Open Datei
Set Active = Application.ActiveWorkbook
ActiveSheet.Shapes("AutoShape 3").Select
Selection.Characters.Text = "Neu"
Selection.ShapeRange.Item(3).Hyperlink.Address = "Aktuell.xls"
Workbooks("c:\vormonat.xls").Close SaveChanges:=True
Exit Sub
Meldung:
titel1 = "Fehler"
Mel0 = "Sie haben die Datei bereits einmal gesichert."
antwort = MsgBox(Mel0 + Chr(13), vbOKOnly, titel1)
End Sub

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige