- Katılım
- 5 Eylül 2007
- Mesajlar
- 1,247
- Excel Vers. ve Dili
- ofis 2010
iyi günler; form sitesinden temin ettiğim makro ile pdf uzantılı dosyaları düzenliyorum , ilave olarak işlemin sonuna 2019 da yazdırmak istiyorum yani , 0180044623_2019~01-2019~01_KDV1_BYN_ok olan uzantıyı KDV1_BYN_ok-01 şeklinde çeviriyor, bu şekilde çevirmesi KDV1_BYN_ok-01_2019 şeklinde yapmaya çalıştım olmadı, Teşekkürler
Kod:
Dim sayfaadi, eskidosya, yenidosya, dosyaadi As String
Dim aradizin As String
Dim say As Integer
Dim buluzanti As String
Sub menu()
aradizin = Cells(2, 1).Value & "\"
buluzanti = Cells(2, 2).Value
say = 0
Call dosyalaribul
MsgBox say & " adet dosya adı değiştirme işlemi tamamlandı."
End Sub
Function dosyavarmi(ByVal fName As String) As Boolean
On Error Resume Next
dosyavarmi = ((GetAttr(fName) And vbDirectory) <> vbDirectory)
End Function
Sub dosyalaribul()
Dim FileNameWithPath As Variant
Dim ListOfFilenamesWithParh As New Collection
Call FileSearchByHavrda(ListOfFilenamesWithParh, aradizin, "*.*", True)
Dim z As Long
Dim ws As Worksheet
Application.ScreenUpdating = False
For Each FileNameWithPath In ListOfFilenamesWithParh
dosyaadi = FileNameWithPath
uzanti = Right(dosyaadi, Len(dosyaadi) - InStrRev(dosyaadi, "."))
If UCase(uzanti) = buluzanti And InStr(dosyaadi, "~") > 0 Then
dosya = ""
yol = ""
For i = Len(dosyaadi) To 1 Step -1
If Mid(dosyaadi, i, 1) = "\" Then
yol = Mid(dosyaadi, 1, i)
dosya = Mid(dosya, 1, Len(dosya) - 4)
vn = Mid(dosya, 1, InStr(dosya, "_") - 1)
If Len(vn) = 10 Then basla = 25 Else basla = 26
ay = Mid(dosya, basla, 2)
dosya = yol & Mid(dosya, basla + 3, Len(dosya)) & "-" & ay & ".pdf"
If dosyavarmi(dosya) Then
MsgBox (dosya & " bu dosya isminden bir dosya mevcut. Dosya adı değiştirilemez")
Exit For
Else
say = say + 1
Name dosyaadi As dosya
End If
Exit For
End If
If Mid(dosyaadi, i, 1) <> "\" Then dosya = Mid(dosyaadi, i, 1) & dosya
Next i
a = a
End If
Next FileNameWithPath
If ListOfFilenamesWithParh.Count = 0 Then
Debug.Print "Dosya bulunamadı."
MsgBox "Dosya bulunamadı."
End If
Application.ScreenUpdating = True
Exit Sub
End Sub
Private Sub FileSearchByHavrda(pFoundFiles As Collection, pPath As String, pMask As String, pIncludeSubdirectories As Boolean)
On Error Resume Next
Dim DirFile As String
Dim CollectionItem As Variant
Dim SubDirCollection As New Collection
pPath = Trim(pPath)
If Right(pPath, 1) <> "\" Then pPath = pPath & "\"
DirFile = Dir(pPath & pMask)
Do While DirFile <> ""
pFoundFiles.Add pPath & DirFile
DirFile = Dir
Loop
If Not pIncludeSubdirectories Then Exit Sub
DirFile = Dir(pPath & "*", vbDirectory)
Do While DirFile <> ""
If DirFile <> "." And DirFile <> ".." Then If ((GetAttr(pPath & DirFile) And vbDirectory) = 16) Then SubDirCollection.Add pPath & DirFile
DirFile = Dir
Loop
For Each CollectionItem In SubDirCollection
Call FileSearchByHavrda(pFoundFiles, CStr(CollectionItem), pMask, pIncludeSubdirectories) ' Recursive procedure call
Next
End Sub