EXCEL过河-全文件夹内xlsx另存为jpg图片

Sub 全文件夹另存为图片()
Application.DisplayAlerts = False
Dim myPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "请选择被处理文件的所在文件夹"
If .Show = -1 Then
myPath = .SelectedItems(1)
Else
Exit Sub
End If
End With
Dim fs, myfolder, myfile, myfiles
Set fs = CreateObject("Scripting.FileSystemObject")
Set myfolder = fs.GetFolder(myPath)
Set myfiles = myfolder.Files
For Each myfile In myfiles
If myfile.Type = "Microsoft Excel 工作表" Then
Workbooks.Open Filename:=myfile.Path
Dim p, f
Dim x As Range
p = myfolder ; ""
f = ActiveWorkbook.Name
Set x = Range("A2").CurrentRegion
x.Select
Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
With ActiveSheet.ChartObjects.Add(0, 0, x.Width, x.Height)
StartTime = Now()
Do
DoEvents
Loop Until CLng(DateDiff("S", StartTime, Now())) > 1
.Chart.Paste
.Chart.Export Filename:=p ; f ; ".jpg"
.Chart.Parent.Delete
End With
End If
ActiveWindow.Close
Next
Application.DisplayAlerts = True
End Sub