Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
908to912
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
908to912
908to912
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Logo ersetzen

Logo ersetzen
26.09.2007 11:37:34
Jürg
Halloo Forumsrunde
Habe ein anliegen und brauche eure Hilfe.
ich muss bei 1800 Exceldateien mit über 4 Tabellen (Mappen) das Firmenloge ersetzen.
Gibt es einen Code der das macht?
meine Vorstellung
datei öffnen,
n Tabellen(Mappen) altes Logo löschen
n Tabellen(Mappen) neues Logo einfügen
bereich ist A1:d4
datei schliessen
nachste datei öffnen .... etc
gibt es sowas?
besten dank
jürg

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Logo ersetzen
26.09.2007 11:59:13
Rudi
Hallo,
teste mal:

Option Explicit
Sub Logo_tauschen()
Dim oFS As Object, oFldr As Object, oFile As Object, wkb As Workbook, strImagePath
Dim iFile As Integer, iFiles As Integer
Const strOL As String = "A1"   'Zelle mit oberer linker Ecke des Logos
Const strUR As String = "D4"   'Zelle mit unterer rechter Ecke des Logos
Set oFS = CreateObject("scripting.filesystemobject")
On Error Resume Next
Set oFldr = oFS.getfolder(GetOrdner(, "Ordner mit zu ändernden Dateien wählen"))
On Error GoTo 0
If oFldr Is Nothing Then Exit Sub
strImagePath = Application.GetOpenFilename _
("Bilder *.jpg; *.gif, *.jpg; *.gif", , "Bitte das neue Bild auswählen")
If strImagePath = False Then Exit Sub
iFile = 1
iFiles = oFldr.Files.Count
Application.ScreenUpdating = False
For Each oFile In oFldr.Files
If oFile.Name Like "*.xls" Then
Application.StatusBar = "Datei " & iFile & " (" _
& Format(Int(oFile.Size / 1024), "#,##0") & " kB) von " & iFiles & " öffnen"
Set wkb = Workbooks.Open(oFile, ignorereadonlyrecommended:=True)
prcInsertImage wkb, strImagePath, strOL, strUR
Application.StatusBar = "Datei " & iFile & " (" _
& Format(Int(oFile.Size / 1024), "#,##0") & " kB) von " & iFiles & " schließen"
wkb.Close True
iFile = iFile + 1
End If
Next oFile
Application.StatusBar = False
MsgBox "Erledigt", , ""
Application.ScreenUpdating = True
End Sub
Private Sub prcInsertImage( _
wkb As Workbook, _
ByVal strImage As String, _
strOL As String, _
strUR As String)
Dim shpNeu As Object, shp As Object, wks As Worksheet
Dim sngOldWidth As Single, rngImg As Range
Dim strPW As String
DoEvents
For Each wks In wkb.Worksheets
If wks.ProtectContents Then
On Error Resume Next
wks.Unprotect strPW
On Error GoTo 0
Else
strPW = ""
End If
If wks.ProtectContents Then
Do
strPW = InputBox("Kennwort für " & vbLf & wkb.Name & "!" & wks.Name & "?")
On Error Resume Next
wks.Unprotect strPW
On Error GoTo 0
Loop While wks.ProtectContents And strPW  ""
End If
If wks.ProtectContents Then
MsgBox wkb.FullName & " konnte nicht geändert werden!"
Exit Sub
End If
If wks.Range(strOL).MergeCells = True Or strUR = "" Then
Set rngImg = wks.Range(strOL).MergeArea
Else
Set rngImg = wks.Range(wks.Range(strOL), wks.Range(strUR))
End If
For Each shp In wks.Shapes
If Not Intersect(shp.TopLeftCell, rngImg) Is Nothing And shp.Type = msoPicture Then
shp.OLEFormat.Object.Delete
Set shpNeu = wks.Pictures.Insert(strImage)
sngOldWidth = shpNeu.Width
With shpNeu
.Width = rngImg.Width - 4
.Height = .Height * .Width / sngOldWidth
.Left = wks.Range(strOL).Left + 2
.Top = WorksheetFunction.Min(rngImg.Top + (rngImg.Height - .Height) / 2, _
wks.Range(strOL).Top + wks.Range(strOL).Height - 1)
End With
End If
Next shp
If strPW  "" Then wks.Protect strPW
Next wks
End Sub
Private Function GetOrdner(Optional ByVal def = "", _
Optional ByVal Text = "Bitte einen Ordner wählen.")
'Ordnerauswahl
Dim objShell As Object, objFolder As Object
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, Text, 0, def)
If objFolder Is Nothing Then Exit Function
GetOrdner = objFolder.Self.Path
End Function


Achtung: unbedingt vorher die Dateien sichern.
Gruß
Rudi
Eine Kuh macht Muh, viele Kühe machen Mühe

Anzeige
AW: Logo ersetzen
26.09.2007 17:23:00
Jürg
hallo rudi
klappt vorzüglich
herzlichen Dank
gruss
Jürg

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige