Exportar libor de excel desd access poniendole contraseña
Tengo este código en Access que construye una tabla y la exporta al una carpeta en la PC, quisiera que al libro se le pudiera poner contraseña desde que se exporta para cuando sea abierto la solicite. No se como hacerlo
Private Sub cmdExportar_Click()
Dim rstNombrePrograma As DAO.Recordset, _
rstTituloTema As DAO.Recordset, _
qdf As DAO.QueryDef, _
strSQL As String, _
strHoja As String, _
strArchivo As String, _
strTitulo As String, _
Campo As DAO.Field, _
lngColumna As Long, _
i As Long, _
xls As Object
Const xlWBATWorksheet = -4167
Const xlAutomatic = -4105
Const xlSolid = 1
Const xlThemeColorDark1 = 1
Const xlToRight = -4161
Const xlNormal = -4143
On Error GoTo cmdExportar_Click_TratamientoErrores
strSQL = "SELECT NombrePrograma"
strSQL = strSQL & " FROM ProgramasEmitidos"
strSQL = strSQL & " GROUP BY NombrePrograma"
Set xls = CreateObject("Excel.Application")
xls.Visible = True
xls.Workbooks.Add xlWBATWorksheet
strHoja = xls.ActiveSheet.Name
Set rstNombrePrograma = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset)
If Not (rstNombrePrograma.EOF And rstNombrePrograma.BOF) Then
Do
StrSQL = "SELECT TituloTema, NombreAutor, NombreInterprete, Sonatas, Fecha, Calculo, Local, Plantilla "
strSQL = strSQL & "FROM ProgramasEmitidos"
strSQL = strSQL & " WHERE NombrePrograma = Parametro1"
Set qdf = CurrentDb.CreateQueryDef("", strSQL)
qdf.Parameters("Parametro1") = rstNombrePrograma!NombrePrograma
Set rstTituloTema = qdf.OpenRecordset
xls.ActiveWorkBook.Sheets.Add Before:=xls.Worksheets(xls.Worksheets.Count)
xls.ActiveSheet.Name = rstNombrePrograma!NombrePrograma
With xls
lngColumna = 1
For Each Campo In rstTituloTema.Fields
strTitulo = ""
For i = 1 To Len(Campo.Name)
strTitulo = strTitulo & Mid(Campo.Name, i, 1)
If i < Len(Campo.Name) Then
If EsMayuscula(Mid(Campo.Name, i + 1, 1)) Then strTitulo = strTitulo & " "
End If
Next i
.ActiveSheet.Cells(1, lngColumna) = strTitulo
lngColumna = lngColumna + 1
Next Campo
.Range("A1").Select
.Range(.Selection, .Selection.End(xlToRight)).Select
.Selection.Font.Bold = True
With .Selection.Interior
.Pattern = xlSolid
.ColorIndex = 15
End With
End With
If Not (rstTituloTema.EOF And rstTituloTema.BOF) Then
xls.ActiveSheet.Cells(2, 1).CopyFromRecordset rstTituloTema
End If
xls.Columns("A:G").EntireColumn.AutoFit
rstNombrePrograma.MoveNext
Loop Until rstNombrePrograma.EOF
End If
xls.Application.DisplayAlerts = False
xls.ActiveWorkBook.Worksheets(strHoja).Delete
strArchivo = "D:\SG RADIO\EXPORTACIONES\" & DLookup("Emisora", "01TNomencladorEmisora") & " Derecho Autor Obras Completas.xls"
If Not Nz(strArchivo, "") = "" Then
xls.ActiveWorkBook.SaveAs FileName:=strArchivo, FileFormat:=xlNormal
Else
xls.ActiveWorkBook.Saved = True
End If
xls.Application.DisplayAlerts = True
cmdExportar_Click_Salir:
On Error Resume Next
xls.Quit
Set xls = Nothing
Set qdf = Nothing
CierraRecordsetDAO rstNombrePrograma
CierraRecordsetDAO rstTituloTema
On Error GoTo 0
Exit Sub
cmdExportar_Click_TratamientoErrores:
MsgBox "Error " & Err & " en proc.: cmdExportar_Click de Documento VBA: Form_frmFrmIniCaptacion (" & Err.Description & ")", vbCritical + vbOKOnly, "ATENCION"
Resume cmdExportar_Click_Salir
Resume Next
End Sub