Sub Test()
Dim oFldr As String
Dim nm As Name
Dim rng As Range
oFldr = GetFolder(ActiveWorkbook.Path)
If oFldr = "" Then
MsgBox "Cancelled", vbExclamation
Else
For Each nm In ActiveWorkbook.Names
On Error Resume Next
'If Left(nm.Name, 1) = "P" And Not InStr(1, nm.RefersTo, "#REF!") > 0 Then
Set rng = Range(nm.RefersTo)
rng.Parent.Activate
ActiveWindow.View = xlNormalView
Call ExportRangeAsPictureFile(rng, oFldr & "\" & nm.Name & ".jpg")
ActiveWindow.View = xlPageBreakPreview
Set rng = Nothing
On Error GoTo 0
'End If
Next nm
End If
End Sub
Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select Folder To Export All Of The Figures To"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show = True Then sItem = .SelectedItems(1)
End With
GetFolder = sItem
Set fldr = Nothing
End Function
Function ExportRangeAsPictureFile(rExport As Range, sExport As String) As Boolean
Dim dh As Double
Dim dw As Double
dh = 1: dw = 1
On Error Resume Next
Kill sExport
On Error GoTo 0
If rExport Is Nothing Then GoTo exit_Func
rExport.CopyPicture appearance:=xlScreen, Format:=xlBitmap
With ActiveSheet.ChartObjects.Add(Left:=rExport.Left, Top:=rExport.Top, Width:=rExport.Width + dw, Height:=rExport.Height + dh)
DoEvents
With .Chart
Do Until .Pictures.Count = 1
DoEvents: .Paste
Loop
.ChartArea.Format.Line.Visible = msoFalse
.Export sExport
ExportRangeAsPictureFile = True
End With
.Delete
End With
exit_Func:
End Function
تحميل محتوى الموضوع
عرض نسخة صالحة للطباعة
أرسل هذا الموضوع إلى صديق
