返回列表 上一主題 發帖

[發問] 存檔時自動備份檔案並轉為.xlsx格式

回復 1# msmplay
SaveCopyAs好像沒辦法指定格式。沒想到更好的辦法,這個試試看。
  1. Private Sub Workbook_BeforeClose(Cancel As Boolean)
  2.     On Error Resume Next
  3.     Dim mypath As String, fname As String
  4.    
  5.     If Me.Saved = True Then
  6.         fname = "自動備份" & Format(Date, "yymmdd")
  7.         mypath = ThisWorkbook.Path & "/備份/"
  8.         ThisWorkbook.SaveCopyAs mypath & fname & ".xlsm"
  9.         
  10.         Workbooks.Open (mypath & fname & ".xlsm")
  11.         Application.DisplayAlerts = False
  12.         ActiveWorkbook.SaveAs mypath & fname, FileFormat:=51
  13.         Application.DisplayAlerts = True
  14.         ActiveWorkbook.Close
  15.         Kill (mypath & fname & ".xlsm")
  16.     End If
  17.    
  18. End Sub
複製代碼

TOP

本帖最後由 zyzzyva 於 2016-8-21 00:40 編輯

3F的code有點bug,一定要先存檔再關閉才有用,如果是在對話視窗出來再按「是」存檔就不會作用。
應該是事件觸發先後的問題,要再修改一下。

TOP

本帖最後由 zyzzyva 於 2016-8-21 00:56 編輯

回復 6# msmplay
怪怪,我用空白的測沒有這個問題,可以先在kill下一行加個ActiveWorkbook.Save,bug明天有空再研究。

TOP

回復 6# msmplay
後來想了一下,如果沒有一定要用SaveCopyAs的原因,用l大的方式直接SaveAs比較好。
不過最好還是加個if判斷,不然如果關閉的時候選否,備份還是會執行,原來正確的備份就被蓋掉了。
拿網路上跟l大的code組合改了一下,您再參考看看。
  1. Private Sub Workbook_BeforeClose(Cancel As Boolean)
  2.     Dim mypath As String, fname As String

  3.     If Not Me.Saved Then
  4.         Msg = "Do you want to save the changes you made to "
  5.         Msg = Msg & Me.Name & "?"
  6.         Ans = MsgBox(Msg, vbQuestion + vbYesNoCancel)
  7.         Select Case Ans
  8.             Case vbYes
  9.                 Me.Save
  10.             Case vbNo
  11.                 Me.Saved = False
  12.             Case vbCancel
  13.                 Cancel = True
  14.                 Exit Sub
  15.           End Select
  16.     End If
  17.    
  18.     If Me.Saved Then
  19.         Application.DisplayAlerts = False '關閉系統警告訊息
  20.         fname = "自動備份" & Format(Date, "yymmdd") & ".xlsx"
  21.         mypath = ThisWorkbook.Path & "\備份\"
  22.         'ThisWorkbook.Save '要儲存自身檔案,請自行選擇要不要儲存
  23.         ThisWorkbook.SaveAs mypath & fname, FileFormat:=xlOpenXMLWorkbook
  24.         Application.DisplayAlerts = True '開啟系統警告訊息
  25.     Else
  26.         Me.Saved = True
  27.     End If
  28.       
  29. End Sub
複製代碼

TOP

回復 12# msmplay
測試看看。(不要放在根目錄如C:\下)
  1. Private Sub Workbook_BeforeClose(Cancel As Boolean)
  2.     Dim mypath As String, fname As String

  3.     If Not Me.Saved Then
  4.         Msg = "Do you want to save the changes you made to "
  5.         Msg = Msg & Me.Name & "?"
  6.         Ans = MsgBox(Msg, vbQuestion + vbYesNoCancel)
  7.         Select Case Ans
  8.             Case vbYes
  9.                 Me.Save
  10.             Case vbNo
  11.                 Me.Saved = False
  12.             Case vbCancel
  13.                 Cancel = True
  14.                 Exit Sub
  15.           End Select
  16.     End If
  17.    
  18.     If Me.Saved Then
  19.         Application.DisplayAlerts = False '關閉系統警告訊息
  20.         fname = "\自動備份" & Format(Date, "yymmdd") & ".xlsx"
  21.         mypath = Left(ThisWorkbook.Path, InStrRev(ThisWorkbook.Path, "\") - 1)
  22.         'ThisWorkbook.Save '要儲存自身檔案,請自行選擇要不要儲存
  23.         ThisWorkbook.SaveAs mypath & fname, FileFormat:=xlOpenXMLWorkbook
  24.         Application.DisplayAlerts = True '開啟系統警告訊息
  25.     Else
  26.         Me.Saved = True
  27.     End If
  28.    
  29.     Targetfile = mypath & fname

  30.     If GetAttr(Targetfile) Then
  31.         SetAttr Targetfile, vbReadOnly
  32.     End If
  33.       
  34. End Sub
複製代碼

TOP

回復 14# msmplay
對阿,是唯讀屬性的問題。如果希望之後還可以直接存檔,可能存檔前要加個檢查,如果屬性已經是唯讀,就改回一般(vbNormal)

TOP

回復 16# msmplay
改了一下,應該可以,再試試看。
  1. Private Sub Workbook_BeforeClose(Cancel As Boolean)
  2.     Dim mypath As String, fname As String
  3.    
  4.     fname = "\自動備份" & Format(Date, "yymmdd") & ".xlsx"
  5.     mypath = Left(ThisWorkbook.Path, InStrRev(ThisWorkbook.Path, "\") - 1)
  6.     Targetfile = mypath & fname
  7.    

  8.     If Not Me.Saved Then
  9.         Msg = "Do you want to save the changes you made to "
  10.         Msg = Msg & Me.Name & "?"
  11.         Ans = MsgBox(Msg, vbQuestion + vbYesNoCancel)
  12.         Select Case Ans
  13.             Case vbYes
  14.                 Me.Save
  15.             Case vbNo
  16.                 Me.Saved = False
  17.             Case vbCancel
  18.                 Cancel = True
  19.                 Exit Sub
  20.           End Select
  21.     End If
  22.    
  23.     If Me.Saved Then
  24.         Application.DisplayAlerts = False '關閉系統警告訊息
  25.         'ThisWorkbook.Save '要儲存自身檔案,請自行選擇要不要儲存
  26.         If Dir(Targetfile) <> "" Then
  27.             If GetAttr(Targetfile) And vbReadOnly Then
  28.                 SetAttr Targetfile, vbNormal
  29.             End If
  30.         End If
  31.         ThisWorkbook.SaveAs mypath & fname, FileFormat:=xlOpenXMLWorkbook
  32.         Application.DisplayAlerts = True '開啟系統警告訊息
  33.     Else
  34.         Me.Saved = True
  35.     End If

  36.     If Dir(Targetfile) <> "" Then
  37.         If GetAttr(Targetfile) Then
  38.             SetAttr Targetfile, vbReadOnly
  39.         End If
  40.     End If
  41.       
  42. End Sub
複製代碼

TOP

回復 19# msmplay
應該只是多了一個\,改成mypath = ThisWorkbook.Path & "\備份"試試看。

TOP

        靜思自在 : 有時當思無時苦,好天要積雨來糧。
返回列表 上一主題