تغيير نام تعداد زيادي فايل در يك پوشه

[rezankh]

با سلام
پوشه‌ي دارم كه داخلش تعداد زيادي فايل تصويري هستش كه مي‌خوام با اعمال شرط همزمان rename بشند. هر چي دنبال گشتم پيدا نكردم ممنون مي‌شم اگه راهنمايي كنيد.

[arash020]

سلام
با کد

MsgBox (FileDateTime("k:\x.jpg"))
میتونی بگیری که زمان ایجاد فایل کی هستش
منتها شما باید با توابع مربوط به رشته
قسمت تاریخ رو از اطلاعات کلی تاریخ و زمان که نشون میده جدا کنی چون شما فقط به تاریخش احتیاج داری دیگه
بعدشم اینکه ممکنه هیچکدوم اون فایلها که قراره تغییر نام بدی توی یه ساعت و دقیقه نباشه ولی تاریخ شون یکی باشه
پس قسمت تاریخ رو جدا کن.
همین کار رو توی یه لوپ بزار تا همه ی فایل های اون پوشه رو از نظر تاریخ چک کنه و (آدرس دقیق)مساوی ها رو جایی مثلا توی یه لیست باکس دیگه بریز
قدم بعد عم که دیگه راحته:
حالا فایل های هم زمان و آدرسشونو داری دیگه
با یه حلقه تک تک فایل هارو میتونی با دستور:

"مسیر و نام فایل مقصد","مسیر و نام فایل مبدا" FileCopy

با نام تغییر داده (دلخواه) توی همون پوشه ی خودش کپی کنی و بعد
با دستور:

"مسیر و نام فایل برای حذف" Kill

فایل اصلی رو (نام قبلی) حدف کنی
->چون تابع تغییر نام ندیدم!
کار راحتیه
موفق باشی

[MMR_1344]

با دستور Name هم میتونی بصورت زیر عمل کنی

إName Oldfilename As Newfilename

[kitcat_m18]

مي توني از توابع API هم استفاده کني

Declare Function MoveFileEx Lib "kernel32" Alias "MoveFileExA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal dwFlags As Long) As Long

[sajjad_india]

بهترین پیشنهاد :
قبلش نمیدونم چقدر با FOS کار کردی . حالا بگذریم
اول مسی اون پوشه فایل رو با ListFile بگیر بهد یکی یکی نام فایل ها رو بریز تو آرایه بعد متغیر نام تعریف کن بعدش با تابع FOS که به مقدار تعداد فایل ها در درون حلقه نام فایل رو عوض کن .
For i= 0 to TedadeFileDaraPoshe
FOS.RenameFile(NameFile)+i
Next I

[kitcat_m18]

فکر مي کنم منظور دوست عزيزمون سجادFileSystemObject ) FSO) باشه.

[rezankh]

با تشكر از همه دوستان عمليات تغيير نام به روشي كه ميخواستم رو درستش كردم و جواب داد ولي فقط براي يك فايل، لذا از حلقه Do While به شكل زير استفاده كردم


Private Sub XPButton3_Click()

Dim f0 As String
Dim f1 As String
Dim F2 As String
Dim F3 As String
Dim f4 As String
Dim F5 As String
Dim F6 As String
Dim F7 As String
Dim le As Integer
Dim p0 As String


f0 = Dir$(App.Path & "\Pictures\*.jpg")

Do While Len(f0)

f0 = Dir$(App.Path & "\Pictures\*.jpg")

le = Len(f0)

If le = 5 Then
p0 = Left(f0, 1)
End If

If le = 6 Then
p0 = Left(f0, 2)
End If

If le = 7 Then
p0 = Left(f0, 3)
End If

If le = 8 Then
p0 = Left(f0, 4)
End If

If le = 9 Then
p0 = Left(f0, 5)
End If

If le = 10 Then
p0 = Left(f0, 6)
End If

If le = 11 Then
p0 = Left(f0, 7)
End If

If le = 12 Then
p0 = Left(f0, 8)
End If

If le = 13 Then
p0 = Left(f0, 9)
End If

If le = 14 Then
p0 = Left(f0, 10)
End If

If le = 15 Then
p0 = Left(f0, 11)
End If

If le = 16 Then
p0 = Left(f0, 11)
End If

If le = 17 Then
p0 = Left(f0, 11)
End If

If le = 18 Then
p0 = Left(f0, 11)
End If

If le = 19 Then
p0 = Left(f0, 11)
End If

f1 = StrReverse(p0)
F2 = Left(f1, 1)


