1

这是这个问题的后续，Lock Cells after Data Entry。我从问这个问题取得了进展，但遇到了更多问题，所以我觉得我应该问一个新问题。工作簿由多个用户编辑。为了防止篡改以前的数据，一旦输入数据并保存文件，单元格就会被锁定。

我在代码中有几个小错误：

  1. 如果用户选择SaveAs然后尝试保存现有文件通常的“您要替换此文件吗？” 对话框出现。如果用户选择否，则会出现运行时错误。我在下面的代码中突出显示了错误的位置，但我不确定如何修复它。

  2. 如果用户已输入数据，则尝试退出并使用关闭时出现的保存对话框保存文件，文件已保存但数据未锁定。我一直在尝试调用我的主代码以在退出保存时锁定单元格，但我一直遇到参数而不是可选错误。

这是完整的代码：

Option Explicit
Const WelcomePage = "Macros"
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'Written by Alistair Weir (alistair.weir@communitypharmacyscotland.org.uk, http://alistairweir.blogspot.co.uk/)

Dim ws As Worksheet
Dim wsActive As Worksheet
Dim vFilename As Variant
Dim bSaved As Boolean

'Turn off screen updating
With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With

'Record active worksheet
Set wsActive = ActiveSheet

'Prompt for Save As
If SaveAsUI = True Then
    MsgBox "Are you sure you want to save? Data entered cannot be edited once the file has been saved. Press cancel on the next screen to edit your data or continue if you are sure it is correct.", vbCritical, "Are you sure?"

    vFilename = Application.GetSaveAsFilename("", fileFilter:="Excel Files (*.xls), *.xls")
    If CStr(vFilename) = "False" Then
        bSaved = False
    Else
        'Save the workbook using the supplied filename
        Call HideAllSheets
        '--> The vFilename Variant in the next line is the problem **
        '--> when trying to overwrite an existing file  **
        ThisWorkbook.SaveAs vFilename
        Application.RecentFiles.Add vFilename
        Call ShowAllSheets
        bSaved = True
    End If
Else
    'Save the workbook, prompt if normal save selected not save As
    Call HideAllSheets
    If MsgBox("Are you sure you want to save? Data entered cannot be edited after saving", vbYesNo, "Save?") = vbYes Then
        ThisWorkbook.Save
        Call ShowAllSheets
        bSaved = True
        Else
        Cancel = True
    End If
    Call ShowAllSheets
End If

'Restore file to where user was
wsActive.Activate
'Restore screen updates
With Application
    .ScreenUpdating = True
    .EnableEvents = True
End With

'Set application states appropriately
If bSaved Then
    ThisWorkbook.Saved = True
    Cancel = True
Else
    Cancel = True
End If

'Lock Cells before save if data has been entered
    Dim rpcell As Range
With ActiveSheet
    If bSaved = True Then
    .Unprotect Password:="oVc0obr02WpXeZGy"
    .Cells.Locked = False
    For Each rpcell In ActiveSheet.UsedRange
        If rpcell.Value = "" Then
            rpcell.Locked = False
        Else
            rpcell.Locked = True
        End If
    Next rpcell
    .Protect Password:="oVc0obr02WpXeZGy"
    Else
    MsgBox "The LogBook was not saved. You are free to edit the RP Log again", vbOKOnly, "LogBook Not Saved"
    End If
End With

End Sub

Private Sub Workbook_Open()
    Application.ScreenUpdating = False
    Call ShowAllSheets
    Application.ScreenUpdating = True
    ThisWorkbook.Saved = True
End Sub

'Called to hide all the sheets but enable macros page
Private Sub HideAllSheets()
    Dim ws As Worksheet
    Worksheets(WelcomePage).Visible = xlSheetVisible
    For Each ws In ThisWorkbook.Worksheets
        If Not ws.Name = WelcomePage Then ws.Visible = xlSheetVeryHidden
    Next ws
    Worksheets(WelcomePage).Activate
End Sub

'Called to show the data sheets when macros are enabled
Private Sub ShowAllSheets()
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        If Not ws.Name = WelcomePage Then ws.Visible = xlSheetVisible
    Next ws
    Worksheets(WelcomePage).Visible = xlSheetVeryHidden
End Sub

谢谢 ：）

编辑

现在我正在通过绕过 excel 的默认“你想保存吗？”来解决问题 2。通过做这个：

Private Sub Workbook_BeforeClose(Cancel As Boolean)

    If MsgBox("Are you sure you want to quit? Any unsaved changes will be lost.", vbYesNo, "Really quit?") = vbNo Then
    Cancel = True
    Else
    ThisWorkbook.Saved = True
    Application.Quit
    End If

End Sub

我愿意接受更好方法的建议，但仍然没有解决第一个问题。

4

1 回答 1

1

一种可能性是在保存函数中编写自己的确认，如下所示：

Private Function SaveSheet(Optional fileName) As Boolean

HideAllSheets

If fileName = "" Then
    ThisWorkbook.Save
    SaveSheet = True
Else
    Application.DisplayAlerts = False

    If Dir(fileName) <> "" Then
        If MsgBox("Worksheet exists. Overwrite?", vbYesNo, "Exists") = vbNo Then Exit Function
    End If

    ThisWorkbook.saveAs fileName
    SaveSheet = True

    Application.DisplayAlerts = True
End If

ShowAllSheets

End Function

并将您的原始代码更改为：

If SaveAsUI Then
    If MsgBox( _
        "Are you sure you want to save? Data entered cannot be edited once the file has been saved. " & _
        "Press cancel on the next screen to edit your data or continue if you are sure it is correct.", _
        vbYesNo, "Are you sure?" _
    ) = vbYes Then
        vFilename = Application.GetSaveAsFilename("", fileFilter:="Excel Files (*.xls), *.xls")

        If vFilename <> "" Then
            If SaveSheet(vFilename) Then bSaved = True
        End If
    End If
Else
    If MsgBox( _
        "Are you sure you want to save? Data entered cannot be edited after saving", _
        vbYesNo, "Save?" _
    ) = vbYes Then
        If SaveSheet("") Then bSaved = True
    End If
End If

我还没有完全测试上述内容，但它应该会给你一些想法。

于 2012-05-09T16:56:57.060 回答