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

[amin.t]

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

[amir_ts]

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



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:="C:\Users\User\Desktop" & "\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

[amin.t]

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



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:="C:\Users\User\Desktop" & "\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





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

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


من توی سایت ماکروسافت این پیچ رو دیدم
Shape.SaveAsPicture Method (Publisher) (https://msdn.microsoft.com/en-us/library/office/ff939209.aspx)

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


Public Sub SaveAsPicture_Example()

ThisDocument.Pages(1).Shapes(1).SaveAsPicture "filename.jpg"

End Sub



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

[Amir Ghasemiyan]

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

سلام دوست عزیز
از اونجایی که در اکسل عکس رو نمیشه به راحتی ذخیره کرد باید اول تبدیل به نمودار بشه بعد ذخیره کرد
من در اینجا (http://xlvba.fr.yuku.com/topic/207#.VxXhnzB97ct) روش این کار رو پیدا کردم. با کمی اصلاح مطابق نیاز شما قرار میدم.


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