Makro Objekt in alle Tabellenblätter

Sub Stempel() ' Stempel Makro ' Tastenkombination: Strg+Umschalt+S ActiveSheet.OLEObjects.Add(Filename:="H:\Profil\Desktop\Stempel_neu.docx", _ Link:=False, DisplayAsIcon:=False).Select ActiveSheet.Shapes("Object 3").ScaleWidth 0.6670341786, msoFalse, _ msoScaleFromTopLeft ActiveSheet.Shapes("Object 3").IncrementLeft -141.25 ActiveSheet.Shapes("Object 3").IncrementTop 356.25 End Sub

Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Thomas,
hier dein Makro entsprechend angepasst.
Die Skalierung funktioniert bei mir aber nicht dauerhaft. Wenn die datei gespeichert wird, dann ändert sich die Höhe wieder auf den Originalwert.
Mit der Füllung hatte ich jetzt keine Probleme. Der Bereich um das Wordobjekt blieb bei mir beim Einfügen ohne Füllung. Ich hab mal eine entsprechende Zeile im Code eingebaut - konnte dies aber nicht positiv testen.
LG
Franz

'Bearbeitet 2020-03-22 unter Windows 10, Excel 365
Sub Stempel()
' Stempel Makro
' Tastenkombination: Strg+Umschalt+S
Dim wks As Worksheet, intS As Integer
Dim strDateiStempel As String
Dim rngZiel As Range
Dim objObject As Object, objShape As Shape
strDateiStempel = "H:\Profil\Desktop\Stempel_neu.docx"
strDateiStempel = "C:\Users\Admin\Desktop\Stempel_neu.docx"
For intS = 1 To ActiveWorkbook.Worksheets.Count
With ActiveWorkbook.Worksheets(intS)
Select Case .Name
Case "Tabelle2", "Tab XYZ" 'Namen anpassen !!!
'auf diesen Blättern keinen Stempel einfügen
Case Else
.Activate
Set rngZiel = .Range("D58")
rngZiel.Select
If wks Is Nothing Then
Set wks = ActiveWorkbook.Worksheets(intS)
'Worddatei als nicht verlinktes Objekt in Zelle laden
Set objObject = .OLEObjects.Add(Filename:=strDateiStempel, _
Link:=False, DisplayAsIcon:=False)
'OLE-Object eier Shape-Variablen zuweisen
Set objShape = .Shapes(objObject.Name)
With objShape
.LockAspectRatio = msoTrue
'eingefügtes Objekt skalieren
.ScaleWidth 0.6670341786, msoFalse, msoScaleFromTopLeft
'Linien ausblenden
.Line.Visible = msoFalse
'Füllung ausblenden
.Fill.Visible = msoFalse
.Copy
End With
Else
ActiveSheet.Paste
End If
Set objShape = .Shapes(.Shapes.Count)
With objShape
'eingefügtes Objekt in der Zielzelle positionieren
.Top = rngZiel.Top + 2
.Left = rngZiel.Left + 2
End With
rngZiel.Select
End Select
End With
Next intS
End Sub

Beliebteste Forumthreads (12 Monate)

Makro Objekt in alle Tabellenblätter

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread

306 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Makro Objekt in alle Tabellenblätter

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

306 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread