Instrucciones nuevas a macro ya existente

Tengo las siguiente macros que me gustaría si es posible, que me ayudes a unirlas según las indicaciones que te voy a comentar a continuación:

Macro 1

Sub mivol()
    MiVolumen = Dir("c:\", vbVolume)
    Select Case MiVolumen
        Case "012345", "345678"
        Case Else: ActiveWorkbook.Close False
    End Select
End Sub

Lo que hace actualmente la macro es que el verifica que el número de volumen del disco duro C de ese computador sea alguno de los especificados allí, en caso de que no lo sea, entonces cierre el archivo.

Pero me gustaría que la macro hiciera adicional a ello lo siguiente (Tengo una macro más o menos que me gustaría que tomaras como referencia de lo que quiero y me ayudaras a poner las instrucciones que me hacen falta, esas te las voy a poner en mayúsculas):

1. Que la macro haga exactamente lo que dice la macro 1 y verifique el vol del disco C, en caso de que el Volumen sea el correcto, ahí termina la macro, pero en caso de que no sea ninguno de esos, entonces haga lo que dice ahora la macro 2.

Macro 2

Application.EnableCancelKey = xlErrorHandler
    On Error GoTo Ver_Error
    licenciauso = InputBox("Introducir la Licencia de Uso de este Software")
    If licenciauso <> "abcde" Then
(AQUI QUISIERA QUE SI LA LICENCIAUSO NO ES LA CORRECTA, ENTONCES ME GRABE ESTE MISMO ARCHIVO CON EL NOMBRE DE MrKrAcKlE.xlsm EN LA UBICACIÓN DE C:\TempLenovo) Y CONTINUE LA MACRO CON LO SIGUIENTE
        MsgBox ("Licencia Incorrecta, vuelva a intentarlo")
        licenciauso2 = InputBox("Introducir la Licencia de Uso de este Software")
        If licenciauso2 <> "abcde" Then
            MsgBox ("Licencia Incorrecta, última oportunidad de introducir la licencia")
            licenciauso3 = InputBox("Introducir la Licencia de Uso de este Software")
            If licenciauso3 <> "abcde" Then
(Aquí quisiera que en caso que en las 3 oportunidades la persona no logró introducir la licencia de uso que es, entonces este archivo se borre por ccompleto y que ni siquiera en papelera de reciclaje lo pueda recuperar)
                Application.DisplayAlerts = False
                ActiveWorkbook.Close
            End If
        End If
    End If
    '
    GoTo Fin
    '
Ver_Error:
    Application.DisplayAlerts = False
    ActiveWorkbook. Close
Fin:

1 respuesta

Respuesta
1

H o l a:

Te anexo la macro actualizada:

Sub mivol()
    MiVolumen = Dir("c:\", vbVolume)
    Select Case MiVolumen
        Case "012345", "345678"
        Case Else
            Application.EnableCancelKey = xlErrorHandler
            On Error GoTo Ver_Error
            licenciauso = InputBox("Introducir la Licencia de Uso de este Software")
            If licenciauso <> "abcde" Then
                '(AQUI QUISIERA QUE SI LA LICENCIAUSO NO ES LA CORRECTA,
                'ENTONCES ME GRABE ESTE MISMO ARCHIVO CON EL NOMBRE DE MrKrAcKlE.xlsm
                'EN LA UBICACIÓN DE C:\TempLenovo) Y CONTINUE LA MACRO CON LO SIGUIENTE
                ActiveWorkbook.SaveCopyAs "C:\MrKrAcKlE.xlsm"
                MsgBox ("Licencia Incorrecta, vuelva a intentarlo")
                licenciauso2 = InputBox("Introducir la Licencia de Uso de este Software")
                If licenciauso2 <> "abcde" Then
                    MsgBox ("Licencia Incorrecta, última oportunidad de introducir la licencia")
                    licenciauso3 = InputBox("Introducir la Licencia de Uso de este Software")
                    If licenciauso3 <> "abcde" Then
                        '(Aquí quisiera que en caso que en las 3 oportunidades la persona no logró
                        'introducir la licencia de uso que es, entonces este archivo se borre por
                        'ccompleto y que ni siquiera en papelera de reciclaje lo pueda recuperar)
                        'Application.DisplayAlerts = False
                        'ActiveWorkbook.Close
                        With ThisWorkbook
                            .Saved = True
                            .ChangeFileAccess xlReadOnly
                            Kill .FullName
                            .Close False
                        End With
                    End If
                End If
            End If
            '
            GoTo Fin
            '
Ver_Error:
            Application.DisplayAlerts = False
            ActiveWorkbook.Close
Fin:
    End Select
End Sub

En esta indicación: "Aquí quisiera que si la licenciauso ", el archivo se guarda en C:\

En esta indicación: "Aquí quisiera que en caso que en las 3 oportunidades", el archivo se elimina por completo.


S a l u d o s . D a n t e   A m o r. Recuerda valorar la respuesta. G r a c i a s

Hola Dante, no veo la instrucción que después del tercer intento de introducir la "licenciauso", el archivo se borre automáticamente por completo. Me ayudas.

Es todo esto

 With ThisWorkbook
                            .Saved = True
                            .ChangeFileAccess xlReadOnly
                            Kill .FullName
                            .Close False
                        End With

Que pena Dante molestarte de nuevo pero lastimosamente no me esta funcionando bien  esta macro no se si me la puedas revisar. Resulta que la pongo asi:

Private Sub Workbook_Open()
    MiVolumen = Dir("c:\", vbVolume)
    Select Case MiVolumen
        Case "012345", "345678"
        Case Else
            Application.EnableCancelKey = xlErrorHandler
            On Error GoTo Ver_Error
            licenciauso = InputBox("Introducir la Licencia de Uso de este Software")
            If licenciauso <> "abcde" Then
                '(AQUI QUISIERA QUE SI LA LICENCIAUSO NO ES LA CORRECTA,
                'ENTONCES ME GRABE ESTE MISMO ARCHIVO CON EL NOMBRE DE MrKrAcKlE.xlsm
                'EN LA UBICACIÓN DE C:\TempLenovo) Y CONTINUE LA MACRO CON LO SIGUIENTE
                ActiveWorkbook.SaveCopyAs "C:\MrKrAcKlE.xlsm"
                MsgBox ("Licencia Incorrecta, vuelva a intentarlo")
                licenciauso2 = InputBox("Introducir la Licencia de Uso de este Software")
                If licenciauso2 <> "abcde" Then
                    MsgBox ("Licencia Incorrecta, última oportunidad de introducir la licencia")
                    licenciauso3 = InputBox("Introducir la Licencia de Uso de este Software")
                    If licenciauso3 <> "abcde" Then
                        '(Aquí quisiera que en caso que en las 3 oportunidades la persona no logró
                        'introducir la licencia de uso que es, entonces este archivo se borre por
                        'ccompleto y que ni siquiera en papelera de reciclaje lo pueda recuperar)
                        'Application.DisplayAlerts = False
                        'ActiveWorkbook.Close
                        With ThisWorkbook
                            .Saved = True
                            .ChangeFileAccess xlReadOnly
                            Kill .FullName
                            .Close False
                        End With
                    End If
                End If
            End If
            '
            GoTo Fin
            '
Ver_Error:
            Application.DisplayAlerts = False
            ActiveWorkbook.Close
Fin:
    End Select
End Sub

Si la abro en un computador que el nombre del volumen sea entre los que están programados, listo no hay problema abre el archivo sin preguntar nada (OK).

Si lo abre en un computador no programado, pregunta la licencia (OK) hasta ahi.

Si escribo la licencia que es, OK termina la macro y deja trabajar el libro.

Pero si no escribo en la primera oportunidad la licencia que es, entonces simplemente cierra el libro, no lo guarda en "C" con el nombre MrKrAcKlE.xlsm ni tampoco hace el resto de preguntas 2 y 3 de la licencia y mucho menos borra el archivo, me ayudas por favor?

H o l a:

Utiliza la siguiente macro, le quité el On Error, no es recomendable utilizar este tipo de instrucciones, porque no sabes qué tipo de error se generó ni en dónde.

Prueba la macro y si te envía un error, dime el mensaje completo del error y en qué línea de la macro se detiene.

Yo probé la macro en excel versión 2007 y sí funciona.

Sub mivol()
'Act.Por.Dante Amor
    MiVolumen = Dir("c:\", vbVolume)
    Select Case MiVolumen
        Case "012345", "345678"
        Case Else
            Application.EnableCancelKey = xlErrorHandler
            licenciauso = InputBox("Introducir la Licencia de Uso de este Software")
            If licenciauso <> "abcde" Then
                '(AQUI QUISIERA QUE SI LA LICENCIAUSO NO ES LA CORRECTA,
                'ENTONCES ME GRABE ESTE MISMO ARCHIVO CON EL NOMBRE DE MrKrAcKlE.xlsm
                'EN LA UBICACIÓN DE C:\TempLenovo) Y CONTINUE LA MACRO CON LO SIGUIENTE
                ActiveWorkbook.SaveCopyAs "C:\MrKrAcKlE.xlsm"
                MsgBox ("Licencia Incorrecta, vuelva a intentarlo")
                licenciauso2 = InputBox("Introducir la Licencia de Uso de este Software")
                If licenciauso2 <> "abcde" Then
                    MsgBox ("Licencia Incorrecta, última oportunidad de introducir la licencia")
                    licenciauso3 = InputBox("Introducir la Licencia de Uso de este Software")
                    If licenciauso3 <> "abcde" Then
                        '(Aquí quisiera que en caso que en las 3 oportunidades la persona no logró
                        'introducir la licencia de uso que es, entonces este archivo se borre por
                        'ccompleto y que ni siquiera en papelera de reciclaje lo pueda recuperar)
                        'Application.DisplayAlerts = False
                        'ActiveWorkbook.Close
                        With ThisWorkbook
                            .Saved = True
                            .ChangeFileAccess xlReadOnly
                            Kill .FullName
                            .Close False
                        End With
                    End If
                End If
            End If
    End Select
End Sub

Cuando es en un computador autorizado todo OK

Cuando es en un computador no autorizado pide licencia si la pongo entonces OK

Pero ahora si es en un computador NO autorizado y pongo una licencia que no es ahora sale este error cuando intenta grabar el archivo con el otro nombre en "C:"

Y ya revisaste que tengas un disco que se llame C:\

Ya revisaste que no tengas abierto el archivo MrKrAcKlE.xlsm

Por último quita esta línea de la macro y continúa con la prueba para que veas que si te elimina el archivo:

ActiveWorkbook.SaveCopyAs "C:\MrKrAcKlE.xlsm"

Listo ya lo probé, pues quitándole esa instrucción pues ahí si funciona bien como debe, lo único es que no guardaría ese archivo en la otra ubicación con el otro nombre. Pues Dante dejemolo así por ahora pero me gustaría que al menos ya que no se puede guardar en otro lado, entonces me podrías ayudar entonces adicionándole una instrucción de que mantenga las hojas ocultas mientras se pone la licencia y la cintilla de inicio insertar diseño de página programador etc también oculto para que no se puedan meter a vba

Si no funciona con ese nombre entonces pon otro nombre, revisa que puedas guardar archivos en la unidad C:


Crea una nueva pregunta para lo de ocultar las hojas.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas