msmplay

回復 10# zyzzyva


   z大~~~~測試已成功，真的超級感謝的呦

msmplay

回復 10# zyzzyva


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


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

zyzzyva

回復 12# msmplay
測試看看。(不要放在根目錄如C:\下)

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

複製代碼

msmplay

回復 13# zyzzyva

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

下載 (15.52 KB)

2016-11-2 22:28

下載 (20.33 KB)

2016-11-2 22:28

zyzzyva

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

msmplay

回復 15# zyzzyva

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

zyzzyva

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

複製代碼

msmplay

回復 17# zyzzyva

z大~~真的可以了耶！謝謝你*^O^*

msmplay

回復 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

zyzzyva

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