تغيير مكان حفظ الصور

[Alaaq3]

السلام عليكم ورحمة الله : الاساتذة الكرام ارجو المساعدة في موضوع حفظ مكان الصور . هذا الفورم المرفق يقوم بحفظ الصور بجانب ملف الاكسل . وانا اريد ان يحفظها في مكان اخر مثلا ( ملف الاكسل على سطح المكتب والصور في قرص /:E) 

بيان الموظفين.xlsm

Private Sub CommandButton1_Click()
Unload Me
End Sub
Private Sub CommandButton2_Click()
image_path = Application.GetOpenFilename(FileFilter:="Picture Files (Fichiers image),*.gif;*.jpg;*.jpeg;*.bmp", Title:="اختار الصورة")
If image_path <> False Then
Me.Image1.Picture = LoadPicture(image_path)
Me.Image1.Visible = True
End If
End Sub

Private Sub CommandButton3_Click()
If TextBox2.Value = "" Then MsgBox "ادخل اسم الصورة اولا": Exit Sub
Var = TextBox2.Text

مكان حفظ الصور '

SavePicture Image1.Picture, ThisWorkbook.Path & "\" & Var & ".jpg"
MsgBox "تم حفظ الصورة بنجاح مع تحيات مجدى يونس", vbInformation
End Sub

Private Sub Image1_Click()

End Sub

Private Sub TextBox1_Change()
'=============================

Dim MYPATH
MYPATH = ThisWorkbook.Path & "\" & TextBox1.Text & ".JPG"
If Right(MYPATH, 1) <> "\" Then
On Error GoTo 1
Image1.Picture = LoadPicture(MYPATH)
Else
1:
'MsgBox "هذا الصورة غير موجودة", vbInformation, "خطأ"
'Image1.Picture = LoadPicture()
Image1.Picture = LoadPicture(ThisWorkbook.Path & "\M.JPG")
Exit Sub
End If
'==========================================

End Sub

Private Sub TextBox2_Change()

End Sub

Private Sub UserForm_Click()

End Sub

Private Sub Yh_ListFind_Click()
On Error Resume Next
Dim MYSH As Worksheet
Dim S_1 As String
S_1 = Yh_ListFind.List(Yh_ListFind.ListIndex, 6)
Set MYSH = Sheets("new")
With MYSH
    .Select
    .Range(S_1).Select
End With
TextBox1.Value = Range(S_1).Value
End Sub

Private Sub Yh_ListFind_DblClick(ByVal cancel As MSForms.ReturnBoolean)
On Error Resume Next
Dim MYSH As Worksheet
Dim S_1 As String
S_1 = Yh_ListFind.List(Yh_ListFind.ListIndex, 6)
Set MYSH = Sheets("new")
With MYSH
    .Select
    .Range(S_1).Select
End With
Me.Hide
End Sub

Private Sub Yh_TextFind_Change()
On Error Resume Next
Dim MYSH As Worksheet
Dim V As Integer, LastRow As Integer
Dim M As String
Dim A, F
Yh_ListFind.Clear
If Yh_TextFind.Text = "" Then GoTo 1
M = Yh_TextFind.Text
        Set MYSH = Sheets("new")
        With MYSH
            LastRow = .Cells(.Rows.Count, "d").End(xlUp).Row
            Set A = .Range("d13:d" & LastRow).Find(M)
            If Not A Is Nothing Then
                F = A.Address
                Do
                If Application.WorksheetFunction.Search(M, A, 1) = 1 Then
                    Yh_ListFind.AddItem A.Value
                    Yh_ListFind.List(V, 1) = A.Offset(0, 1).Value
                    Yh_ListFind.List(V, 2) = A.Offset(0, 2).Value
                    Yh_ListFind.List(V, 3) = A.Offset(0, 3).Value
                    Yh_ListFind.List(V, 4) = A.Offset(0, 4).Value
                    Yh_ListFind.List(V, 5) = A.Offset(0, 5).Value
                    Yh_ListFind.List(V, 6) = A.Address
                    V = V + 1
                 End If
                Set A = .Range("d13:d" & LastRow).FindNext(A)
                Loop While Not A Is Nothing And A.Address <> F
            End If
        End With

On Error GoTo 0
1 End Sub

 

[عبدالفتاح في بي اكسيل]

الرجاء  ضع  الكود  في <> كما موجود في  اعدادات الكتابة والتنسيق  لديك 

غير مجرب .  مجرد  محاولة 

كما ترى انشا  مجلد  في  اي  محرك تريده  ثم قم  بنسخ امتداده وضعه في  الكود 

Private Sub CommandButton3_Click()
Const csPath As String = "C:\Test\"

If TextBox2.Value = "" Then MsgBox "ادخل اسم الصورة اولا": Exit Sub
Var = TextBox2.Text

مكان حفظ الصور '

SavePicture Image1.Picture, csPath & Var & ".jpg"
MsgBox "تم حفظ الصورة بنجاح مع تحيات مجدى يونس", vbInformation
End Sub

 

[حسونة حسين]

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

استبدل هذه الجمله

ThisWorkbook.Path & "\" 

الى 

"E:\" 

 

[Alaaq3]

احسنتم كثيرا كيلا الطريقتان نجحتا