السلام عليكم
لقية موضوع لكن المشكله للاكسس وارغب بكود لاخذ صوره بالاكسل
Private Const iScanner As Long = 1764
Dim iSh
Private Sub Cmd_Pic_Folder_Click()
May_Pic = Application.GetOpenFilename("Picture Files (*.jpg; *.jpeg; *.bmp; *.gif),*.jpg; *.jpeg; *.bmp; *.gif")
If May_Pic = False Then Exit Sub
On Error GoTo 1
Set Image1.Picture = LoadPicture(May_Pic)
Exit Sub
1
MsgBox "هذا النوع من الصور غير معتمد في البرنامج", vbExclamation + vbMsgBoxRight, " "
End Sub
Private Sub CmdSA_Click()
On Error GoTo 1
Set s = iSh.Shapes(CStr(Me.Text_PicTo_Copy))
s.CopyPicture
iSh.ChartObjects.Add(0, 0, s.Width, s.Height).Chart.Paste
iSh.ChartObjects(1).Chart.Export Filename:="monimage.jpg"
iSh.Shapes(iSh.Shapes.Count).Delete
Me.Image1.PictureSizeMode = fmPictureSizeModeZoom
Me.Image1.Picture = LoadPicture("monimage.jpg")
Kill "monimage.jpg"
1
Dim N_Pic As String
If TBN_Pic.Text = "" Then Exit Sub
N_Pic = ThisWorkbook.Path & "\SW\S\" & TBN_Pic & ".jpg" 'bmp
SavePicture Image1.Picture, N_Pic
UserForm1.LabelPic.Caption = N_Pic
Application.Visible = False
Unload Me
End Sub
Private Sub CmdWA_Click()
On Error GoTo 1
Set s = iSh.Shapes(CStr(Me.Text_PicTo_Copy))
s.CopyPicture
iSh.ChartObjects.Add(0, 0, s.Width, s.Height).Chart.Paste
iSh.ChartObjects(1).Chart.Export Filename:="monimage.jpg"
iSh.Shapes(iSh.Shapes.Count).Delete
Me.Image1.PictureSizeMode = fmPictureSizeModeZoom
Me.Image1.Picture = LoadPicture("monimage.jpg")
Kill "monimage.jpg"
1
Dim N_Pic As String
If TBN_Pic.Text = "" Then Exit Sub
N_Pic = ThisWorkbook.Path & "\SW\W\" & TBN_Pic & ".jpg" 'bmp
SavePicture Image1.Picture, N_Pic
UserForm1.LabelPic.Caption = N_Pic
Application.Visible = False
Unload Me
End Sub
Private Sub CommandButton2_Click()
On Error Resume Next
Set iSh = Sheets("PH")
iSh.Activate
Application.CommandBars.FindControl(ID:=1764).Execute
For Each s In iSh.Shapes
Me.Text_PicTo_Copy.Text = s.Name
Next
Application.Visible = False
End Sub
Private Sub sCancel_Click()
Unload Me
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 0 Then Cancel = True
End Sub
ارغب بالمساعده في التعديل
وشكرا لكم