AW: Application.StatusBar (nochmal)
15.01.2004 17:21:04
Birne
Hallo,
ist nict im StatusBar, aber ist lustig denke ich :-)
Option Explicit
Sub BewText()
Dim Shps As Shapes
Dim WArtTxt As Shape
Dim inc As Integer
On Local Error GoTo BewText_Err
Set Shps = ActiveSheet.Shapes
' add neuen text
' methode AddTextEffect blder einen WordArtText und
' returnes einen shape object :
Set WArtTxt = Shps.AddTextEffect(PresetTextEffect:=msoTextEffect22, _
text:="Hallo Miriam :-)", _
FontName:="Arial", _
FontSize:=15, _
FontBold:=msoFalse, _
FontItalic:=msoFalse, _
Left:=Cells(1, 1).Left, _
Top:=Cells(1, 1).Top)
For inc = 1 To 600
WArtTxt.Left = inc
WArtTxt.Top = inc
WArtTxt.Rotation = inc
If (inc Mod 5 = 0) Then
If (WArtTxt.Visible = msoFalse) Then
WArtTxt.Visible = msoTrue
Else
WArtTxt.Visible = msoFalse
End If
End If
DoEvents
Next inc
' text wieder loeschen
WArtTxt.Delete
Exit Sub
BewText_Err:
MsgBox "Error " & Err.Number, vbCritical, "Error"
End Sub