خروجی از عکس در اکسل

[kazem1359]

سلام یک فایل اکسل دارم که در یکی از شیتها چندتا عکس دارم چطور می تونم با ماکرو یک خروجی با نمایش نه پرینت از عکسها داشته باشم و هر عکسی در یک صفحه باشه؟ ممنون

[kazem1359]

با سلام در فایل زیر با انتخاب یک محدوده می توان خروجی به صورت عکس دریافت کرد حالا چطور میشه تغییرات زیر را توی ماکرو بدیم :

نمی خواهیم محدوده ای انتخاب کنیم به جای محدوده ، عکسی که در شیت هست انتخاب بشه و به صورت عکس دریافت بشه همین///
ممنون
http://s10.picofile.com/file/8405861134/ConvertToJPG.xlsm.html

[M_ExceL]

سلام،
بررسی کنید
تصویر در مسیر دسکتاپ و داخل پوشه test ذخیره می شود

Sub M_ExceL()
Dim shp As Shape
sPath = Environ("USERPROFILE") & "\Desktop\test"
Folder = Dir(sPath, vbDirectory)
If Folder = vbNullString Then
MkDir (sPath)
End If
strImageName = "test"
Set shp = ActiveSheet.Shapes("Picture 1")
shp.Select
Selection.ShapeRange.PictureFormat.Contrast = 0.5
Selection.ShapeRange.PictureFormat.Brightness = 0.5
Selection.ShapeRange.PictureFormat.ColorType = msoPictureAutomatic
Selection.ShapeRange.PictureFormat.TransparentBack ground = msoFalse
Selection.ShapeRange.Fill.Visible = msoFalse
Selection.ShapeRange.Line.Visible = msoFalse
Selection.ShapeRange.Rotation = 0#
Selection.ShapeRange.PictureFormat.CropLeft = 0#
Selection.ShapeRange.PictureFormat.CropRight = 0#
Selection.ShapeRange.PictureFormat.CropTop = 0#
Selection.ShapeRange.PictureFormat.CropBottom = 0#
Selection.ShapeRange.ScaleHeight 1#, msoTrue, msoScaleFromTopLeft
Selection.ShapeRange.ScaleWidth 1#, msoTrue, msoScaleFromTopLeft
Application.Selection.CopyPicture
Set oDia = ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height)
Set oChartArea = oDia.Chart
oDia.Activate
With oChartArea
.ChartArea.Select
.Paste
.Export (sPath & "\" & strImageName & ".jpg")
End With
oDia.Delete
End Sub

[kazem1359]

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

[M_ExceL]

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

ActiveWorkbook.Path
مسیر فایل را بر می گرداند

[kazem1359]

سلام ممنون میشه بگین کجای کد اصلی قرار بدم؟

[M_ExceL]

سلام ممنون میشه بگین کجای کد اصلی قرار بدم؟
سلام،


Sub M_ExceL()
Dim shp As Shape
sPath = ActiveWorkbook.Path
strImageName = "test"
Set shp = ActiveSheet.Shapes("Picture 1")
shp.Select
Selection.ShapeRange.PictureFormat.Contrast = 0.5
Selection.ShapeRange.PictureFormat.Brightness = 0.5
Selection.ShapeRange.PictureFormat.ColorType = msoPictureAutomatic
Selection.ShapeRange.PictureFormat.TransparentBack ground = msoFalse
Selection.ShapeRange.Fill.Visible = msoFalse
Selection.ShapeRange.Line.Visible = msoFalse
Selection.ShapeRange.Rotation = 0#
Selection.ShapeRange.PictureFormat.CropLeft = 0#
Selection.ShapeRange.PictureFormat.CropRight = 0#
Selection.ShapeRange.PictureFormat.CropTop = 0#
Selection.ShapeRange.PictureFormat.CropBottom = 0#
Selection.ShapeRange.ScaleHeight 1#, msoTrue, msoScaleFromTopLeft
Selection.ShapeRange.ScaleWidth 1#, msoTrue, msoScaleFromTopLeft
Application.Selection.CopyPicture
Set oDia = ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height)
Set oChartArea = oDia.Chart
oDia.Activate
With oChartArea
.ChartArea.Select
.Paste
.Export (sPath & "\" & strImageName & ".jpg")
End With
oDia.Delete
End Sub

[kazem1359]

ممنون وسپاس مشکل حل شد