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

[mehdi196]

سلام بر دوستان عزیز و اساتید گرامی

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

Sub ExportImage()


Dim sFilePath AsString
Dim sView AsString

'Captures current window view
sView = ActiveWindow.View

'Sets the current view to normal so there are no "Page X" overlays on the image
ActiveWindow.View = xlNormalView

'Temporarily disable screen updating
Application.ScreenUpdating =False

Set Sheet = ActiveSheet

'Set the file path to export the image to the user's desktop
'I have to give credit to Kyle for this solution, found it here:
'http://stackoverflow.com/questions/17551238/vba-how-to-save-excel-workbook-to-desktop-regardless-of-user
sFilePath = CreateObject("W******.Shell").specialfolders("Desktop")&""& ActiveSheet.Name &".png"

'Export print area as correctly scaled PNG image, courtasy of Winand
zoom_coef =100/ Sheet.Parent.Windows(1).Zoom
Set area = Sheet.Range(Sheet.PageSetup.PrintArea)
area.CopyPicture xlPrinter
Set chartobj = Sheet.ChartObjects.Add(0,0, area.Width * zoom_coef, area.Height * zoom_coef)
chartobj.Chart.Paste
chartobj.Chart.Export sFilePath,"png"
chartobj.Delete

'Returns to the previous view
ActiveWindow.View = sView

'Re-enables screen updating
Application.ScreenUpdating =True

'Tells the user where the image was saved
MsgBox ("Export completed! The file can be found here:"& Chr(10)& Chr(10)& sFilePath)

EndSub


ولی تنها ایرادش اینه که تمام فایلهای یک صفحه را فقط با نام صفحه ذخیره میکنه که باعث OVERWRITE میشود. در صورتی که من میخوام علاوه بر نام شیت ،
تاریخ و ساعت پرینت هم بدنبال آن نوشته شود. اینجوری پرینت هایی که از یک شیت گرفته میشود بعلت تغییر تاریخ و ساعت پرینت،
همنام نخواهند شد در نتیجه OVERWRITE نمیشوند.




قبلأ یه کد برای PDF کردن صفحه استفاده میکردم که این قابلیت رو داشت.

Sub PDFActiveSheet()
'www.contextures.com
'for Excel 2010 and later
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
On Error GoTo errHandler


Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
strTime = Format(Now(), "yyyymmdd\_hhmm")


'get active workbook folder, if saved
strPath = wbA.Path
If strPath = "" Then
strPath = Application.DefaultFilePath
End If
strPath = strPath & ""


'replace spaces and periods in sheet name
strName = Replace(wsA.Name, " ", "")
strName = Replace(strName, ".", "_")


'create default name for savng file
strFile = strName & "_" & strTime & ".pdf"
strPathFile = strPath & strFile


'use can enter name and
' select folder for file
myFile = Application.GetSaveAsFilename _
(InitialFileName:=strPathFile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and FileName to save")


'export to PDF if a folder was selected
If myFile <> "False" Then
wsA.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=myFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
'confirmation message with file info
MsgBox "PDF file has been created: " _
& vbCrLf _
& myFile
End If


exitHandler:
Exit Sub
errHandler:
MsgBox "Could not create PDF file"
Resume exitHandler
End Sub




لطفأ اساتید گرامی راهنمایی بفرمایید.

ارادت...

[Amir Ghasemiyan]

سلام دوست عزيز

شما ميتونين اين كد رو

sFilePath = CreateObject("W******.Shell").specialfolders("Desktop") & "\" & ActiveSheet.Name & ".png"

با كد زير جابجا كنيد:

strTime = Format(Now(), "yyyymmdd\_hhmm")


sFilePath = CreateObject("W******.Shell").specialfolders("Desktop") & "\" & ActiveSheet.Name & "-" & strTime & ".png"

[mehdi196]

از پاسخگویی شما بسیار سپاسگزارم
ولی بعد از اجرا این ارور میده..

[Amir Ghasemiyan]

از اين كد استفاده بفرماييد

Sub ExportImage()




Dim sFilePath As String
Dim sView As String


'Captures current window view
sView = ActiveWindow.View


'Sets the current view to normal so there are no "Page X" overlays on the image
ActiveWindow.View = xlNormalView


'Temporarily disable screen updating
Application.ScreenUpdating =False


Set Sheet = ActiveSheet


'Set the file path to export the image to the user's desktop
'I have to give credit to Kyle for this solution, found it here:
'http://stackoverflow.com/questions/17551238/vba-how-to-save-excel-workbook-to-desktop-regardless-of-user
strTime = Format(Now(), "yyyymmdd\_hhmm")
sFilePath = CreateObject("Wscrip t.Shell").specialfolders("Desktop") & "\" & ActiveSheet.Name & "-" & strTime & ".png"


'Export print area as correctly scaled PNG image, courtasy of Winand
zoom_coef =100/ Sheet.Parent.Windows(1).Zoom
Set area = Sheet.Range(Sheet.PageSetup.PrintArea)
area.CopyPicture xlPrinter
Set chartobj = Sheet.ChartObjects.Add(0,0, area.Width * zoom_coef, area.Height * zoom_coef)
chartobj.Chart.Paste
chartobj.Chart.Export sFilePath,"png"
chartobj.Delete


'Returns to the previous view
ActiveWindow.View = sView


'Re-enables screen updating
Application.ScreenUpdating =True


'Tells the user where the image was saved
MsgBox ("Export completed! The file can be found here:"& Chr(10)& Chr(10)& sFilePath)


End Sub

دقت كنيد كه در خط 22 فاصله بين اين عبارت را حذف كنيد.
"Wscrip t.Shell"

[mehdi196]

بسیار بسیار ممنونم برادر عزیز و دلسوز... واقعأ کارم راه انداختی .. خدا خیرت بده ...