Verbesserung des Makros
14.10.2003 14:14:32
Reinhard
Hi,
folgendes Makro erzeugt in der gerade aktiven Zelle den Text "Datei liegt hier" wobei "hier" als Hyperlink anklickbar ist.
Anpassungen sind leicht im Sternchenbereich zu tätigen
Gruß
Reinhard
Sub EinzelwortHyperlink()
'Reinhard 2003
Dim ZellenText As String
Dim RechteckText As String
Dim ZellenBreite As Long
Dim RechteckBreite As Long
Dim Linksoffset As Long
Dim Farbe As Long
Dim Unterstrich As Long
Dim Adresse As String
ZellenText = "Datei liegt"
RechteckText = "hier."
ZellenBreite = 20 'zeichen
RechteckBreite = 25 'Pixel
Linksoffset = 48 'Versatz nach rechts des Rechtecks innerhalb der Zelle
' ausprobieren wie es mit Zellentext harmoniert
Farbe = 41 'Blau
' es gäbe noch xlUnderlineStyleNone, xlUnderlineStyleSingle, xlUnderlineStyleDouble, _
' xlUnderlineStyleSingleAccounting oder xlUnderlineStyleDoubleAccounting
Unterstrich = xlUnderlineStyleSingle 'einfacher Unterstrich
Adresse = "https://www.google.de/" 'Adresse des Hyperlinks
Höhe = ActiveCell.RowHeight
Links = ActiveCell.Left + Linksoffset
Oben = ActiveCell.Top
ActiveCell.ColumnWidth = ZellenBreite
ActiveCell.FormulaR1C1 = ZellenText
ActiveSheet.Shapes.AddShape(msoShapeRectangle, Links, Oben, RechteckBreite, Höhe).Select
'ActiveSheet.Shapes("Rectangle 1").Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), Address:=Adresse
Selection.ShapeRange.Fill.Visible = msoTrue
Selection.ShapeRange.Fill.Solid
Selection.ShapeRange.Fill.ForeColor.SchemeColor = 9
Selection.ShapeRange.Fill.Transparency = 0#
Selection.ShapeRange.Line.Weight = 0.75
Selection.ShapeRange.Line.DashStyle = msoLineSolid
Selection.ShapeRange.Line.Style = msoLineSingle
Selection.ShapeRange.Line.Transparency = 0#
Selection.ShapeRange.Line.Visible = msoFalse
'ActiveSheet.Shapes("Rectangle 1").Select
Selection.Characters.Text = "hier"
With Selection.Characters(Start:=1, Length:=Len(RechteckText)).Font
.Name = "Arial"
.FontStyle = "Standard"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
'ActiveSheet.Shapes("Rectangle 1").Select
With Selection.Font
.Name = "Arial"
.FontStyle = "Standard"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = Unterstrich
.ColorIndex = Farbe
End With
ActiveCell.Select
End Sub