[حل شده] ذخیره کردن یک عکس در فایل اکسل بوسیله ی vb در دسکتاپم

[amin.t]

سلام بر دوستان عزیز من می خوام عکسی که در فایل اکسلم وجود دارد را بوسیله ی کد vb در سیستمم ذخیره کنم . کسی می دونه چطور این کار رو باید انجام بدم ؟

[amir_ts]

با سلام
کد زیر رو امتحان کنید.

[LEFT]Option Explicit


Sub ExportAllPictures()
    Dim MyChart As Chart
    Dim n As Long, shCount As Long
    Dim Sht As Worksheet
    Dim pictureNumber As Integer


    Application.ScreenUpdating = False
    pictureNumber = 1
    For Each Sht In ActiveWorkbook.Sheets
        shCount = Sht.Shapes.Count
        If Not shCount > 0 Then Exit Sub


        For n = 1 To shCount
            If InStr(Sht.Shapes(n).Name, "Picture") > 0 Then
                
                Set MyChart = Charts.Add
                MyChart.Name = "TemporaryPictureChart"
               
                Set MyChart = MyChart.Location(Where:=xlLocationAsObject, Name:=Sht.Name)
                
                MyChart.ChartArea.Width = Sht.Shapes(n).Width
                MyChart.ChartArea.Height = Sht.Shapes(n).Height
                MyChart.Parent.Border.LineStyle = 0
                Sht.Shapes(n).Copy
                MyChart.ChartArea.Select
                MyChart.Paste
                      
                
                MyChart.Export Filename:=[COLOR=#ff0000]"C:\Users\User\Desktop"[/COLOR] & "\Picture-" & pictureNumber & ".jpg", FilterName:="jpg"
               
                
                pictureNumber = pictureNumber + 1
                
                Sht.Cells(1, 1).Activate
                Sht.ChartObjects(Sht.ChartObjects.Count).Delete
            End If
        Next
    Next Sht
    Application.ScreenUpdating = True
    
End Sub[/LEFT]

[amin.t]

با سلام
کد زیر رو امتحان کنید.

[LEFT]Option Explicit


Sub ExportAllPictures()
    Dim MyChart As Chart
    Dim n As Long, shCount As Long
    Dim Sht As Worksheet
    Dim pictureNumber As Integer


    Application.ScreenUpdating = False
    pictureNumber = 1
    For Each Sht In ActiveWorkbook.Sheets
        shCount = Sht.Shapes.Count
        If Not shCount > 0 Then Exit Sub


        For n = 1 To shCount
            If InStr(Sht.Shapes(n).Name, "Picture") > 0 Then
                
                Set MyChart = Charts.Add
                MyChart.Name = "TemporaryPictureChart"
               
                Set MyChart = MyChart.Location(Where:=xlLocationAsObject, Name:=Sht.Name)
                
                MyChart.ChartArea.Width = Sht.Shapes(n).Width
                MyChart.ChartArea.Height = Sht.Shapes(n).Height
                MyChart.Parent.Border.LineStyle = 0
                Sht.Shapes(n).Copy
                MyChart.ChartArea.Select
                MyChart.Paste
                      
                
                MyChart.Export Filename:=[COLOR=#ff0000]"C:\Users\User\Desktop"[/COLOR] & "\Picture-" & pictureNumber & ".jpg", FilterName:="jpg"
               
                
                pictureNumber = pictureNumber + 1
                
                Sht.Cells(1, 1).Activate
                Sht.ChartObjects(Sht.ChartObjects.Count).Delete
            End If
        Next
    Next Sht
    Application.ScreenUpdating = True
    
End Sub
[/LEFT]

سلام
آقا امیر دمت گرم

ولی توی فایل من چندتا عکسه که من می خوام فقط عکسی که اسمش PICTURE 7 ه رو سیو کنه


من توی سایت ماکروسافت این پیچ رو دیدم
Shape.SaveAsPicture Method (Publisher)

و این کد رو معرفی کرده

Public Sub SaveAsPicture_Example() 
 
 ThisDocument.Pages(1).Shapes(1).SaveAsPicture "filename.jpg" 
 
End Sub

مشکل من اینه که نمیدونم چطور عکسی رو که اسمش PICTURE 7 ه رو باهاش سیو کنم !
یعنی نمی دونم چطور بهش معرفی کنم؟؟

[Amir Ghasemiyan]

سلام بر دوستان عزیز من می خوام عکسی که در فایل اکسلم وجود دارد را بوسیله ی کد vb در سیستمم ذخیره کنم . کسی می دونه چطور این کار رو باید انجام بدم ؟

سلام دوست عزیز
از اونجایی که در اکسل عکس رو نمیشه به راحتی ذخیره کرد باید اول تبدیل به نمودار بشه بعد ذخیره کرد
من در اینجا روش این کار رو پیدا کردم. با کمی اصلاح مطابق نیاز شما قرار میدم.

Option Explicit


Sub ExportMyPicture()


     Dim MyChart As String, MyPicture As String
     Dim PicWidth As Long, PicHeight As Long
     
     Application.ScreenUpdating = False
     On Error GoTo Finish


     MyPicture = "Picture 7"
     With Selection
           PicHeight = .ShapeRange.Height
           PicWidth = .ShapeRange.Width
     End With
     
     Charts.Add
     ActiveChart.Location Where:=xlLocationAsObject, Name:="Sheet1"
     Selection.Border.LineStyle = 0
     MyChart = Selection.Name & " " & Split(ActiveChart.Name, " ")(2)
     
     With ActiveSheet
           With .Shapes(MyChart)
                 .Width = PicWidth
                 .Height = PicHeight
           End With
           
           .Shapes(MyPicture).Copy
           
           With ActiveChart
                 .ChartArea.Select
                 .Paste
           End With
           
           .ChartObjects(1).Chart.Export Filename:="MyPic.jpg", FilterName:="jpg"
           .Shapes(MyChart).Cut
     End With
     
     Application.ScreenUpdating = True
     Exit Sub
     
Finish:
     MsgBox "You must select a picture"
End Sub