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