اذهب الي المحتوي
أوفيسنا

تغيير اسم الملف


الردود الموصى بها

أستاذنا الكبير عميد منتدنا  / جمال دغيدي

 

السلام عليكم ورحمة الله وبركاته

 

جزاك الله خيراً لك كل الشكر ولأستاذنا القدير / عبد الله باقشير كل الشكر والتحية على هذه الروائع المفيدة . دمتم لنا وجعل جميع اعمالكم في ميزان حسناتكم.

رابط هذا التعليق
شارك

السلام عليكم

جزاكم الله خيرا

 

هذا كود يعمل على اي امتداد


Option Explicit
'======================================================
'======================================================



Sub RenameMe()
Dim NewName As String, MyBook As String, MyPath As String, MyTyp As String, MyName As String
'============================
On Error GoTo Err_kh_Name
'============================
1:
NewName = InputBox("ادخل اسم الملف الجديد", "اسم الملف")
If StrPtr(NewName) = 0 Then Exit Sub
If Trim(NewName) = "" Then GoTo 1
'============================
With ThisWorkbook
    MyBook = .Name
    MyPath = .Path & Application.PathSeparator
End With

MyTyp = Mid$(MyBook, InStrRev(MyBook, "."))
MyName = Replace(MyBook, MyTyp, "")
'============================
If NewName = MyName Then
    MsgBox "اسم الملف هذا هو نفس الاسم الحالي", vbOKOnly, ""
    GoTo 1
End If
'============================
NewName = MyPath & NewName & MyTyp

If Dir(NewName, vbDirectory) = vbNullString Then
    ThisWorkbook.SaveAs Filename:=NewName
    Kill MyPath & MyBook
    MsgBox "تم تعديل اسم الملف بنجاح", vbOKOnly, "الحمدلله"
Else
    MsgBox "اسم الملف هذا موجود مسبقا", vbOKOnly, ""
    GoTo 1
End If
'============================
Err_kh_Name:
If Err Then
    MsgBox "Err.Number : " & Err.Number
    Err.Clear
End If

End Sub

المرفق 2003

vvv.rar

  • Like 3
رابط هذا التعليق
شارك

السلام عليكم

الاستاذ القدير دغيدي 

جزاك الله خير على هذا الملف

 

 

الاستاذ العلامه عبدالله باقشير حفظك الله

حقيقة كود جميل جدا

جزاك الله كل خير وبارك فيك

 

تقبلو مروري

رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information