☰

VBA 脚本宏保存到特定位置

tag-icon • tag-icon file-location
VBA 脚本宏保存到特定位置

如何改变以下脚本以便它保存到特定文件夹而不是询问？

Sub Saveaspdfandsend()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range

Set xSht = ActiveSheet
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

If xFileDlg.Show = True Then
   xFolder = xFileDlg.SelectedItems(1)
Else
   MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
   Exit Sub
End If
xFolder = xFolder + "\" + xSht.Name + Format(Now, " yyyy-mm-dd hmmAM/PM") + ".pdf"

'Check if file already exist
If Len(Dir(xFolder)) > 0 Then
    xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
                      vbYesNo + vbQuestion, "File Exists")
    On Error Resume Next
    If xYesorNo = vbYes Then
        Kill xFolder
    Else
        MsgBox "if you don't overwrite the existing PDF, I can't continue." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
        Exit Sub
    End If
    If Err.Number <> 0 Then
        MsgBox "Unable to delete existing file.  Please make sure the file is not open or write protected." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
        Exit Sub
    End If
End If

Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
    'Save as PDF file
    xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard

    'Create Outlook email
    Set xOutlookObj = CreateObject("Outlook.Application")
    Set xEmailObj = xOutlookObj.CreateItem(0)
    With xEmailObj
        .Display
        .To = ""
        .CC = "[email protected]"
        .Subject = xSht.Name + ".pdf"
        .Attachments.Add xFolder
        If DisplayEmail = False Then
            '.Send
        End If
    End With
Else
  MsgBox "The active worksheet cannot be blank"
  Exit Sub
End If
End Sub

感谢迈克尔

答案1

您可以看到所选项目被放入名为文件夹. 注释掉关于 xFileDlg 的部分直到 xFolder 附加到的部分。

将其更改为您想要的任何内容：

xFolder = xFolder + "\" + xSht.Name + Format(Now, " yyyy-mm-dd hmmAM/PM") + ".pdf"

答案2

您必须选择文件夹的唯一原因就是这部分......

设置 xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

如果 xFileDlg.Show = True 则 xFolder = xFileDlg.SelectedItems(1) 否则 MsgBox "您必须指定一个文件夹来保存 PDF。" & vbCrLf & vbCrLf & "按 OK 退出此宏。", vbCritical, "必须指定目标文件夹" Exit Sub End If

如果您每次都想选择文件夹或需要创建新文件夹，那么这种方法就很好了。但如果文件夹已存在，而您总是要将其保存到同一位置，那么只需删除上述部分，然后手动添加文件夹位置即可。

例如：
xFolder = “C:\MyPDFs” + “\” + xSht.Name + Format(Now, “ yyyy-mm-dd hmmAM/PM”) + “.pdf”

相关内容