0

有人可以帮我找出一种方法来遍历当前文件的目录并搜索文件以查看它是否存在，如果确实存在，则计算已经具有版本号的文件数并增加下一个数字，如果它不存在然后像正常一样创建文件。

基本上我有一个 vba 宏，它允许您从所有存储的“主模板”中提取幻灯片包。用户单击他们想要的包，然后将包提取并保存到同一目录中。我的问题是没有版本控制或文件保护设置。有人可以帮我弄清楚如何循环并增加版本号。

Option Explicit

Public Sub CreatePack(control As IRibbonControl)

  Dim packName As String
  Dim Count As Integer
  Select Case control.Id
    Case "packbutton_B1"
      packName = "B1"
    Case "packbutton_B2"
      packName = "B2"
    Case "packbutton_TSD"
      packName = "TSD"
  End Select

  'Note: Attempt to remove characters that are not file-system friendly
  Dim Title As String
  If ActivePresentation.Slides(1).Shapes.Count >= 9 Then
    Title = Trim(ActivePresentation.Slides(1).Shapes(9).TextEffect.Text)
    If Title = "" Then MsgBox "Warning: A project title has not been entered on Slide 1."
  Else
    Title = "(Project Title Not Known)"
    MsgBox "The title slide has been removed, the project name cannot be detected."
  End If
  Title = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Title, "/", ""), "\", ""), ":", ""), "*", ""), "<", ""), ">", ""), "|", ""), """", "")

  Dim path As String
  path = ActivePresentation.path

  If Len(Dir(path & "\" & packName & " Slide Pack - " & Title & ".pptx")) > 0 Then 'File exists

 ' If MsgBox("This will produce a pack in a separate PowerPoint file. Before extracting the pack make sure you have implemented a version number otherwise your changes maybe overwritten." & vbCrLf & vbCrLf & "Your current file will remain open, and any pending changes will not be automatically saved.", vbOKCancel, "Slide Manager - Create Pack") = vbOK Then

  MsgBox ("File exists, the file name version number will be incremented")

  CopySlidesToBlankPresentation packName

  Application.ActivePresentation.SaveAs path & "\" & packName & " Slide Pack - " & Title & Count + 1, ppSaveAsOpenXMLPresentation

  ActivePresentation.Save

  Else

  MsgBox ("This will produce a pack in a separate PowerPoint file." & vbCrLf & vbCrLf & "Your current file will remain open, and any pending changes will not be automatically saved")

  CopySlidesToBlankPresentation packName

  Application.ActivePresentation.SaveAs path & "\" & packName & " Slide Pack - " & Title, ppSaveAsOpenXMLPresentation

  ActivePresentation.Save

End If

End Sub

任何帮助是极大的赞赏！

问候，本

4

1 回答 1

1

如果我正确理解你的问题，你的循环应该是这样的

Dim fileNoVersion As String
fileNoVersion = path & "\" & packName & " Slide Pack - " & Title

Dim count As Integer
count = 1
While Dir(fileNoVersion & count & ".pptx") <> ""
    count = count + 1
Wend

这将检查哪些文件 Version1、Version2、Version3... 存在并返回下一个未使用的编号。

于 2012-07-14T13:13:50.170 回答