Macro de Excel para aprobaciones y otras opciones de aprobaciones digitales

Hola, en estos días que estamos viviendo cambios en nuestra forma de trabajar, ya se trabajando desde casa, entrando a la oficina de forma escalonada, utilizando tecnología que no habías utilizado antes, conferencias, correos, grabar vídeos para clases, etc.

Algunas opciones para firmar documentos de manera electrónica

  • Con un flujo en Sharepoint
  • Un formato de Infopath de Microsoft
  • Creando llaves certificadas 
  • Abode Reader
  • Crear un WorkFlow o flujo de aprobación en sus sistemas de ERP
En Adobe Reader por ejemplo pueden exportar cualquier archivo de Microsoft a PDF y asignarle la firma, seleccionando en la barra el icono de Firma, puedes colocar una imagen, tus iniciales, un texto


Viendo esto recordé una macro con la que trabaje hace algún tiempo para poder adicionar firmas electrónicas y envíar el archivo por correo a un siguiente aprobador y validando el aprobador, esto puede funcionar si hay personas fuera de la oficina y necesitas que se firmen documentos para autorizar procesos.

El formato en Excel  es como la siguiente imagen 




La macro tiene el siguiente código

Public correo1, correo2, correo3, correo4, correo5 As String
Private Sub Workbook_open()
 correo1 = "programacionparatodos@prog.com"  'Nive11
End Sub

Private Sub CommandButton2_Click() 'boton de enviar_formato
Dim fila As Integer
Dim nombre As String
CommandButton1.Enabled = False  'llenado
  CommandButton3.Enabled = True 'approve
  CommandButton4.Enabled = True 'reject
correo1 = "programacionparatodos@prog.com"  'Nive11
correo2 = "zelideth27@gmail.com"  'Nivel2
'copy format in one file
If Range("C20").Interior.Color = RGB(255, 255, 255) Then Do 'primer envio
   fila = 0
   'nombre del archivo
   nombre = "Aprobar_Venta" + Sheet5.Range("B4") + Trim(Str(Year(Date))) + Trim(Str(Month(Date))) + Trim(Str(Day(Date)))
   mio = ActiveWorkbook.Name
   Workbooks.Add
   otro = ActiveWorkbook.Name
   Workbooks(mio).Activate
   Sheets(4).Copy after:=Workbooks(otro).ActiveSheet
   Application.DisplayAlerts = False
   Workbooks(otro).Sheets(1).Delete
   ActiveWorkbook.SaveAs filename:=ThisWorkbook.Path & "\" & Replace(nombre, "/", ""), FileFormat:=xlOpenXMLWorkbookMacroEnabled
   'xlOpenXMLWorkbook
   Application.DisplayAlerts = False
   ActiveWorkbook.Close False
   nombre = ThisWorkbook.Path & "\" & Replace(nombre, "/", "") & ".xlsm"

   Call Send_File(nombre)
   CommandButton3.Enabled = False 'approve
   CommandButton4.Enabled = False 'reject
   CommandButton1.Enabled = True
End If

End Sub

Private Sub Send_File(filename As String)
 
  Dim stFileName As String
  Dim vaRecipients As Variant
  Dim noSession As Object
  Dim noDatabase As Object
  Dim noDocument As Object
  Dim noEmbedObject As Object
  Dim Body As Object
  Dim stAttachment As String
  Dim stSubject    As String
  Dim vaMsg        As String
  Dim nombre       As String
  Dim strTo        As String

 'send mail to supervidor
   'If Abs(Cells(23, 5)) >= 1 And Abs(Cells(23, 5)) <= 99 And Range("C37").Interior.Color = RGB(255, 255, 255) Then
 If Range("C37").Interior.Color = RGB(255, 255, 255) Then
      strTo = correo1
 End If
 If Abs(Cells(23, 5)) >= 100 And Abs(Cells(23, 5)) <= 499 And Range("C37").Interior.Color = RGB(51, 204, 51) Then
    strTo = correo2
 End If

 If Abs(Cells(23, 5)) >= 500 And Abs(Cells(23, 5)) <= 999 And Range("C38").Interior.Color = RGB(51, 204, 51) Then
     strTo = correo3
 End If
 
 If Abs(Cells(23, 5)) >= 1000 And Abs(Cells(23, 5)) <= 4999 And Range("C39").Interior.Color = RGB(51, 204, 51) Then
strTo = correo4
 End If
 
 If Abs(Cells(23, 5)) >= 5000 And Abs(Cells(23, 5)) <= 14999 And Range("C40").Interior.Color = RGB(51, 204, 51) Then
strTo = correo5
 End If
  
 If Abs(Cells(23, 5)) >= 15000 Then
strTo = correo6
 End If

   
  'Create the list of recipients.
  stSubject = "Authorization_cycle_acount" + Sheet5.Range("B4") + Trim(Str(Year(Date))) + Trim(Str(Month(Date))) + Trim(Str(Day(Date)))
  vaMsg = "Please review and Approve o Reject the inventory asjusment"
  'Instantiate the Lotus Notes COM's Objects.
  Set noSession = CreateObject("Notes.NotesSession")
  Set noDatabase = noSession.GETDATABASE("", "")
 
  'If Lotus Notes is not open then open the mail-part of it.
  If noDatabase.IsOpen = False Then noDatabase.OPENMAIL
 
  'Create the e-mail
  Set noDocument = noDatabase.CreateDocument
  'Example to create an attachment (optional)
  
  Set Body = noDocument.CreateRichTextItem("Body")
  Call Body.APPENDTEXT(vaMsg)
  Call Body.ADDNEWLINE(2)
  Call Body.EMBEDOBJECT(1454, "", filename, "Attachment")
 ' MsgBox filename
  noDocument.SAVEMESSAGEONSEND = True
  'Example to set return receipt (optional)
  noDocument.DeliveryReport = "B"
  'Example to set high priority (optional)
  ' MailDoc.DeliveryPriority = "H"
  Call noDocument.ReplaceItemValue("SendTo", strTo)
  Call noDocument.ReplaceItemValue("Subject", stSubject)
  Call noDocument.ReplaceItemValue("PostedDate", Now())
  Call noDocument.Send(False)
  'Add values to the created e-mail main properties.
 ' With noDocument
 '   .Form = "Memo"
 '   .SendTo = vaRecipients
 '   .Subject = stSubject
 '   .SaveMessageOnSend = True
 '   .PostedDate = Now()
 '   .Send 0, vaRecipients
 ' End With
 
  'Delete the temporarily workbook.
  'Kill stAttachment
 
  'Release objects from memory.
  Set Body = Nothing
  Set noDocument = Nothing
  Set noDatabase = Nothing
  Set noSession = Nothing

  MsgBox "The e-mail has successfully been created and distributed" + strTo, vbInformation
  
End Sub

Private Sub CommandButton3_Click()
'Aprove

 If Abs(Cells(23, 5)) >= 1 And Abs(Cells(23, 5)) <= 99 Then
    Call approve_1("C37")
 End If
 If Abs(Cells(23, 5)) >= 100 And Abs(Cells(23, 5)) <= 499 Then
    Call approve_1("C37")
    Call approve_2("C38", "C37")
 End If

 If Abs(Cells(23, 5)) >= 500 And Abs(Cells(23, 5)) <= 999 Then
     Call approve_1("C37")
     Call approve_2("C38", "C37")
     Call approve_3("C39", "C38")
 End If
 
 If Abs(Cells(23, 5)) >= 1000 And Abs(Cells(23, 5)) <= 4999 Then
      Call approve_1("C37")
     Call approve_2("C38", "C37")
     Call approve_3("C39", "C38")
     Call approve_4("C40", "C39")
 End If
 
 If Abs(Cells(23, 5)) >= 5000 And Abs(Cells(23, 5)) <= 14999 Then
 Call approve_5("C41")
 End If
  
 If Abs(Cells(23, 5)) >= 15000 Then
 Call approve_6("C42")
 End If

End Sub


Private Sub CommandButton4_Click()
'Reject

 If Abs(Cells(23, 5)) >= 1 And Abs(Cells(23, 5)) <= 99 Then
    Call reject_1("C37")
 End If
 If Abs(Cells(23, 5)) >= 100 And Abs(Cells(23, 5)) <= 499 Then
    Call reject_1("C37")
    Call reject_2("C38", "C37")
 End If

 If Abs(Cells(23, 5)) >= 500 And Abs(Cells(23, 5)) <= 999 Then
     Call reject_1("C37")
     Call reject_2("C38", "C37")
     Call reject_3("C39", "C38")
 End If
 
 If Abs(Cells(23, 5)) >= 1000 And Abs(Cells(23, 5)) <= 4999 Then
      Call reject_1("C37")
     Call reject_2("C38", "C37")
     Call reject_3("C39", "C38")
     Call reject_4("C40", "C39")
 End If
 
 If Abs(Cells(23, 5)) >= 5000 And Abs(Cells(23, 5)) <= 14999 Then
 Call reject_5("C41")
 End If
  
 If Abs(Cells(23, 5)) >= 15000 Then
 Call reject_6("C42")
 End If
End Sub
Private Sub approve_1(Celda As String)
  Dim noSession As Object
  Dim noDatabase As Object
  Dim MailServer As String 'this is the users mail server
  Dim MailDB As Object 'this is the users mail database
  Dim MailDBName As String
  Dim pos_mail As Integer
  Dim pos_mail2 As Integer
  Dim vc_mail As String
  Dim vc_mail2 As String
  'Instantiate the Lotus Notes COM's Objects.
  Set noSession = CreateObject("Notes.NotesSession")
  Set noDatabase = noSession.GETDATABASE("", "")
  MailServer = noSession.GetEnvironmentString("MailServer", True)
  'If Lotus Notes is not open then open the mail-part of it.
  If noDatabase.IsOpen = False Then noDatabase.OPENMAIL
  
 correo1 = "rtes@test.com" 'jefe

  MailDBName = noSession.GetEnvironmentString("KeyFileName_Owner", True)
  'MsgBox MailDBName
  pos_mail = InStr(MailDBName, "/")
  vc_mail = Mid(MailDBName, 4, pos_mail - 4)
  pos_mail2 = InStr(correo1, "@")
  vc_mail2 = Left(correo1, pos_mail2 - 1)
  vc_mail2 = Replace(vc_mail2, ".", " ")
  If LCase(vc_mail) = LCase(vc_mail2) Then
    'Approve first level
    If Not (Dir("C:\Users\Ana Zamora\Documents\sig1.jpg") > "") Then
        If Range(Celda).Value = "" Then
            ActiveSheet.Unprotect Password:="testpass"
            Range(Celda).Value = "APPROVE"
            Range(Celda).Interior.Color = RGB(51, 204, 51)
        Else
          MsgBox ("This signature has already been applied!")
        End If
    Else
       ActiveSheet.Unprotect Password:="testpass"
       Range(Celda).Select
    
    
       Dim Sh As Shape
       With Worksheets("Formato 2018")
           For Each Sh In .Shapes
              If Not Application.Intersect(Sh.TopLeftCell, .Range(Celda)) Is Nothing Then
                 MsgBox ("This signature has already been applied!")
                 ActiveSheet.Protect Password:="testpass", DrawingObjects:=True, Contents:=True, Scenarios:=True
                 ActiveWorkbook.Save
                Exit Sub
               End If
               
               
           Next Sh
        End With
        
        ActiveSheet.Pictures.Insert("C:\Users\Ana Zamora\Documents\sig1.jpg").Select
        ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Select
        Range(Celda).Interior.Color = RGB(51, 204, 51)
        With Selection
          .ShapeRange.LockAspectRatio = msoFalse
          .ShapeRange.Height = ActiveCell.RowHeight
          .ShapeRange.Width = ActiveCell.Width
          .Placement = xlMoveAndSize
        End With
    
      End If
    Else
    MsgBox ("Usuario not valid to Approve")
    End If
    CommandButton4.Enabled = False
    CommandButton1.Enabled = False
    ActiveSheet.Protect Password:="testpass", DrawingObjects:=True, Contents:=True, Scenarios:=True
    ActiveWorkbook.Save
    
    Set noDatabase = Nothing
    Set noSession = Nothing
    
End Sub
Private Sub approve_2(Celda As String, Celda2 As String)
'Approve second level
  Dim noSession As Object
  Dim noDatabase As Object
  Dim MailServer As String 'this is the users mail server
  Dim MailDB As Object 'this is the users mail database
  Dim MailDBName As String
  Dim pos_mail As Integer
  Dim pos_mail2 As Integer
  Dim vc_mail As String
  Dim vc_mail2 As String

 correo2 = "ana.zamora@test.com"  

    Set noSession = CreateObject("Notes.NotesSession")
  Set noDatabase = noSession.GETDATABASE("", "")
  MailDBName = noSession.GetEnvironmentString("KeyFileName_Owner", True)
  'MsgBox MailDBName
  pos_mail = InStr(MailDBName, "/")
  vc_mail = Mid(MailDBName, 4, pos_mail - 4)
  pos_mail2 = InStr(correo2, "@")
  vc_mail2 = Left(correo2, pos_mail2 - 1)
  vc_mail2 = Replace(vc_mail2, ".", " ")
  
  If LCase(vc_mail) = LCase(vc_mail2) Then
        If Range(Celda).Value = "" Then
            ActiveSheet.Unprotect Password:="testpass"
            Range(Celda).Value = "APPROVE"
            Range(Celda).Interior.Color = RGB(51, 204, 51)
        Else
          MsgBox ("This signature has already been applied!")
        End If
    
            If Range(Celda2).Interior.Color <> RGB(51, 204, 51) Then
                 MsgBox ("Missing previous authorization!")
                 ActiveSheet.Protect Password:="testpass", DrawingObjects:=True, Contents:=True, Scenarios:=True
                 ActiveWorkbook.Save
                Exit Sub
            End If
   Else
    MsgBox ("Usuario not valid to Approve")
   End If
    CommandButton4.Enabled = False
    CommandButton1.Enabled = False
    ActiveSheet.Protect Password:="testpass", DrawingObjects:=True, Contents:=True, Scenarios:=True
    ActiveWorkbook.Save
End Sub
Private Sub approve_3(Celda As String, Celda2 As String)
  Dim noSession As Object
  Dim noDatabase As Object
  Dim MailServer As String 'this is the users mail server
  Dim MailDB As Object 'this is the users mail database
  Dim MailDBName As String
  Dim pos_mail As Integer
  Dim pos_mail2 As Integer
  Dim vc_mail As String
  Dim vc_mail2 As String
  
 correo3 = "mail3@test.com"  
  Set noSession = CreateObject("Notes.NotesSession")
  Set noDatabase = noSession.GETDATABASE("", "")
MailDBName = noSession.GetEnvironmentString("KeyFileName_Owner", True)
  'MsgBox MailDBName
  pos_mail = InStr(MailDBName, "/")
  vc_mail = Mid(MailDBName, 4, pos_mail - 4)
  pos_mail2 = InStr(correo3, "@")
  vc_mail2 = Left(correo3, pos_mail2 - 1)
  vc_mail2 = Replace(vc_mail2, ".", " ")
  
  If LCase(vc_mail) = LCase(vc_mail2) Then
      If Range(Celda).Value = "" Then
            ActiveSheet.Unprotect Password:="testpass"
            Range(Celda).Value = "APPROVE"
            Range(Celda).Interior.Color = RGB(51, 204, 51)
        Else
          MsgBox ("This signature has already been applied!")
        End If
    
            If Range(Celda2).Interior.Color <> RGB(51, 204, 51) Then
                 MsgBox ("Missing previous authorization!")
                 ActiveSheet.Protect Password:="testpass", DrawingObjects:=True, Contents:=True, Scenarios:=True
                 ActiveWorkbook.Save
                Exit Sub
            End If
   Else
    MsgBox ("Usuario not valid to Approve")
   End If
   
    CommandButton4.Enabled = False
    CommandButton1.Enabled = False
    ActiveSheet.Protect Password:="testpass", DrawingObjects:=True, Contents:=True, Scenarios:=True
    ActiveWorkbook.Save
End Sub

Private Sub approve_4(Celda As String, Celda2 As String)
  Dim noSession As Object
  Dim noDatabase As Object
  Dim MailServer As String 'this is the users mail server
  Dim MailDB As Object 'this is the users mail database
  Dim MailDBName As String
  Dim pos_mail As Integer
  Dim pos_mail2 As Integer
  Dim vc_mail As String
  Dim vc_mail2 As String
 correo4 = "mail4@test.com"  
   Set noSession = CreateObject("Notes.NotesSession")
  Set noDatabase = noSession.GETDATABASE("", "")
 MailDBName = noSession.GetEnvironmentString("KeyFileName_Owner", True)
  'MsgBox MailDBName
  pos_mail = InStr(MailDBName, "/")
  vc_mail = Mid(MailDBName, 4, pos_mail - 4)
  pos_mail2 = InStr(correo4, "@")
  vc_mail2 = Left(correo4, pos_mail2 - 1)
  vc_mail2 = Replace(vc_mail2, ".", " ")
 
 If LCase(vc_mail) = LCase(vc_mail2) Then
                  If Range(Celda).Value = "" Then
            ActiveSheet.Unprotect Password:="testpass"
            Range(Celda).Value = "APPROVE"
            Range(Celda).Interior.Color = RGB(51, 204, 51)
        Else
          MsgBox ("This signature has already been applied!")
        End If
    
            If Range(Celda2).Interior.Color <> RGB(51, 204, 51) Then
                 MsgBox ("Missing previous authorization!")
                 ActiveSheet.Protect Password:="testpass", DrawingObjects:=True, Contents:=True, Scenarios:=True
                 ActiveWorkbook.Save
                Exit Sub
            End If
   Else
    MsgBox ("Usuario not valid to Approve")
   End If
    CommandButton4.Enabled = False
    CommandButton1.Enabled = False
    ActiveSheet.Protect Password:="testpass", DrawingObjects:=True, Contents:=True, Scenarios:=True
    ActiveWorkbook.Save
End Sub

Private Sub approve_5(Celda As String)
  Dim noSession As Object
  Dim noDatabase As Object
  Dim MailServer As String 'this is the users mail server
  Dim MailDB As Object 'this is the users mail database
  Dim MailDBName As String
  Dim pos_mail As Integer
  Dim pos_mail2 As Integer
  Dim vc_mail As String
  Dim vc_mail2 As String
correo5 = "mail5@test.com" 
  Set noSession = CreateObject("Notes.NotesSession")
  Set noDatabase = noSession.GETDATABASE("", "")
 MailDBName = noSession.GetEnvironmentString("KeyFileName_Owner", True)
  'MsgBox MailDBName
  pos_mail = InStr(MailDBName, "/")
  vc_mail = Mid(MailDBName, 4, pos_mail - 4)
  pos_mail2 = InStr(correo5, "@")
  vc_mail2 = Left(correo5, pos_mail2 - 1)
  vc_mail2 = Replace(vc_mail2, ".", " ")
 
 If LCase(vc_mail) = LCase(vc_mail2) Then
        If Range(Celda).Value = "" Then
            ActiveSheet.Unprotect Password:="testpass"
            Range(Celda).Value = "APPROVE"
            Range(Celda).Interior.Color = RGB(51, 204, 51)
        Else
          MsgBox ("This signature has already been applied!")
        End If
    
            If Range(Celda2).Interior.Color <> RGB(51, 204, 51) Then
                 MsgBox ("Missing previous authorization!")
                 ActiveSheet.Protect Password:="testpass", DrawingObjects:=True, Contents:=True, Scenarios:=True
                 ActiveWorkbook.Save
                Exit Sub
            End If
   Else
    MsgBox ("Usuario not valid to Approve")
   End If
    CommandButton4.Enabled = False
    CommandButton1.Enabled = False
    ActiveSheet.Protect Password:="testpass", DrawingObjects:=True, Contents:=True, Scenarios:=True
    ActiveWorkbook.Save
End Sub

Private Sub approve_6(Celda As String)
  Dim noSession As Object
  Dim noDatabase As Object
  Dim MailServer As String 'this is the users mail server
  Dim MailDB As Object 'this is the users mail database
  Dim MailDBName As String
  Dim pos_mail As Integer
  Dim pos_mail2 As Integer
  Dim vc_mail As String
  Dim vc_mail2 As String
  Set noSession = CreateObject("Notes.NotesSession")
  Set noDatabase = noSession.GETDATABASE("", "")
 MailDBName = noSession.GetEnvironmentString("KeyFileName_Owner", True)
  'MsgBox MailDBName
  pos_mail = InStr(MailDBName, "/")
  vc_mail = Mid(MailDBName, 4, pos_mail - 4)
  pos_mail2 = InStr(correo5, "@")
  vc_mail2 = Left(correo5, pos_mail2 - 1)
  vc_mail2 = Replace(vc_mail2, ".", " ")
 
 If LCase(vc_mail) = LCase(vc_mail2) Then
           If Range(Celda).Value = "" Then
            ActiveSheet.Unprotect Password:="testpass"
            Range(Celda).Value = "APPROVE"
            Range(Celda).Interior.Color = RGB(51, 204, 51)
        Else
          MsgBox ("This signature has already been applied!")
        End If
    
            If Range(Celda2).Interior.Color <> RGB(51, 204, 51) Then
                 MsgBox ("Missing previous authorization!")
                 ActiveSheet.Protect Password:="testpass", DrawingObjects:=True, Contents:=True, Scenarios:=True
                 ActiveWorkbook.Save
                Exit Sub
            End If
   Else
    MsgBox ("Usuario not valid to Approve")
   End If
    CommandButton4.Enabled = False
    CommandButton1.Enabled = False
    ActiveSheet.Protect Password:="testpass", DrawingObjects:=True, Contents:=True, Scenarios:=True
    ActiveWorkbook.Save
End Sub

Private Sub reject_1(Celda As String)
  Dim noSession As Object
  Dim noDatabase As Object
  Dim MailServer As String 'this is the users mail server
  Dim MailDB As Object 'this is the users mail database
  Dim MailDBName As String
  Dim pos_mail As Integer
  Dim pos_mail2 As Integer
  Dim vc_mail As String
  Dim vc_mail2 As String
  'Instantiate the Lotus Notes COM's Objects.
  Set noSession = CreateObject("Notes.NotesSession")
  Set noDatabase = noSession.GETDATABASE("", "")
  MailServer = noSession.GetEnvironmentString("MailServer", True)
  'If Lotus Notes is not open then open the mail-part of it.
  If noDatabase.IsOpen = False Then noDatabase.OPENMAIL
  
 correo1 = "correo1@test.com"  'supervisor

  MailDBName = noSession.GetEnvironmentString("KeyFileName_Owner", True)
  'MsgBox MailDBName
  pos_mail = InStr(MailDBName, "/")
  vc_mail = Mid(MailDBName, 4, pos_mail - 4)
  pos_mail2 = InStr(correo1, "@")
  vc_mail2 = Left(correo1, pos_mail2 - 1)
  vc_mail2 = Replace(vc_mail2, ".", " ")
  If LCase(vc_mail) = LCase(vc_mail2) Then
    'reject first level
    If Not (Dir("C:\Users\Ana Zamora\Documents\sig1.jpg") > "") Then
        If Range(Celda).Value = "" Then
            ActiveSheet.Unprotect Password:="testpass"
            Range(Celda).Value = "Reject"
            Range(Celda).Interior.Color = RGB(255, 0, 0)
        Else
          MsgBox ("This signature has already been applied!")
        End If
    Else
       ActiveSheet.Unprotect Password:="testpass"
       Range(Celda).Select
    
    
       Dim Sh As Shape
       With Worksheets("Formato 2018")
           For Each Sh In .Shapes
              If Not Application.Intersect(Sh.TopLeftCell, .Range(Celda)) Is Nothing Then
                 MsgBox ("This signature has already been applied!")
                 ActiveSheet.Protect Password:="testpass", DrawingObjects:=True, Contents:=True, Scenarios:=True
                 ActiveWorkbook.Save
                Exit Sub
               End If
               
               
           Next Sh
        End With
        
        ActiveSheet.Pictures.Insert("C:\Users\Ana Zamora\Documents\sig1.jpg").Select
        ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Select
        Range(Celda).Interior.Color = RGB(255, 0, 0)
        With Selection
          .ShapeRange.LockAspectRatio = msoFalse
          .ShapeRange.Height = ActiveCell.RowHeight
          .ShapeRange.Width = ActiveCell.Width
          .Placement = xlMoveAndSize
        End With
    
      End If
    Else
    MsgBox ("Usuario not valid to reject")
    End If
    CommandButton4.Enabled = False
    CommandButton1.Enabled = False
    ActiveSheet.Protect Password:="testpass", DrawingObjects:=True, Contents:=True, Scenarios:=True
    ActiveWorkbook.Save
    
    Set noDatabase = Nothing
    Set noSession = Nothing
    
End Sub
Private Sub reject_2(Celda As String, Celda2 As String)
'reject second level
  Dim noSession As Object
  Dim noDatabase As Object
  Dim MailServer As String 'this is the users mail server
  Dim MailDB As Object 'this is the users mail database
  Dim MailDBName As String
  Dim pos_mail As Integer
  Dim pos_mail2 As Integer
  Dim vc_mail As String
  Dim vc_mail2 As String

 correo2 = "ana.zamora@test.com"  

    Set noSession = CreateObject("Notes.NotesSession")
  Set noDatabase = noSession.GETDATABASE("", "")
  MailDBName = noSession.GetEnvironmentString("KeyFileName_Owner", True)
  'MsgBox MailDBName
  pos_mail = InStr(MailDBName, "/")
  vc_mail = Mid(MailDBName, 4, pos_mail - 4)
  pos_mail2 = InStr(correo2, "@")
  vc_mail2 = Left(correo2, pos_mail2 - 1)
  vc_mail2 = Replace(vc_mail2, ".", " ")
  
  If LCase(vc_mail) = LCase(vc_mail2) Then
        If Range(Celda).Value = "" Then
            ActiveSheet.Unprotect Password:="testpass"
            Range(Celda).Value = "Reject"
            Range(Celda).Interior.Color = RGB(255, 0, 0)
        Else
          MsgBox ("This signature has already been applied!")
        End If
    
            If Range(Celda2).Interior.Color <> RGB(51, 204, 51) Then
                 MsgBox ("Missing previous authorization!")
                 ActiveSheet.Protect Password:="testpass", DrawingObjects:=True, Contents:=True, Scenarios:=True
                 ActiveWorkbook.Save
                Exit Sub
            End If
   Else
    MsgBox ("Usuario not valid to reject")
   End If
    CommandButton4.Enabled = False
    CommandButton1.Enabled = False
    ActiveSheet.Protect Password:="testpass", DrawingObjects:=True, Contents:=True, Scenarios:=True
    ActiveWorkbook.Save
End Sub
Private Sub reject_3(Celda As String, Celda2 As String)
  Dim noSession As Object
  Dim noDatabase As Object
  Dim MailServer As String 'this is the users mail server
  Dim MailDB As Object 'this is the users mail database
  Dim MailDBName As String
  Dim pos_mail As Integer
  Dim pos_mail2 As Integer
  Dim vc_mail As String
  Dim vc_mail2 As String
  
 correo3 = "correo2@test.com"  
  Set noSession = CreateObject("Notes.NotesSession")
  Set noDatabase = noSession.GETDATABASE("", "")
MailDBName = noSession.GetEnvironmentString("KeyFileName_Owner", True)
  'MsgBox MailDBName
  pos_mail = InStr(MailDBName, "/")
  vc_mail = Mid(MailDBName, 4, pos_mail - 4)
  pos_mail2 = InStr(correo3, "@")
  vc_mail2 = Left(correo3, pos_mail2 - 1)
  vc_mail2 = Replace(vc_mail2, ".", " ")
  
  If LCase(vc_mail) = LCase(vc_mail2) Then
      If Range(Celda).Value = "" Then
            ActiveSheet.Unprotect Password:="testpass"
            Range(Celda).Value = "reject"
            Range(Celda).Interior.Color = RGB(255, 0, 0)
        Else
          MsgBox ("This signature has already been applied!")
        End If
    
            If Range(Celda2).Interior.Color <> RGB(51, 204, 51) Then
                 MsgBox ("Missing previous authorization!")
                 ActiveSheet.Protect Password:="testpass", DrawingObjects:=True, Contents:=True, Scenarios:=True
                 ActiveWorkbook.Save
                Exit Sub
            End If
   Else
    MsgBox ("Usuario not valid to reject")
   End If
   
    CommandButton4.Enabled = False
    CommandButton1.Enabled = False
    ActiveSheet.Protect Password:="testpass", DrawingObjects:=True, Contents:=True, Scenarios:=True
    ActiveWorkbook.Save
End Sub

Private Sub reject_4(Celda As String, Celda2 As String)
  Dim noSession As Object
  Dim noDatabase As Object
  Dim MailServer As String 'this is the users mail server
  Dim MailDB As Object 'this is the users mail database
  Dim MailDBName As String
  Dim pos_mail As Integer
  Dim pos_mail2 As Integer
  Dim vc_mail As String
  Dim vc_mail2 As String
 correo4 = "mail4@ests.com"  
   Set noSession = CreateObject("Notes.NotesSession")
  Set noDatabase = noSession.GETDATABASE("", "")
 MailDBName = noSession.GetEnvironmentString("KeyFileName_Owner", True)
  'MsgBox MailDBName
  pos_mail = InStr(MailDBName, "/")
  vc_mail = Mid(MailDBName, 4, pos_mail - 4)
  pos_mail2 = InStr(correo4, "@")
  vc_mail2 = Left(correo4, pos_mail2 - 1)
  vc_mail2 = Replace(vc_mail2, ".", " ")
 
 If LCase(vc_mail) = LCase(vc_mail2) Then
                  If Range(Celda).Value = "" Then
            ActiveSheet.Unprotect Password:="testpass"
            Range(Celda).Value = "Reject"
            Range(Celda).Interior.Color = RGB(255, 0, 0)
        Else
          MsgBox ("This signature has already been applied!")
        End If
    
            If Range(Celda2).Interior.Color <> RGB(51, 204, 51) Then
                 MsgBox ("Missing previous authorization!")
                 ActiveSheet.Protect Password:="testpass", DrawingObjects:=True, Contents:=True, Scenarios:=True
                 ActiveWorkbook.Save
                Exit Sub
            End If
   Else
    MsgBox ("Usuario not valid to reject")
   End If
    CommandButton4.Enabled = False
    CommandButton1.Enabled = False
    ActiveSheet.Protect Password:="testpass", DrawingObjects:=True, Contents:=True, Scenarios:=True
    ActiveWorkbook.Save
End Sub

Private Sub reject_5(Celda As String)
  Dim noSession As Object
  Dim noDatabase As Object
  Dim MailServer As String 'this is the users mail server
  Dim MailDB As Object 'this is the users mail database
  Dim MailDBName As String
  Dim pos_mail As Integer
  Dim pos_mail2 As Integer
  Dim vc_mail As String
  Dim vc_mail2 As String
correo5 = "correo5@test.com"  
  Set noSession = CreateObject("Notes.NotesSession")
  Set noDatabase = noSession.GETDATABASE("", "")
 MailDBName = noSession.GetEnvironmentString("KeyFileName_Owner", True)
  'MsgBox MailDBName
  pos_mail = InStr(MailDBName, "/")
  vc_mail = Mid(MailDBName, 4, pos_mail - 4)
  pos_mail2 = InStr(correo5, "@")
  vc_mail2 = Left(correo5, pos_mail2 - 1)
  vc_mail2 = Replace(vc_mail2, ".", " ")
 
 If LCase(vc_mail) = LCase(vc_mail2) Then
        If Range(Celda).Value = "" Then
            ActiveSheet.Unprotect Password:="testpass"
            Range(Celda).Value = "Reject"
            Range(Celda).Interior.Color = RGB(255, 0, 0)
        Else
          MsgBox ("This signature has already been applied!")
        End If
    
            If Range(Celda2).Interior.Color <> RGB(51, 204, 51) Then
                 MsgBox ("Missing previous authorization!")
                 ActiveSheet.Protect Password:="testpass", DrawingObjects:=True, Contents:=True, Scenarios:=True
                 ActiveWorkbook.Save
                Exit Sub
            End If
   Else
    MsgBox ("Usuario not valid to reject")
   End If
    CommandButton4.Enabled = False
    CommandButton1.Enabled = False
    ActiveSheet.Protect Password:="testpass", DrawingObjects:=True, Contents:=True, Scenarios:=True
    ActiveWorkbook.Save
End Sub

Private Sub reject_6(Celda As String)
  Dim noSession As Object
  Dim noDatabase As Object
  Dim MailServer As String 'this is the users mail server
  Dim MailDB As Object 'this is the users mail database
  Dim MailDBName As String
  Dim pos_mail As Integer
  Dim pos_mail2 As Integer
  Dim vc_mail As String
  Dim vc_mail2 As String
  Set noSession = CreateObject("Notes.NotesSession")
  Set noDatabase = noSession.GETDATABASE("", "")
 MailDBName = noSession.GetEnvironmentString("KeyFileName_Owner", True)
  'MsgBox MailDBName
  pos_mail = InStr(MailDBName, "/")
  vc_mail = Mid(MailDBName, 4, pos_mail - 4)
  pos_mail2 = InStr(correo5, "@")
  vc_mail2 = Left(correo5, pos_mail2 - 1)
  vc_mail2 = Replace(vc_mail2, ".", " ")
 
 If LCase(vc_mail) = LCase(vc_mail2) Then
           If Range(Celda).Value = "" Then
            ActiveSheet.Unprotect Password:="testpass"
            Range(Celda).Value = "Reject"
            Range(Celda).Interior.Color = RGB(255, 0, 0)
        Else
          MsgBox ("This signature has already been applied!")
        End If
    
            If Range(Celda2).Interior.Color <> RGB(51, 204, 51) Then
                 MsgBox ("Missing previous authorization!")
                 ActiveSheet.Protect Password:="testpass", DrawingObjects:=True, Contents:=True, Scenarios:=True
                 ActiveWorkbook.Save
                Exit Sub
            End If
   Else
    MsgBox ("Usuario not valid to reject")
   End If
    CommandButton4.Enabled = False
    CommandButton1.Enabled = False
    ActiveSheet.Protect Password:="testpass", DrawingObjects:=True, Contents:=True, Scenarios:=True
    ActiveWorkbook.Save
