返回列表 上一主題 發帖

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

回復 10# zyzzyva


   z大~~~~測試已成功,真的超級感謝的呦
*宅女一枚無誤*

TOP

本帖最後由 msmplay 於 2016-11-2 20:02 編輯

回復 10# zyzzyva


   z大~~可以請教兩個延伸的問題嗎?
就是如果自動備份位置希望改為檔案的上層資料夾,該如何修改呢?
例如:檔案 放於 C:\Users\Downloads\測試,希望自動備份檔案於 C:\Users\Downloads


另外如果希望自動備份的檔案固定存為唯讀檔,又該如何修改呢?
例如: 測試檔.xlsm 存檔時自動備份為 測試檔.xlsx(唯讀)
*宅女一枚無誤*

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

本帖最後由 msmplay 於 2016-11-2 22:33 編輯

回復 13# zyzzyva

   z大~~~~~測試後,發現第一次存檔成功,但第二次要再存檔就會出現以下錯誤,是不是因為唯讀檔無法覆蓋問題呢??

2.PNG
2016-11-2 22:28
1.PNG
2016-11-2 22:28
*宅女一枚無誤*

TOP

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

TOP

回復 15# zyzzyva

z大~~~~那請問可以存檔即覆蓋舊檔嗎?也就是無論如何,原始檔只要存檔就是要覆蓋備份唯讀檔,可以醬嗎?又該如何修改呢?真的非常感謝~~~~~~
*宅女一枚無誤*

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

本帖最後由 msmplay 於 2016-11-3 12:45 編輯

回復 17# zyzzyva

z大~~真的可以了耶!謝謝你*^O^*
*宅女一枚無誤*

TOP

回復 17# zyzzyva

z大~~~~結果公司又要將備份檔改放於像之前寫的那樣,放在檔案下一層備份資料夾內mypath = ThisWorkbook.Path & "\備份\"


結果我嘗試改了一下但都不對,可以再麻煩您嗎~~~~
紅色是我自己亂改的


  • Private Sub Workbook_BeforeClose(Cancel As Boolean)
  •     Dim mypath As String, fname As String
  •     fname = "\自動備份" & Format(Date, "yymmdd") & ".xlsx"
  •     mypath = ThisWorkbook.Path & "\備份\"
  •     Targetfile = mypath & fname
  •     If Not Me.Saved Then
  •         Msg = "Do you want to save the changes you made to "
  •         Msg = Msg & Me.Name & "?"
  •         Ans = MsgBox(Msg, vbQuestion + vbYesNoCancel)
  •         Select Case Ans
  •             Case vbYes
  •                 Me.Save
  •             Case vbNo
  •                 Me.Saved = False
  •             Case vbCancel
  •                 Cancel = True
  •                 Exit Sub
  •           End Select
  •     End If
  •     If Me.Saved Then
  •         Application.DisplayAlerts = False '關閉系統警告訊息
  •         'ThisWorkbook.Save '要儲存自身檔案,請自行選擇要不要儲存
  •         If Dir(Targetfile) <> "" Then
  •             If GetAttr(Targetfile) And vbReadOnly Then
  •                 SetAttr Targetfile, vbNormal
  •             End If
  •         End If
  •         ThisWorkbook.SaveAs mypath & fname, FileFormat:=xlOpenXMLWorkbook
  •         Application.DisplayAlerts = True '開啟系統警告訊息
  •     Else
  •         Me.Saved = True
  •     End If
  •     If Dir(Targetfile) <> "" Then
  •         If GetAttr(Targetfile) Then
  •             SetAttr Targetfile, vbReadOnly
  •         End If
  •     End If
  • End Sub
*宅女一枚無誤*

TOP

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

TOP

        靜思自在 : 【停滯不前,終無所得】人都迷於尋找奇蹟,因而停滯不前;縱使時間再多、路再長,也了無用處,終無所得。
返回列表 上一主題