Microsoft Excel Joaom ManuelJoaom Manuel hace 21 minutos Passw en plantilla Excel, Coloca passw en libros abiertos sin passw

1 post / 0 nuevos
JoaoM
Imagen de JoaoM
Offline
última acción: Hace 1 mes 6 días
Nivel 1 - 200 puntosNivel 2 - 500 puntosNivel 3 - 1000 puntosNivel 4 - 2000 puntos
alta: 15/12/2011 - 23:46
Puntos: 2785
Microsoft Excel Joaom ManuelJoaom Manuel hace 21 minutos Passw en plantilla Excel, Coloca passw en libros abiertos sin passw

Espero te encuentres bien

Quisiera que dentro de sus posibilidades me digan que puedo hacer o como hacer sobre:

Tengo una plantilla Excel y una de las macros que contiene es para crear un PDF y XLSX de lo que tengo en la hoja activa, neutralizando el passw de la plantilla (hoja activa), y vuelve a colocarlo al finalizar la ejecución.

Si tengo OTROS libros abiertos (los que sean, teniendo macros o no) la macro de la plantilla funciona colocando passw a los libros que están abiertos (uno a la ves) y dejando la plantilla sin el Passw.

Digo uno a la vez porque coloca passsw a uno de los abiertos, repito el proceso coloca passw a otro de los abiertos, y así sucesivamente, dejando desde lo primero la plantilla sin passw, aunque sin activar alguno de los demas libros abiertos

Si tengo 5 abiertos, (no contando la plantilla) de uno en uno le coloca passw dejando la plantilla sin passw. LA MACRO;

Sub GuardaSinMacros() 'guarda una copia .xlsx TOTALMENTE protegida, una copia PDF, elimina botones,
'desprotege y protege la origen

    Dim ruta    As String
    Dim nombre  As String
    Dim wb      As Object
    Dim i       As Long
    Dim d       As String
    ruta = "D:\Datos Mecanicos\"
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    ActiveSheet.Unprotect "123"
    With ThisWorkbook.Sheets(1)
   
    Set h1 = ActiveSheet
        nombre = Ini(Quitar(.Range("G4"))) & "_" & h1.Name & " " & Format(.Range("H3"), "19-0000") & _
       " " & .Range("D11") & "_" & .Range("C13") & "_" & .Range("D13") & "_" & .Range("H13") & _
       "_" & .Range("I13") & " " & .Range("J13").Value
'XXXXXXXX
'El cuadro dialogo abre en la carpeta de rut Guardar copia desde el cuadro dialogo
    With Application.FileDialog(msoFileDialogFolderPicker) 'Abre el cuadro dialogo
        .Title = "Selecciona destino"
        .AllowMultiSelect = False
        .InitialFileName = ruta

'Si cancela sale de la macro
        If .Show <> -1 Then Exit Sub
        ruta = .SelectedItems(1) & "\"
    End With
'XXXXXXXX
        .Copy
    End With
    Set wb = Workbooks(Workbooks.Count)
    With wb
        With .Sheets(1)
            For i = .Shapes.Count To 1 Step -1
                d = .Shapes(i).TopLeftCell.Address(False, False)
                Select Case d
                    Case "J2": .Shapes(i).Delete
                    Case "J3": .Shapes(i).Delete
                    Case "L3": .Shapes(i).Delete
                    Case "L4": .Shapes(i).Delete
                End Select
               
       'wb.Sheets(1).DisplayHorizontalScrollBar = False
      
            Next
            .SaveAs Filename:=ruta & nombre & ".xlsx", FileFormat:=xlOpenXMLWorkbook, _
                CreateBackup:=False
            With .Range("B2:J60")
                .ExportAsFixedFormat Type:=xlTypePDF, Filename:=ruta & nombre & ".pdf", _
                                     Quality:=xlQualityStandard, IncludeDocProperties:=True, _
                                     IgnorePrintAreas:=False, OpenAfterPublish:=False
                .Copy
                .PasteSpecial xlPasteValues
                Application.CutCopyMode = False
                Range("A2").Select 'DEseleccionar el rango en la copia
            End With
            With .Cells
                .Locked = True
                .FormulaHidden = False
            End With
            .Protect Password:="123", DrawingObjects:=True, Contents:=True, Scenarios:=True
            .EnableSelection = xlNoSelection 'Restringe todo, seleccion y escritura
        End With
        .SaveAs Filename:=ruta & nombre & ".xlsx", FileFormat:=xlOpenXMLWorkbook, _
                CreateBackup:=False
        .Close True
       
    End With
    Set wb = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    With ThisWorkbook
        With .Sheets(1).Range("H3")
            .Value = .Value + 1
        End With
    End With
    ActiveSheet.Protect "123"
        MsgBox "Archivos: " & nombre & " guardados en " & ruta & " como: " & ".xlsx" & " y " & ".PDF", vbInformation, "Guardado"
End Sub

Etiquetas: