返回列表 上一主題 發帖

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

zyzzyva

帖子
109 
主題
1 
精華
0 
積分
116 
點名
0  
作業系統
win7 
軟體版本
2007 
閱讀權限
20 
註冊時間
2016-8-4 
最後登錄
2018-10-22 

論壇榮譽勳章論壇贊助勳章
1# 跳轉到 »
發表於 2016-8-21 00:21 | 顯示全部帖子
回復 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

帖子
109 
主題
1 
精華
0 
積分
116 
點名
0  
作業系統
win7 
軟體版本
2007 
閱讀權限
20 
註冊時間
2016-8-4 
最後登錄
2018-10-22 

論壇榮譽勳章論壇贊助勳章
2#
發表於 2016-8-21 00:38 | 顯示全部帖子
本帖最後由 zyzzyva 於 2016-8-21 00:40 編輯

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

TOP

zyzzyva

帖子
109 
主題
1 
精華
0 
積分
116 
點名
0  
作業系統
win7 
軟體版本
2007 
閱讀權限
20 
註冊時間
2016-8-4 
最後登錄
2018-10-22 

論壇榮譽勳章論壇贊助勳章
3#
發表於 2016-8-21 00:54 | 顯示全部帖子
本帖最後由 zyzzyva 於 2016-8-21 00:56 編輯

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

TOP

zyzzyva

帖子
109 
主題
1 
精華
0 
積分
116 
點名
0  
作業系統
win7 
軟體版本
2007 
閱讀權限
20 
註冊時間
2016-8-4 
最後登錄
2018-10-22 

論壇榮譽勳章論壇贊助勳章
4#
發表於 2016-8-21 09:50 | 顯示全部帖子
回復 6# msmplay
後來想了一下，如果沒有一定要用SaveCopyAs的原因，用l大的方式直接SaveAs比較好。
不過最好還是加個if判斷，不然如果關閉的時候選否，備份還是會執行，原來正確的備份就被蓋掉了。
拿網路上跟l大的code組合改了一下，您再參考看看。
  1. Private Sub Workbook_BeforeClose(Cancel As Boolean)
  2.     Dim mypath As String, fname As String

  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 = ThisWorkbook.Path & "\備份\"
  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. End Sub
複製代碼

TOP

zyzzyva

帖子
109 
主題
1 
精華
0 
積分
116 
點名
0  
作業系統
win7 
軟體版本
2007 
閱讀權限
20 
註冊時間
2016-8-4 
最後登錄
2018-10-22 

論壇榮譽勳章論壇贊助勳章
5#
發表於 2016-11-2 21:21 | 顯示全部帖子
回復 12# msmplay
測試看看。(不要放在根目錄如C:\下)
  1. Private Sub Workbook_BeforeClose(Cancel As Boolean)
  2.     Dim mypath As String, fname As String

  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

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

TOP

zyzzyva

帖子
109 
主題
1 
精華
0 
積分
116 
點名
0  
作業系統
win7 
軟體版本
2007 
閱讀權限
20 
註冊時間
2016-8-4 
最後登錄
2018-10-22 

論壇榮譽勳章論壇贊助勳章
6#
發表於 2016-11-3 08:49 | 顯示全部帖子
回復 14# msmplay
對阿，是唯讀屬性的問題。如果希望之後還可以直接存檔，可能存檔前要加個檢查，如果屬性已經是唯讀，就改回一般(vbNormal)

TOP

zyzzyva

帖子
109 
主題
1 
精華
0 
積分
116 
點名
0  
作業系統
win7 
軟體版本
2007 
閱讀權限
20 
註冊時間
2016-8-4 
最後登錄
2018-10-22 

論壇榮譽勳章論壇贊助勳章
7#
發表於 2016-11-3 09:24 | 顯示全部帖子
回復 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.    

  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

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

TOP

zyzzyva

帖子
109 
主題
1 
精華
0 
積分
116 
點名
0  
作業系統
win7 
軟體版本
2007 
閱讀權限
20 
註冊時間
2016-8-4 
最後登錄
2018-10-22 

論壇榮譽勳章論壇贊助勳章
8#
發表於 2016-11-6 16:06 | 顯示全部帖子
回復 19# msmplay
應該只是多了一個\，改成mypath = ThisWorkbook.Path & "\備份"試試看。

TOP

        靜思自在 : 一句溫暖的話，就像往別人身上灑香水，自己會沾到兩三滴。
返回列表 上一主題