تعديل كود لحفظ الصور

[اشرف]

Private Sub Command125_Click()
On Error GoTo err:

   ' Requires reference to Microsoft Office 14.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.PicPath1 = ""
   Me.PicPath2 = ""
   Me.PicPath3 = ""
   ' Set up the File Dialog.
   Set fDialog = Application.FileDialog(msoFileDialogFilePicker)

   With fDialog

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

      ' Set the title of the dialog box.
      .Title = "Please select images"

      ' Clear out the current filters, and add our own.
      .Filters.Clear
      
      .Filters.Add "jpg image", "*.jpg"
      
      
      ' Show the dialog box. If the .Show method returns True, the
      ' user picked at least all files. 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 & "\" & "ashraf" & "\" & Me.PName & "a." & Right$(varFile, Len(varFile) - InStrRev(varFile, "."))
           FileCopy varFile, destpath
            Me.PicPath1 = destpath
             destpath = Application.CurrentProject.Path & "\" & "ashraf" & "\" & Me.PName & "b." & Right$(varFile, Len(varFile) - InStrRev(varFile, "."))
           FileCopy varFile, destpath
            Me.PicPath2 = destpath
              destpath = Application.CurrentProject.Path & "\" & "ashraf" & "\" & Me.PName & "d." & Right$(varFile, Len(varFile) - InStrRev(varFile, "."))
           FileCopy varFile, destpath
            Me.PicPath3 = destpath
            
         Next

      Else
         MsgBox "You clicked Cancel in the file dialog box."
      End If
   End With
   Exit Sub
err:
   MsgBox err.Description & " " & err.Number
End Sub

السلام عليكم اخواني

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

اريد عن طريق ذر واحد ادخال مجموعة صور دفعة واحدة يضع في كل خانة الامتداد لصورة 

وفقت كود ولكن به عيب او مشكله انه ياخذ صورة واحدة من مجموعة الصور المحدددة ويحفظها بامتدادات محتلفة في الخانات الثلاثة

ارجو من الافاضل اصحاب الخبرة تعديل الكود ان امكن لاهميته

 

تم تعديل ديسمبر 19, 2020 بواسطه اشرف

[husamwahab]

وعليكم السلام استاذ اشرف 

تفضل التعديل  حسب فهمي

On Error GoTo err:

   ' Requires reference to Microsoft Office 14.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
    Dim i As Long
   ' Clear listbox contents.
   Me.PicPath1 = ""
   Me.PicPath2 = ""
   Me.PicPath3 = ""
   ' Set up the File Dialog.
   Set fDialog = Application.FileDialog(msoFileDialogFilePicker)

   With fDialog

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

      ' Set the title of the dialog box.
      .Title = "Please select images"

      ' Clear out the current filters, and add our own.
      .Filters.Clear
      
      .Filters.Add "jpg image", "*.jpg"
      
      
      ' Show the dialog box. If the .Show method returns True, the
      ' user picked at least all files. If the .Show method returns
      ' False, the user clicked Cancel.
      If .Show = True Then
     i = 1
         'Loop through each file selected and add it to our list box.
         For Each varFile In .SelectedItems
         
         If i = 1 Then
          destpath = Application.CurrentProject.Path & "\" & "ashraf" & "\" & Me.PName & "a." & Right$(varFile, Len(varFile) - InStrRev(varFile, "."))
           FileCopy varFile, destpath
            Me.PicPath1 = destpath
         ElseIf i = 2 Then
             destpath = Application.CurrentProject.Path & "\" & "ashraf" & "\" & Me.PName & "b." & Right$(varFile, Len(varFile) - InStrRev(varFile, "."))
           FileCopy varFile, destpath
            Me.PicPath2 = destpath
         Else
              destpath = Application.CurrentProject.Path & "\" & "ashraf" & "\" & Me.PName & "d." & Right$(varFile, Len(varFile) - InStrRev(varFile, "."))
           FileCopy varFile, destpath
            Me.PicPath3 = destpath
         End If
         i = i + 1
         Next

      Else
         MsgBox "You clicked Cancel in the file dialog box."
      End If
   End With
   Exit Sub
err:
   MsgBox err.Description & " " & err.Number

 

[اشرف]

السلام عليكم 

اخي الفاضل husamwahab

لك كل التقدير والاحترام علي سرعة الاستجابة هذا هو المطلوب بالضبط وعندما يكتمل البرنامج سأضعه هدية للمنتدي في رأس السنة الميلادية ان شاء الله وكنا من الاحياء

[husamwahab]

بالخدمة استاذي العزيز

والدعاء بالصحة والسلامة لك ولجميع الناس 

امين رب العالمين