End Sub


Private Sub CommandButton5_Click()

 ActiveSheet.Unprotect Password:="testpass"
Sheet5.Range("A8:C22") = ""
 Range("C37").Interior.Color = RGB(255, 255, 255)
 Range("C38").Interior.Color = RGB(255, 255, 255)
 Range("C39").Interior.Color = RGB(255, 255, 255)
 Range("C40").Interior.Color = RGB(255, 255, 255)
 Range("C41").Interior.Color = RGB(255, 255, 255)
 Range("C42").Interior.Color = RGB(255, 255, 255)
 Range("C43").Interior.Color = RGB(255, 255, 255)
 Range("E37").Interior.Color = RGB(255, 255, 255)
 Range("E38").Interior.Color = RGB(255, 255, 255)
 Range("E39").Interior.Color = RGB(255, 255, 255)
 Range("E40").Interior.Color = RGB(255, 255, 255)
 Range("E41").Interior.Color = RGB(255, 255, 255)
 Range("E42").Interior.Color = RGB(255, 255, 255)
 Range("E43").Interior.Color = RGB(255, 255, 255)
Sheet5.Range("C37:e43") = ""
 ActiveSheet.Protect Password:="testpass", DrawingObjects:=True, Contents:=True, Scenarios:=True
 ActiveWorkbook.Save
End Sub

No olvides compartirnos y seguirnos en este blog o en Facebook.

Comentarios

Publicar un comentario

Entradas más populares de este blog

Ejemplo Macro en Word

Imagen
Hola: ¿Sabían que no solo en Excel pueden hacer Macros?  ¡¡¡También en Outlook, Word, Power Point,Access  es posible hacer Macros!!!  ☺️ Ya que Word, Excel, Power Point,Access son de familia Microsoft y Visual Basic también es que podemos programar nuestras macros en esta paquetería. Como hemos visto antes, para poder programar nuestras macros, necesitamos primero configurar la Barra de tareas de Developer o Desarrollador Seleccionan el Menu File>Options>Customize Ribbon o en Español Archivo>Opciones>barra de tareas Despues la parte de seguridad de las macros Menu File>Options>Trus Center o Archivo>Opciones>Centro de Seguridad y marcamos como se ve en la imagen, la cuarta opción y el combo Ejemplo Vamos hacer un ejemplo donde, tengamos que generar varios diplomas de fin de curso, pero con una lista de Nombres , entonces vamos a crear un nuevo archivo en Word y le vamos a guardar como tipo Macro  Tenemos una plantill
Leer más

Macro de Excel para abrir archivo csv

Imagen
Hay veces que quieres abrir un archivo de Excel pero está separado por comas, punto y coma o por un pipe. Hay formas de hacerlos desde Excel. Les quiero compartir algunas opciones de como hacerlo y espero que les sean de utilidad. 1.Es abrir el archivo en Excel y utilizar la función de separar por columnas y seleccionar el delimitador, por ejemplo ";" 2. Es colocar "sep=;" en el primer renglón del archivo que quieres abrir y guardar en formato CSV y abrirlo en Excel y te lo abrirá separado en columnas. 3. Otra forma es con una macro, esté en mi gusto es la que más me funciona porque si hay alguna coma en la descripción o en alguna columna, si lo abres desde Excel te va a desacomodar las columnas.  Este botón te abrirá un pantalla para abrir el archivo que quieres separar y te lo abrirá en una hoja de excel ya separado. El código de la macro es el siguiente  Private Sub CommandButton1_Click() Dim sht As Worksheet Dim fnd As Variant Dim rplc As Variant Dim
Leer más

Como ejecutar SQL desde Tareas Programadas de Windows

Imagen
Bienvenidos a este blog, esta semana les quiero compartir otro ejemplo de archivos BAT o Batch en Windows para ejecutar una consulta a una base de datos SQL con la instrucción sqlcmd y poder ejecutar tareas programadas en sql server desde las tareas programadas de Windows. El comando sqlcmd es de Microsfot y nos ayuda para ejecutar consultas desde un archivo esta es la definición que da Microsoft La utilidad sqlcmd es una utilidad de la línea de comandos para la ejecución ad hoc e interactiva de instrucciones y scripts de Transact-SQL y para la automatización de tareas de scripting de Transact-SQL. Para usar sqlcmd interactivamente, o para compilar archivos de script que se ejecutan mediante sqlcmd, los usuarios deben estar familiarizados con Transact-SQL. La utilidad sqlcmd se usa normalmente de las formas siguientes: Ejemplo: Objetivo: Ejecutar un query a una base de datos para obtener las facturas timbradas a clientes y crear un archivo csv de salida y alojarlo en una carpet
Leer más