Új hozzászólás Aktív témák

• #34875 Traxx őstag Delila_1 #34863

  Új Válasz 2017-04-11 12:16:58 #34875

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Traxx

  őstag

  válasz Delila_1 #34863 üzenetére

  és sztanozs: köszönöm

  Delila hozzászólása volt a kulcs, az alapján elkezdtem keresgélni, és egy külföldi fórumon találtam egy hasznos makrót, pont ilyen esetekre. Sikerült szépen lecserélnem az összes képet (és jól gondoltad, régi logót újra ). És igen, azonos helyen voltak a logók. Ha valakinek még szüksége lenne rá, akkor közzé is teszem, lefordítva a használat korlátjait, és a makróban a megjegyzéseket, szövegdobozokat. Egy új fájlba másoltam bele a makrót, amit utána elmentettem, aztán hajrá

  A makró működéséhez azért volt pár feltétel, ami szerencsére nálam adott volt:
  - ha a munkalap védett, akkor átugorja, és nem cseréli le a képet
  - ha a fájl csak egyetlen képet tartalmaz, akkor
  - a régi képet lecseréli az újra, ugyanabban a pozícióban, ahol az elődje volt
  - az új képen nem végez semmilyen átméretezést, szóval megfelelő méretűt célszerű választani
  - a fálj ugyanazon néven, de másik (LOGONEW) mappába kerül elmentésre; ezt a mappát létre kell hozni abban a könyvtárban, ahol a cserélendő fájlok vannak
  - és nyilván a művelet előtt nem árt egy biztonsági mentés

  És a makró:

  Sub ReBrand()

Dim PCount As Long, I As Long, Candid As Long, myPath As String, myFFile As String
Dim LogSh As Worksheet, LogoPos As String, newLogo As String, NextLogLine As Long
Dim mySk As Long, myRep As Long, myTim As Single
'
newLogo = "D:\logo2.jpg" '<<< Az új logo elérési útja és neve
'
'Figyelmeztető üzenet:
rispo = MsgBox("Add meg a könyvtárat, amelyek fáljaiban ki kell cserélni a logo-t" & vbCrLf _
& "A könyvtárnak tartalmaznia kell egy ÜRES mappát, aminek a neve ""LOGONEW""" _
& vbCrLf & "Nyomd meg az OK-t a folytatáshoz, vagy a Cancelt a folyamat megszakításához.", vbOKCancel)
If rispo <> vbOK Then Exit Sub

'A fájlok elérési útjának megkapása:
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .SelectedItems.Count = 0 Then
MsgBox ("Nem történt kiválasztás, a folyamat megszakítva")
Exit Sub
End If
myPath = .SelectedItems.Item(1)
End With
'
'Indítás:
myTim = Timer
Set LogSh = ThisWorkbook.Sheets(1) 'A tevékenységek naplózása a munkalapon
'
myFFile = Dir(myPath & "\*.xls*") 'megkapjuk az első fájl nevét
Application.EnableEvents = False
Do
PCount = 0
If myFFile = "" Then Exit Do 'Lépjen ki, ha nincs fájl
Workbooks.Open myPath & "\" & myFFile
'A fájl nevének naplózása:
NextLogLine = LogSh.Cells(Rows.Count, 1).End(xlUp).Row + 1
LogSh.Cells(NextLogLine, 1) = myFFile
'Számolja meg, hány kép van:
For I = 1 To Worksheets.Count
LogSh.Cells(NextLogLine, 2).Offset(0, I) = Sheets(I).Name
If Sheets(I).Pictures.Count > 0 Then
PCount = PCount + Sheets(I).Pictures.Count
If Sheets(I).ProtectContents Then PCount = 999
'Naplózási infó a munkalapokon:
LogSh.Cells(NextLogLine, 2).Offset(0, I).Value = "*--" & PCount & "--*--" & Sheets(I).Name
Candid = I
End If
If PCount > 1 Then '>1, nem kell szkennelni több munkalapot
Exit For
End If
Next I
If PCount = 1 Then 'Fájl kijelölve a kicserélésre
Worksheets(Candid).Select
If UCase(Left(ActiveSheet.Pictures(1).Name, 7)) = "PICTURE" Then
'ok, kicserélés:
ActiveSheet.Pictures(1).Select
LogoPos = Selection.TopLeftCell.Address
Selection.Delete
Range(LogoPos).Select
ActiveSheet.Pictures.Insert(newLogo).Select
Range("A1").Select
'Napló eredmény:
LogSh.Cells(NextLogLine, 2).Value = ">>>>>: " & LogoPos
myRep = myRep + 1
'Mentés az új mappába:
ActiveWorkbook.SaveAs (myPath & "\LOGONEW\" & myFFile)
Else
'Napló eredmény:
LogSh.Cells(NextLogLine, 2).Value = "SKIPPED--" & PCount
mySk = mySk + 1
End If
Else
'Napló eredmény:
LogSh.Cells(NextLogLine, 2).Value = "SKIPPED--" & PCount
mySk = mySk + 1
End If
Workbooks(myFFile).Close savechanges:=False 'Bezárás

myFFile = Dir 'Következő fájl
Loop
Application.EnableEvents = True
'
'Végső üzenet:
MsgBox ("Szükséges idő (secs): " & Format(Timer - myTim, "0.00") & vbCrLf _
& "Lecserélve: " & myRep & vbCrLf & "Átugorva: " & mySk)
End Sub

  Az eredeti forrás: [link]

Új hozzászólás Aktív témák