Question

我尝试了不同的代码，但我不能使用正确的输出。我想要一个可以选择文件位置的代码。一切正常，我只需要将PNG保存到保存时选择的文件位置。我只得到以下内容：

FName = "C:\Users\Desktop\Nutrifacts and Analysis-Save\1.png"

Sub picsave_Click()

Dim pic_rng As Range
Dim ShTemp As Worksheet
Dim ChTemp As Chart
Dim PicTemp As Picture
Dim FName As String


FName = "C:\Users\Desktop\Nutrifacts and Analysis-Save\1.png"



Application.ScreenUpdating = False

ThisWorkbook.Windows(1).DisplayGridlines = False

Set pic_rng = Worksheets(1).Range("A1:R31")
Set ShTemp = Worksheets.Add
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:=ShTemp.Name
Set ChTemp = ActiveChart
pic_rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture

 With ThisWorkbook.Sheets(1)
 ActiveSheet.Shapes.Item(1).Line.Visible = msoFalse
 ActiveSheet.Shapes.Item(1).Width = .Range("A1:R31").Width
 ActiveSheet.Shapes.Item(1).Height = .Range("A1:R31").Height
End With

ChTemp.Paste
ChTemp.Export fileName:=FName, Filtername:="png"

  Application.DisplayAlerts = False
  ShTemp.Delete
 Application.DisplayAlerts = True

 ThisWorkbook.Windows(1).DisplayGridlines = True

Application.ScreenUpdating = True

Set ShTemp = Nothing
Set ChTemp = Nothing
Set PicTemp = Nothing



MsgBox ("Done.")

   End Sub

Answer 1

请尝试以下操作。添加了varResult变量以获取文件名。您可以根据需要进行更改。使用Application.GetSaveAsFilename获取文件名。

Sub test()

Dim pic_rng As Range
Dim ShTemp As Worksheet
Dim ChTemp As Chart
Dim PicTemp As Picture
Dim FName As String
Dim varResult As Variant

On Error Resume Next
FName = "C:\Users\Desktop\Nutrifacts and Analysis-Save\1.png"

'displays the save file dialog
varResult = Application.GetSaveAsFilename(FileFilter:="PNG (*.png), *.png")
If varResult = False Then
  Exit Sub ' do what you want
Else
  FName = varResult
End If

Application.ScreenUpdating = False

ThisWorkbook.Windows(1).DisplayGridlines = False

Set pic_rng = Worksheets(1).Range("A1:R31")
Set ShTemp = Worksheets.Add
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:=ShTemp.Name
Set ChTemp = ActiveChart
pic_rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture

With ThisWorkbook.Sheets(1)
     ActiveSheet.Shapes.Item(1).Line.Visible = msoFalse
     ActiveSheet.Shapes.Item(1).Width = .Range("A1:R31").Width
     ActiveSheet.Shapes.Item(1).Height = .Range("A1:R31").Height
End With


ChTemp.Paste
ChTemp.Export Filename:=FName, Filtername:="png"

Application.DisplayAlerts = False
ShTemp.Delete
Application.DisplayAlerts = True

ThisWorkbook.Windows(1).DisplayGridlines = True

Application.ScreenUpdating = True

Set ShTemp = Nothing
Set ChTemp = Nothing
Set PicTemp = Nothing

MsgBox ("Done.")

End Sub

VBA Excel代码将图片保存为PNG到文件位置

1 个答案: