Question

有人可以帮我一个方法来循环浏览当前文件的目录并搜索该文件以查看它是否存在，如果确实如此，则计算已经具有版本号的文件数并增加下一个数字，如果它不存在则按正常方式创建文件。

基本上我有一个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

非常感谢任何帮助！

此致本

Answer 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

这将检查哪些文件存在版本1，版本2，版本3 ...并返回下一个未使用的编号。

循环访问文件目录以检查文件是否存在，如果它确实增加版本号，则不创建新文件

1 个答案: