Excel Vba 30 vezes ( aberta ) ela se auto destrói

[Netobarbuio]

Boa tarde

Preciso de um VBA que após a planilha ser usada 30 vezes ( aberta ) ela se auto destrói

aguardo

[AfonsoMira]

@Netobarbuio Boas,
Veja se isso ajuda.

Vai ter que colocar uma aba no ficheiro com o nome "Controle" e na célula A1 inserir a quantidade de vezes que pode abrir até eliminar o ficheiro.

 

Cria um módulo novo e cola a seguinte macro:

Sub ApagaFicheiro()
  Dim xNomeCompleto As String
  xNomeCompleto = Application.ActiveWorkbook.FullName
  ActiveWorkbook.Saved = True
  Application.ActiveWorkbook.ChangeFileAccess xlReadOnly
  Kill xNomeCompleto 
  Application.ActiveWorkbook.Close False
End Sub

 

Depois no evento do Livro:

'Antes de fechar ele retira 1 do valor de A1
Private Sub Workbook_BeforeClose(Cancel As Boolean)
	Sheets("Controle").Range("A1").Value = Sheets("Controle").Range("A1").Value - 1
End Sub

'Ao abrir verifica se o valor de A1 é 0, caso seja verdade ele chama a macro ApagaFicheiro
Private Sub Workbook_Open()
On Error Resume Next
 Dim vezes As Integer
 Dim sh As Worksheet
vezes = Sheets("Controle").Range("A1").Value
 If vezes = 0 Then
 ApagaFicheiro
End If
End Sub

 

[Basole]

@AfonsoMira @Netobarbuiomas no caso do usuário ter uma cópia da planilha, poderá utilizar infinitamente, só terá o trabalho de pegar a cópia novamente a cada 30 vezes de abertura.

 

Acho que a solução para este caso é salvar as aberturas no registro do Windows. 

 

No momento não tenho acesso a um PC para testar um exemplo e postar aqui.

@Netobarbuio se puder aguardar até o final da tarde...

[Basole]

@NetobarbuioConforme prometido, segue exemplo...

 

  Aproveitei a rotina "ApagaFicheiro" do colega @AfonsoMira, que "destrói" a planilha 

 

* Copie e cole o codigo abaixo no modulo: EstaPasta_de_trabalho

 

Private Sub Workbook_Open()
    Dim cnt    As Long
    cnt = VBA.GetSetting("MyProjet", "Settings", "Open", 0)
      cnt = cnt + 1
          VBA.SaveSetting "MyProjet", "Settings", "Open", cnt
    
     If cnt > 30 Then
    
          MsgBox "Esta é uma Versão de Avaliação e se expirou! " & VBA.vbNewLine & _
                 "E será fechada automaticamente.", vbCritical, "A T E N Ç Ã O"
          ApagaFicheiro               
     End If
     
End Sub

Private Sub ApagaFicheiro()
  Dim xNomeCompleto As String
  xNomeCompleto = Application.ActiveWorkbook.FullName
  ActiveWorkbook.Saved = True
  Application.ActiveWorkbook.ChangeFileAccess xlReadOnly
  Kill xNomeCompleto
  Application.ActiveWorkbook.Close False
End Sub

 

[Netobarbuio]

12 horas atrás, Basole disse:

@NetobarbuioConforme prometido, segue exemplo...

 

  Aproveitei a rotina "ApagaFicheiro" do colega @AfonsoMira, que "destrói" a planilha 

 

* Copie e cole o codigo abaixo no modulo: EstaPasta_de_trabalho

 

Private Sub Workbook_Open()
    Dim cnt    As Long
    cnt = VBA.GetSetting("MyProjet", "Settings", "Open", 0)
      cnt = cnt + 1
          VBA.SaveSetting "MyProjet", "Settings", "Open", cnt
    
     If cnt > 30 Then
    
          MsgBox "Esta é uma Versão de Avaliação e se expirou! " & VBA.vbNewLine & _
                 "E será fechada automaticamente.", vbCritical, "A T E N Ç Ã O"
          ApagaFicheiro               
     End If
     
End Sub

Private Sub ApagaFicheiro()
  Dim xNomeCompleto As String
  xNomeCompleto = Application.ActiveWorkbook.FullName
  ActiveWorkbook.Saved = True
  Application.ActiveWorkbook.ChangeFileAccess xlReadOnly
  Kill xNomeCompleto
  Application.ActiveWorkbook.Close False
End Sub

 

Show, deu certo Obrigado top!! 

Em 08/07/2021 às 08:04, AfonsoMira disse:

@Netobarbuio Boas,
Veja se isso ajuda.

Vai ter que colocar uma aba no ficheiro com o nome "Controle" e na célula A1 inserir a quantidade de vezes que pode abrir até eliminar o ficheiro.

 

Cria um módulo novo e cola a seguinte macro:

Sub ApagaFicheiro()
  Dim xNomeCompleto As String
  xNomeCompleto = Application.ActiveWorkbook.FullName
  ActiveWorkbook.Saved = True
  Application.ActiveWorkbook.ChangeFileAccess xlReadOnly
  Kill xNomeCompleto 
  Application.ActiveWorkbook.Close False
End Sub

 

Depois no evento do Livro:

'Antes de fechar ele retira 1 do valor de A1
Private Sub Workbook_BeforeClose(Cancel As Boolean)
	Sheets("Controle").Range("A1").Value = Sheets("Controle").Range("A1").Value - 1
End Sub

'Ao abrir verifica se o valor de A1 é 0, caso seja verdade ele chama a macro ApagaFicheiro
Private Sub Workbook_Open()
On Error Resume Next
 Dim vezes As Integer
 Dim sh As Worksheet
vezes = Sheets("Controle").Range("A1").Value
 If vezes = 0 Then
 ApagaFicheiro
End If
End Sub

 

Bom dia

Top deu certinho obrigado!!