تعديل لكود ياخذ الصورة قص وليس نسخ

[محمد التميمي]

السلام عليكم

لدي في النموذج رز امر يحتوي على كود ليستعرض الكومبيوتر وياخذ الصورة نسخ ويحفضها في Pictures برقم السجل . جيد جداً

المطلوب 

تعديل على الكود لياخذ الصورة قص وليس نسخ 

لانه يوجد ملف فيه صور كثيرة وكلما اخذ الصور قص وليس نسخ تتناقص الصور تدريجيا 

بوركتم وجزاكم الله خير جزاء المحسنين

New.rar

[kanory]

ضع هذا الكود ....

On Error GoTo err:

   ' Requires reference to Microsoft Office 15.0 Object Library.
Dim fso As Object
Set fso = CreateObject("scripting.filesystemobject")
   Dim fDialog As Office.FileDialog
   Dim varFile As Variant
    Dim destpath As Variant
   ' Clear listbox contents.
   Me.PicPath2 = ""

   ' Set up the File Dialog.
   Set fDialog = Application.FileDialog(msoFileDialogFilePicker)

   With fDialog

      ' Allow user to make multiple selections in dialog box
      .AllowMultiSelect = False

      ' Set the title of the dialog box.
      .title = "Please select one image"

      ' Clear out the current filters, and add our own.
      .Filters.Clear
      .Filters.Add "png image", "*.jpg"
      .Filters.Add "jpg image", "*.bmp"
      .Filters.Add "jpeg image", "*.png"
      .Filters.Add "jpg image", "*.jpeg"
      .Filters.Add "All Files", "*.*"

      ' Show the dialog box. If the .Show method returns True, the
      ' user picked at least one file. If the .Show method returns
      ' False, the user clicked Cancel.
      If .Show = True Then

         'Loop through each file selected and add it to our list box.
         For Each varFile In .SelectedItems
         
       
        destpath = Application.CurrentProject.Path & "\" & "Pictures" & "\" & Me.Key & "." & Right$(varFile, Len(varFile) - InStrRev(varFile, "."))
            FileCopy varFile, destpath
            Kill (varFile)
            Me.PicPath2 = destpath
            Me.Refresh
            
         Next

      Else
         MsgBox "لقد قمت بالنقر فوق إلغاء الأمر في مربع حوار الملف."
      End If
   End With
   Exit Sub
err:
   MsgBox err.Description & " " & err.Number

تم اضافة هذا الجزء 

Kill (varFile)

 

[محمد التميمي]

8 دقائق مضت, kanory said:

ضع هذا الكود ....

 

 

شكرا استاذي على المرور بارك الله بك الكود يعمل بامتياز كان الخطأ من عندي

تم تعديل يوليو 12, 2021 بواسطه محمد التميمي

[Eng.Qassim]

10 minutes ago, kanory said:

ضع هذا الكود ....

On Error GoTo err:

   ' Requires reference to Microsoft Office 15.0 Object Library.
Dim fso As Object
Set fso = CreateObject("scripting.filesystemobject")
   Dim fDialog As Office.FileDialog
   Dim varFile As Variant
    Dim destpath As Variant
   ' Clear listbox contents.
   Me.PicPath2 = ""

   ' Set up the File Dialog.
   Set fDialog = Application.FileDialog(msoFileDialogFilePicker)

   With fDialog

      ' Allow user to make multiple selections in dialog box
      .AllowMultiSelect = False

      ' Set the title of the dialog box.
      .title = "Please select one image"

      ' Clear out the current filters, and add our own.
      .Filters.Clear
      .Filters.Add "png image", "*.jpg"
      .Filters.Add "jpg image", "*.bmp"
      .Filters.Add "jpeg image", "*.png"
      .Filters.Add "jpg image", "*.jpeg"
      .Filters.Add "All Files", "*.*"

      ' Show the dialog box. If the .Show method returns True, the
      ' user picked at least one file. If the .Show method returns
      ' False, the user clicked Cancel.
      If .Show = True Then

         'Loop through each file selected and add it to our list box.
         For Each varFile In .SelectedItems
         
       
        destpath = Application.CurrentProject.Path & "\" & "Pictures" & "\" & Me.Key & "." & Right$(varFile, Len(varFile) - InStrRev(varFile, "."))
            FileCopy varFile, destpath
            Kill (varFile)
            Me.PicPath2 = destpath
            Me.Refresh
            
         Next

      Else
         MsgBox "لقد قمت بالنقر فوق إلغاء الأمر في مربع حوار الملف."
      End If
   End With
   Exit Sub
err:
   MsgBox err.Description & " " & err.Number

تم اضافة هذا الجزء 

Kill (varFile)

 

هل تقصد استاذ ...اضافة هذا الحقل فقط ؟

Kill (varFile)

تم تعديل يوليو 12, 2021 بواسطه Eng.Qassim

[محمد التميمي]

5 دقائق مضت, Eng.Qassim said:

هل تقصد استاذ ...اضافة هذا الحقل فقط ؟

 

Kill (varFile)

 

اسف استاذي كنت اعمل على غير برنامج وسطح المكتب فوضى 

تم تعديل يوليو 12, 2021 بواسطه محمد التميمي

[Eng.Qassim]

2 minutes ago, Eng.Qassim said:

هل تقصد استاذ ...اضافة هذا الحقل فقط ؟

Kill (varFile)

عذرا ...اقصد السطر

[محمد التميمي]

الان, Eng.Qassim said:

عذرا ...اقصد السطر

لا السطر من ضمن الكود ولاكن كان الاستاذ يقصد انه اضافة فقط

[Eng.Qassim]

1 minute ago, محمد التميمي said:

اسف استاذي كنت اعمل على غير برنامج وسطح المكتب فوضى الكود يعمل بنجاح بار الله بجهودك وزاد الله من ميزان حسناتك

الشكر لاستاذ kanory وليس لي

[محمد التميمي]

19 دقائق مضت, kanory said:

ضع هذا الكود ....

تم اضافة هذا الجزء 

 

شكرأ شكرأ اخي واستاذي kanory تم تجربة الكود عدة مرات ويعمل بامتياز اسف على تاخري بالرد اعمل على برنامج آخر وسطح المكتب فوضى

بارك الله بك اخي الفاضل وجعله الله في ميزان حسناتك

[Eng.Qassim]

7 minutes ago, محمد التميمي said:

شكرأ شكرأ اخي واستاذي kanory تم تجربة الكود عدة مرات ويعمل بامتياز اسف على تاخري بالرد اعمل على برنامج آخر وسطح المكتب فوضى

بارك الله بك اخي الفاضل وجعله الله في ميزان حسناتك

شكرا لك استاذ محمد التميمي على سؤالك فقد اضاف لنا معلومة من الاستاذ

kanory