Password Protect Excel File

[Tim L]

I'm using TransferSpreadsheet to export tables from my dB. Is it possible to password protect the Excel file?

I've carried out a search in Modules & VBA but did not find any satisfactory answers, although the posts were all quite old and I figure that someone may have come across and answer by now. I've got Access/Excel 2003.

Tim

 

[ghudson]

Untested but this should do it...

Public Sub Testing(sFile As String)
On Error GoTo Err_Testing

    Dim xlApp As Object
    Dim xlSheet As Object

    Set xlApp = CreateObject("Excel.Application")
    Set xlSheet = xlApp.Workbooks.Open(sFile).Sheets(1)
    
    With xlApp

    'Password protext the active worksheet    
    .Application.ActiveSheet.Protect "xxx", UserInterfaceOnly:=True

    'Password protect the workbook strcuture
    .Application.ActiveWorkbook.Protect "xxx", Structure:=True, Windows:=False

    'Password protect the file [OnOpen password]
    .Application.DisplayAlerts = False
    .Application.ActiveWorkbook.SaveAs FileName:=sFile, Password:="xxx", WriteResPassword:="xxx"
    .Application.DisplayAlerts = True

    .Application.ActiveWorkbook.Save
    .Application.ActiveWorkbook.Close
    .Quit

    End With

    Set xlApp = Nothing
    Set xlSheet = Nothing

Exit_Testing:
    Exit Sub

Err_Testing:
    MsgBox Err.Number & " - " & Err.Description
    Resume Exit_Testing

 

[Tim L]

ghudson, thanks for the quick reply.

Untested but this should do it...

Erm, might do, got a question though...

There's an "End If" but no start, so what was the "If" statement and where should it be?

Cheers,

Tim

 

[Tim L]

Okay, tried the code now, password successfully set. Thanks for that.

There is a problem though:

The procedure warns about replacing the current file... which has already been created (eg: it could be a file with appended data and therefore can't be deleted prior to this operation). It doesn't actually replace the file, which is okay I suppose, unless that is what you were expecting to happen, but there are two issues:

1. I would rather not have the warning message displayed (DoCmd.SetWarnings (False) has no effect).
   
2. There is also the problem that if the user selects the No or Cancel option when the warning is presented then the file will not be password protected (and maybe leaves a locked file behind, which then can't be replaced the next time the procedure is envoked, although I suppose that this could be cated for in the OnErr event...).

So how do we force a 'yes'?

Tim

 

[tkpstock]

Just kill the file before saving a new copy.

Kill "pathname/filename.xls"

 

[Tim L]

Just kill the file before saving a new copy.

Kill "pathname/filename.xls"

Thanks Tom, unfortunately the original file needs to remain and this command deletes the file; no good adding data to a file then promptly deleting it, all the data will be gone :-(

Tim

 

[tkpstock]

Sorry, didn't read closely enough.

Instead of using SaveAs, just use Save - the file already exists, so you don't have to use SaveAs. This shouldn't prompt for anything.

 

[ghudson]

I fixed my code above to disable the Excel warning message that asks the user if they want to replace the file.

 

[Db-why-not]

Untested but this should do it...

Public Sub Testing(sFile As String)
On Error GoTo Err_Testing

    Dim xlApp As Object
    Dim xlSheet As Object

    Set xlApp = CreateObject("Excel.Application")
    Set xlSheet = xlApp.Workbooks.Open(sFile).Sheets(1)
    
    With xlApp

    'Password protext the active worksheet    
    .Application.ActiveSheet.Protect "xxx", UserInterfaceOnly:=True

    'Password protect the workbook strcuture
    .Application.ActiveWorkbook.Protect "xxx", Structure:=True, Windows:=False

    'Password protect the file [OnOpen password]
    .Application.DisplayAlerts = False
    .Application.ActiveWorkbook.SaveAs FileName:=sFile, Password:="xxx", WriteResPassword:="xxx"
    .Application.DisplayAlerts = True

    .Application.ActiveWorkbook.Save
    .Application.ActiveWorkbook.Close
    .Quit

    End With

    Set xlApp = Nothing
    Set xlSheet = Nothing

Exit_Testing:
    Exit Sub

Err_Testing:
    MsgBox Err.Number & " - " & Err.Description
    Resume Exit_Testing

How would I integrate/ modify this code within my existing code. I have a button, that is clicked and exports several queries into 1 excel workbook with several sheets. I want the whole excel workbook to have 1 password. Below is my existing coderivate Sub CommandTransfer_Click()On Error GoTo SubErrorstrPath = "M:\Research\Lung Us\Data\Exporting_OHSU\OHSU_BAMC_Lung_Point_Clinical_Database_" & "_" & Format(Date, "yyyy_mm_dd") & ".xlsx"DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "OHSU_Admission_dx", strPathDoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "OHSU_DC_DX", strPathDoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "OHSU_CXR_CT", strPathDoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "OHSU_pre_existing", strPathDoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "OHSU_Demographics", strPathDoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "OHSU_Qualifying_cond", strPathDoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "OHSU_Micro", strPathDoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "OHSU_New_Pulm", strPathDoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "OHSU_US_scans", strPathDoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "OHSU_Box_Uploads", strPathDoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "OHSU_US_Review", strPathMsgBox "File Exported successfully", vbInformation + vbOKOnly, "Export Success" SubExit: Exit Sub SubError: MsgBox "Error Number: " & Err.Number & "= " & Err.Description, vbCritical + vbOKOnly, "An error occured" GoTo SubExitEnd SubAny help would be appreciated. Thank you.

 

[theDBguy]

How would I integrate/ modify this code within my existing code. I have a button, that is clicked and exports several queries into 1 excel workbook with several sheets. I want the whole excel workbook to have 1 password. Below is my existing coderivate Sub CommandTransfer_Click()On Error GoTo SubErrorstrPath = "M:\Research\Lung Us\Data\Exporting_OHSU\OHSU_BAMC_Lung_Point_Clinical_Database_" & "_" & Format(Date, "yyyy_mm_dd") & ".xlsx"DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "OHSU_Admission_dx", strPathDoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "OHSU_DC_DX", strPathDoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "OHSU_CXR_CT", strPathDoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "OHSU_pre_existing", strPathDoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "OHSU_Demographics", strPathDoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "OHSU_Qualifying_cond", strPathDoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "OHSU_Micro", strPathDoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "OHSU_New_Pulm", strPathDoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "OHSU_US_scans", strPathDoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "OHSU_Box_Uploads", strPathDoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "OHSU_US_Review", strPathMsgBox "File Exported successfully", vbInformation + vbOKOnly, "Export Success" SubExit: Exit Sub SubError: MsgBox "Error Number: " & Err.Number & "= " & Err.Description, vbCritical + vbOKOnly, "An error occured" GoTo SubExitEnd SubAny help would be appreciated. Thank you.

Hi. This is almost a 15-yr old thread. I suggest you start a new one for you question. Just a thought...