If IsNumeric(F2) = True Then
F3 = ""
f4 = Left(f1, 3)
F7 = StrReverse(f4)
Name App.Path & "\Pictures\" & f0 & "" As App.Path & "\Pictures\" & F7 & ".jpg"
End If

If IsNumeric(F2) = False Then
F3 = "l"
f4 = Left(f1, 4)
F5 = Replace(f4, F2, F3)
F6 = StrReverse(F5)
Name App.Path & "\Pictures\" & f0 & "" As App.Path & "\Pictures\" & F6 & ".jpg"
End If

Loop

End Sub


توضيح : دليل اينكه عمليات طولاني شده اينه كه تابع right تو سيستمم كار نميكنه (بخاطر استفاده از كامپوننت خاص) .
حالا همه فايلها رو تغيير نام ميده ولي حلقه بينهايت شده، با حلقه لوپ هم فقط تو ديتابيس كار كردم و اطلاعاتم كمه لطفا راهنمايي كنيد تا درستش كنم. ممنون

[rezankh]

با تشكر از همه دوستان عمليات تغيير نام به روشي كه ميخواستم رو درستش كردم و جواب داد ولي فقط براي يك فايل، لذا از حلقه Do While به شكل زير استفاده كردم


Private Sub XPButton3_Click()

Dim f0 As String
Dim f1 As String
Dim F2 As String
Dim F3 As String
Dim f4 As String
Dim F5 As String
Dim F6 As String
Dim F7 As String
Dim le As Integer
Dim p0 As String


f0 = Dir$(App.Path & "\Pictures\*.jpg")

Do While Len(f0)

f0 = Dir$(App.Path & "\Pictures\*.jpg")

le = Len(f0)

If le = 5 Then
p0 = Left(f0, 1)
End If

If le = 6 Then
p0 = Left(f0, 2)
End If

If le = 7 Then
p0 = Left(f0, 3)
End If

If le = 8 Then
p0 = Left(f0, 4)
End If

If le = 9 Then
p0 = Left(f0, 5)
End If

If le = 10 Then
p0 = Left(f0, 6)
End If

If le = 11 Then
p0 = Left(f0, 7)
End If

If le = 12 Then
p0 = Left(f0, 8)
End If

If le = 13 Then
p0 = Left(f0, 9)
End If

If le = 14 Then
p0 = Left(f0, 10)
End If

If le = 15 Then
p0 = Left(f0, 11)
End If

If le = 16 Then
p0 = Left(f0, 11)
End If

If le = 17 Then
p0 = Left(f0, 11)
End If

If le = 18 Then
p0 = Left(f0, 11)
End If

If le = 19 Then
p0 = Left(f0, 11)
End If

f1 = StrReverse(p0)
F2 = Left(f1, 1)


If IsNumeric(F2) = True Then
F3 = ""
f4 = Left(f1, 3)
F7 = StrReverse(f4)
If p0 = F7 Then
Exit Sub
End If
Name App.Path & "\Pictures\" & f0 & "" As App.Path & "\Pictures\" & F7 & ".jpg"
End If

If IsNumeric(F2) = False Then
F3 = "l"
f4 = Left(f1, 4)
F5 = Replace(f4, F2, F3)
F6 = StrReverse(F5)
If p0 = F6 Then
Exit Sub
End If
Name App.Path & "\Pictures\" & f0 & "" As App.Path & "\Pictures\" & F6 & ".jpg"
End If


Loop

End Sub




اين مشكل هم خوشبختانه حل شد با اضافه كردن كدهايي كه به رنگ قرمز اضافه كردم. ممنون از شما دوستان عزيز

[rezankh]

با سلام
اگه ميشه يك نگاهي به اين برنامه بندازيد مشكل :
1- عمليات تغيير نام رو من تو حلقه do while گذاشتم ولي فقط همان فايل اولي تغيير نام مي‌يابد.
2 - حلقه بينهايت مي‌ماند. چطور وقتي تمام فايلها رو كه تغيير نام داد حلقه بسته شود.
لطف كنيد برنامه رو اصلاح كنيد.

[just4froum]

با سلام :

كدتون را بدين روش بنويسيد :


Private Sub Command1_Click()
Dim f0 As String
f0 = Dir$(App.Path & "\Pictures\*.jpg")
Do While Len(f0)
f1 = Left(f0, 2)
Name App.Path & "\Pictures\" & f0 & "" As App.Path & "\Pictures\" & f1 & ".jpg"
f0 = Dir
Loop
End Sub




موفق باشيد