Créer un module de date d’expiration d’une application (comme un trial)

**RastaBomboclat** · 27/01/2017, 12h50

Bonjour à tous,

Je reviens avec une nouvelle question concernant la durée d’utilisation d’une application dans le temps.
En effet, j’ai créé une petite application (pour la boite où je travail) qui fonction très bien et un visiteur intéressé nous l’a demandé pour pouvoir aussi le tester chez eux. Mais étant donné que ce ne sera qu’un teste je dois y mettre une date d’expiration qui bloque tout après la date de validité du teste. Après quelques recherche sur le net j’ai vu ce qu’on appelle en anglais «time-bombing as workbook» Mais les codes proposé ne m’ont pas trop convaincu.

Je ne sais pas très bien où commencer pour créer un module d’expiration de l’application. Je signale aussi que je ne domine pas encore les Module Class, seulement les Module normaux. Je ne sais pas grand-chose du tout du tout aux API. Mais pour le reste ça va.

Merci d’avance pour votre aide.

Bonne année, vu que c’est ma première visite cette année dans le forum.

**vinc_bilb** · 27/01/2017, 13h01

Bonjour,

Je ne connais pas le time bombing .... Une solution simple mais peu robuste serait de passer par les évènement ouverture classeur comme (et de protéger le code VBA)
=> On ferme le classeur sans notification si la date actuelle est supérieure à une date de référence

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
Private Sub Workbook_Open()
 
    If Now() > "01/01/2017" Then Application.DisplayAlerts = False: ThisWorkbook.Close
End Sub

Invité · 27/01/2017, 13h23

Bonjour,
Visual studio 6 est passe dans le domaine public , il est accessible en téléchargement, il n'est pas facile à trouver mais je vais regarder pour donner un lien!

Vb6 fonctionne comme VBA moyennant quelques aménagements, il utilise des module de classe que tu enregistre dans un projet DLL! donc tu fourni la DLL à ton client, il ne peut pas voire le code mais ta macro VBA peut l'utiliser.

tu reformate ton code dans un module de classe, tu l'exporte vers un fichier, puis tu ajoute ce fichier ans un projet Vb6 (DLL).

regarde la différence entre entre une sub faisant appel à un code en ligne, avac fonction et un module de classe!

Code module standard :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
Sub Test()
MsgBox "toto"
MsgBox message("toto")
Dim msg As New Classe1
MsgBox msg.Lemessage("toto")
End Sub
Function message(txt As String) As String
message = txt
End Function

Code module de classe :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Public Function Lemessage(txt As String) As String
Lemessage = txt
End Function

Pour l'instant je cherche encore comment interroger l'horloge parlante pour éviter que l'utilisateur change l'heure de l’ordinateur!

**unparia** · 27/01/2017, 14h34

Bonjour
Nous sommes ici dans la section VBA/Excel
Dans ces conditions :

Je reviens avec une nouvelle question concernant la durée d’utilisation d’une application dans le temps.

ne saurait concerner (sinon relevant d'une autre section de VB) qu'un classeur Excel. Et dans ce cas :
Ne perds pas ton temps. Toute tentative de protection de ce genre serait "cassée" en quelques secondes par n'importe quel "casseur" quelque peu averti, voire seulement "débrouillard"..
Bien évidemment, maintenant : il ne "casserait" que ce qui vaut d'être "cassé". Et si "ne vaut pas d'être cassé", aucun véritable intérêt à protéger ...

**RastaBomboclat** · 27/01/2017, 14h53

Envoyé par vinc_bilb

Bonjour,

Je ne connais pas le time bombing .... Une solution simple mais peu robuste serait de passer par les évènement ouverture classeur comme (et de protéger le code VBA)
=> On ferme le classeur sans notification si la date actuelle est supérieure à une date de référence

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
Private Sub Workbook_Open()
 
    If Now() > "01/01/2017" Then Application.DisplayAlerts = False: ThisWorkbook.Close
End Sub

Merci pour le code. Il est simple et cours et facilement utilisable. Je pourrais l'utiliser dans d'autre appli.
Concernant la situation dans laquelle je me trouve, il me faudrait quelque chose de plus costaud mais simple d'utilisation pour mois qui ne suis ni expert ni confirmé ou éclairé en VBA_Excel. Au fait je pense au cas où un petit malin changerai la date de l'ordi. J'ai vue un code qui où on a mis que le comptage se fasse a partir de la date de la premiere utilisation du fichier. Non pas en comptant par la date de l'ordinateur mais à partir de la date d'utilisation du fichier compter le nombre de jour ecoulé sans tenir compte de la date de l'ordinateur afficher.

Je continue aussi a chercher de mon coté. Merci pour ton code, je le garde précieusement.

Envoyé par unparia

Bonjour
Nous sommes ici dans la section VBA/Excel
Dans ces conditions :

ne saurait concerner (sinon relevant d'une autre section de VB) qu'un classeur Excel. Et dans ce cas :
Ne perds pas ton temps. Toute tentative de protection de ce genre serait "cassée" en quelques secondes par n'importe quel "casseur" quelque peu averti, voire seulement "débrouillard"..
Bien évidemment, maintenant : il ne "casserait" que ce qui vaut d'être "cassé". Et si "ne vaut pas d'être cassé", aucun véritable intérêt à protéger ...

Oui j'ai vu ça quelque part, où on recommendais d'ailleurs d'utiliser Add-In Express. Mais VB c'est pas mon fort. J'ai commencer a l'ecole avec Access et je suis passé a VBA_Excell dans la vie professionnelle oubliant tout ce que j'avais appris a l'ecole en Access(aujourd'hui les relations et sql me

).
Mais je vais voir avec la réponse de "dysorthographie" si je pourrais m'ensortir. Sinon, j'ai l'impression que c'est un beau cadeau de nouvel an que je ferai à notre visiteur chanceux.

**RastaBomboclat** · 27/01/2017, 15h48

Bonjour,

J’ai trouvé quelques solutions ICI. Mais je ne vais pas encore les utiliser. J’attends les réponse de dysorthographie avec la méthode via DLL qui est plus protéger que les codes VBA.

un exemple de code du lien.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
Option Explicit
Private Const C_NUM_DAYS_UNTIL_EXPIRATION = 30
 
Sub TimeBombWithDefinedName()
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' TimeBombWithDefinedName
' This procedure uses a defined name to store this workbook's
' expiration date. If the expiration date has passed, a
' MsgBox is displayed and this workbook is closed.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim ExpirationDate As String
Dim NameExists As Boolean
 
On Error Resume Next
ExpirationDate = Mid(ThisWorkbook.Names("ExpirationDate").Value, 2)
If Err.Number <> 0 Then
    '''''''''''''''''''''''''''''''''''''''''''
    ' Name doesn't exist. Create it.
    '''''''''''''''''''''''''''''''''''''''''''
    NameExists = False
    ExpirationDate = CStr(DateSerial(Year(Now), _
        Month(Now), Day(Now) + C_NUM_DAYS_UNTIL_EXPIRATION))
    ThisWorkbook.Names.Add Name:="ExpirationDate", _
        RefersTo:=Format(ExpirationDate, "short date"), _
        Visible:=False
Else
    NameExists = True
End If
 
''''''''''''''''''''''''''''''''''''''''''''''''''''''
' If the today is past the expiration date, close the
' workbook. If the defined name didn't exist, we need
' to Save the workbook to save the newly created name.
''''''''''''''''''''''''''''''''''''''''''''''''''''''
If CDate(Now) > CDate(ExpirationDate) Then
    MsgBox "This workbook trial period has expired.", vbOKOnly
    ThisWorkbook.Close savechanges:=False
End If
 
End Sub

Invité · 27/01/2017, 16h53

tu trouvera ICI le lien pour télécharger visuel studio 6

Nom : Sans titre.png
Affichages : 6094
Taille : 75,5 Ko

Nom : Sans titre.png
Affichages : 6007
Taille : 53,8 Ko

Nom : Sans titre.png
Affichages : 5946
Taille : 22,1 Ko

Nom : Sans titre.png
Affichages : 6127
Taille : 22,9 Ko

Nom : Sans titre.png
Affichages : 6033
Taille : 41,8 Ko

Nom : Sans titre.png
Affichages : 5921
Taille : 13,2 Ko

Nom : Sans titre.png
Affichages : 5951
Taille : 3,1 Ko

Comme tu peux le voir, avec p.Message("toto") le code est inaccessible!

Pour ceux qui pensent qu'il est possible de faire des applications professionnel avec VBA; je leurs répond qu'il est possible de s'approcher, mais professionnel non...

Quand on voit les possibilités de Visual studio en natifs, avec VBA on est loin du compte, sur tout que maintenant il est gratuit!en soit VBA n'est pas professionnel donc tout ce qui en émane ne l'est pas!

**RastaBomboclat** · 30/01/2017, 15h13

Bonjour dysorthographie,
Merci pour tout ces lien et details. Je m'y mets tout de suite. j'ai en effet jusqu'à lundi prochain pour presenter mon travail. je pense que j'y arriverai.

En cas de besion, je reviendrai

Invité · 30/01/2017, 15h26

bonjour RastaBomboclat,
pas de souci, si tu as besoin d'un coach! dans la mesure de mes disponibilités, pas de problème (peut-être as tu toujours mon mail rdurupt) .

le code pour la licence c'est que des 000 (zéro)

Code Module de classe :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
 
Private Sub Class_Initialize()
If Date > "28/02/2017" Then Err.Raise 1664, "Microsoft Excel", "Bonjour vas donc boire une bière à ma santé!"
End Sub
Public Function Message(t As String) As String
Message = t
End Function

**RastaBomboclat** · 31/01/2017, 11h42

Merci beaucoup du soutient.
On est bel est bien dans Developpez.net. J'adore ce site

Invité · 01/02/2017, 13h34

Bonjour,

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
Private Sub UserForm_Initialize() 
Me.Label1 = NavigateDate("http://ntp.alapetite.fr/date.txt.php")
End Sub
 
 
Private Function NavigateDate(ByVal address As String) As String
    If Trim("" & address) = "" Then Exit Function
    If address = "about:blank" Then Exit Function
 
  On Error Resume Next
        WebBrowser1.Navigate address
 NavigateDate = WebBrowser1.Document.GetElementsByTagName("html").Item(0).Document.body.innertext
End Function

**RastaBomboclat** · 01/02/2017, 17h56

Je suis encore coincé au niveau de l'installation de VB6.
J’avais pu télécharger les fichiers via le site que tu m’avais envoyé mais je n’arrive toujours pas à installer l’application parce que la décompression du fichier télécharger ce fait avec 2 erreurs (fichier .ini et un autre dont je ne me rappelle pus l’extension). Et quand je tente d’installer ça ne marche pas.
Quelqu’un m’a promis un disque d’installation (qu’il doit chercher dans ces archives…) et peut être que demain je pourrais l’avoir et commencer le travail. Je travaillerai le weekend apparemment

Invité · 01/02/2017, 18h18

Bonjour
Il faut créer un répertoire sur c:\ et ensuite copier le fichiers dedans et un click droit sur le setup.exe et en tant qu'admin,

**RastaBomboclat** · 03/02/2017, 13h37

Envoyé par dysorthographie

Bonjour
Il faut créer un répertoire sur c:\ et ensuite copier le fichiers dedans et un click droit sur le setup.exe et en tant qu'admin,

Merci, ça marche bien

.
J’ai déjà fait les principaux formulaires mais je suis bien coincé. Eh oui, sur VBA, je fesais référence à l'objet worksheet pour mes données sur la feuille Excel. Mais là, il n’y a pas de worksheet. Et jusque là, j’arrive a bien m’en sortir

avec mes lignes de codes VBA qui sont bien accepter dans VB6.

Afin de manipuler mes donnée, j’ai créé, en me débrouillant, une petite base de données sur Access. Avec 5 petites Tables (Tbl_Supplier ;Tbl_Invoices ; Tbl_Projects ; Tbl_Payment et Tbl_Bank qui est vraiment facultatif). Les relations et quelques requêtes sélections que j'ai fait semblent fonctionner correctement. Le problème maintenant c’est de connecter la base aux formulairex, et bien référencer les tables et les colonnes à prendre.

J’ai vu, çà et là sur le Net, quelques codes VBA pour la connexion Excel vs Access, mais ça m’a l’air d’astuces pour avancés et chevronnés. C’est du nouveau pour moi le VBA-SQL

Invité · 03/02/2017, 14h51

Bonjour RastaBomboclat,

oui Vb6 c'est comme vba quand tu veux utiliser Word, il faut déclarer le références; mais je te conseil d'utiliser des objet "Object"!

Nom : Sans titre.png
Affichages : 5907
Taille : 16,0 Ko

Nom : Sans titre.png
Affichages : 5907
Taille : 16,0 Ko

Code DLL Module de classe1 VB6 :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Public Enum ConstXls
    xlWhole = 1
    xlPart = 2
End Enum
Public cn As New ADODBRD
Public Function NewExcel() As Object
Set NewExcel = CreateObject("Excel.Application")
End Function
Public Function NewClasseur(XlApp As Object) As Object
Set NewClasseur = XlApp.Workbooks.Add
End Function
Public Function NewFeuille(Claseur As Object) As Object
Set NewFeuille = Claseur.Sheets.Add
End Function
 
 
Public Function SerchXls(Myrange As Object, MyCellule As Object, strRecherche, EntierCell As ConstXls, EnBoucle As Boolean) As Long '
On Error Resume Next
SerchXls = 0
   SerchXls = Myrange.Cells.Find(What:=strRecherche, After:=MyCellule, LookIn:=-4123, LookAt _
        :=EntierCell, SearchOrder:=1, SearchDirection:=1, MatchCase:= _
        False, SearchFormat:=False).Row
  If SerchXls <= MyCellule.Row And EnBoucle = False Then SerchXls = 0
End Function

Code DLL Classe ADODBRD VB6 :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
 
Private Connexion
Public TYPEBASE As MyAdo
Public BASE
Public Server
Public Fichier
Public User
Public PassWord
Enum MyAdo
 ACCESS97 = 1
ACCESS2000 = 2
ACCESS2012 = 3
ODBC = 4
ORACLE = 5
 SQLSERVER2005 = 6
SQLServer2008R2 = 7
SQLite = 8
SQLite3 = 9
CSV = 10
ExcelSensTire = 11
ExcelAvecTire = 12
End Enum
 
 
Private Function GenereCSTRING()
'Permet de générer le Cornec String
'1 - ACCESS 97
'2 - ACCESS 2000
'3 - ACCESS 2012
'4 - ODBC
'5 - ORACLE
'6 - SQL SERVER 2005
'7 - SQL Server 2008 R2
'8 - SQLite
'9 - SQLite3
If Trim("" & Fichier) = "" Then Fichier = BASE
 
 
Select Case TYPEBASE
    Case ExcelAvecTire
        GenereCSTRING = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & BASE & ";Extended Properties=""Excel 12.0;HDR=YES;"""
    Case ExcelSensTire
        GenereCSTRING = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & BASE & ";Extended Properties=""Excel 12.0;HDR=no;"""
    Case ACCESS97
        GenereCSTRING = "Provider=Microsoft.Jet.OLEDB.3.51;Persist Security Info=False;Data Source=" & Fichier
    Case ACCESS2000
        GenereCSTRING = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Fichier & ";Persist Security Info=False"
    Case ACCESS2012
        GenereCSTRING = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Fichier & ";"
 
    Case ODBC
        GenereCSTRING = "Provider=MSDASQL.1;Password=" & PassWord & ";Persist Security Info=True;User ID=" & User & ";Data Source=" & BASE
    Case ORACLE
        GenereCSTRING = "Provider=OraOLEDB.Oracle.1;Password=" & PassWord & ";Persist Security Info=True;User ID=" & User & ";Data Source=" & BASE
    Case SQLSERVER2005
        GenereCSTRING = "Provider=SQLOLEDB.1;Password=" & PassWord & ";Persist Security Info=True;User ID=" & User & ";Initial Catalog=" & BASE & ";Data Source=" & Server
    Case SQLServer2008R2
        GenereCSTRING = "Provider=SQLNCLI;Server=" & Server & ";Database=" & BASE & ";UID=" & User & ";PWD=" & PassWord & ";"
    Case SQLite
        GenereCSTRING = "Provider=OleSQLite.SQLiteSource.3; Data Source=" & Fichier
        GenereCSTRING = "Driver={SQLite ODBC (UTF-8) Driver};Database=" & Fichier & ";StepAPI=;Timeout="
    Case SQLite3
        GenereCSTRING = "Driver={SQLite3 ODBC Driver};Database=" & Fichier & ";LongNames=0;Timeout=4000;NoTXN=0;SyncPragma=NORMAL;StepAPI=0;"
    Case CSV
        GenereCSTRING = "ODBC;DBQ=" & Fichier & ";Driver={Microsoft Text Driver (*.txt; *.csv)}; " & "DriverId=27;Extensions=txt,csv,tab,asc;FIL=text;MaxBufferS"
    Connex.Open
    Case Else
        GenereCSTRING = "PAS ASSEZ DE PARAMETRES RENSEIGNES !!!"
 
 
 
 
End Select
''MsgBox GenereCSTRING
'Response.End
End Function
Public Function OpenConnetion()
'Ouvre une connexion à  la base de données.
'Dim Fso As New Scripting.FileSystemObject
    OpenConnetion = False
    On Error Resume Next
    Dim ConnecString
 
 
     Dim NbErr
 
 
    Set Connexion = CreateObject("ADODB.Connection")
    Connexion.Open GenereCSTRING
'ConnecString
 
 
    If Err = 0 Then
 
 
        OpenConnetion = True
       Connexion.CommandTimeout = 14400
    Else
'  MsgBox Err.Description
 
 
    End If
'    Debug.Print Err.Description
    Err.Clear
    On Error GoTo 0
End Function
 
 
 
 
Public Function CloseConnection()
'Referme la connexion
CloseConnection = False
On Error Resume Next
    Connexion.Close
    Set Connexion = Nothing
     If Err = 0 Then
        CloseConnection = True
    End If
    Err.Clear
    On Error GoTo 0
End Function
 
 
 
 
Public Function OpenRecordSet(Sql)
'Retourne un RecordeSet
On Error Resume Next
    Dim Rs
Dim NbErr
 
 
Err.Clear
If Connexion.State = 0 Then
    OpenConnetion
End If
'Debug.Print Sql 'Replace(Sql, "%", "*")
    Set OpenRecordSet = CreateObject("ADODB.Recordset")
 
 
   ' OpenRecordSet.LockType = adLockOptimistic
    ''MsgBox  adLockOptimistic & vbcrlf & Err.Description
    OpenRecordSet.Open Sql, Connexion, 1, 3
 
 
    If Err Then
'   MsgBox Err.Description
 
 
    NbErr = NbErr + 1
        If NbErr < 11 Then
 
 
            Set OpenRecordSet = Nothing
 
 
 
 
        End If
 
 
    End If
    Err.Clear
 
 
End Function
Public Function RetournConnection()
Set RetournConnection = Connexion
End Function
Public Function OpenRecordSetParametre(Sql, Param)
Dim Commande
Dim Params
Set Commande = CreateObject("ADODB.Command")
Dim MyParameter
Set MyParameter = CreateObject("ADODB.Parameter")
Set Commande.ActiveConnection = Connexion
Commande.CommandText = "select Requête2.* from Requête2;"
 Commande.CommandType = adCmdText
 
 
 Set MyParameter = Commande.CreateParameter("[NumJob]", adNumeric)
         MyParameter.Value = 10
Commande.Parameters.Append MyParameter
 
 
 
 
 
 
'aa.Parameters.Append("MyRef") = "243410M660"
Set Rs2 = Commande.Execute
 
 
End Function
Public Function CloseRecordSet(Rs)
On Error Resume Next
    Rs.Close
    Set CloseRecordSet = Nothing
End Function
Public Function Execute(Sql)
    Execute = False
    On Error Resume Next
    Dim NbErr
Reprise:
If Connexion.State = 0 Then
    OpenConnetion
End If
Debug.Print Sql
    Connexion.Execute Sql
    If Err = 0 Then
        Execute = True
 
 
 
 
 
 
 
 
'     Else
'    'MsgBox Err.Description
'         Err.Clear
'    NbErr = NbErr + 1
'    If NbErr < 11 Then
'
'        GoTo Reprise
'    End If
Else
    MsgBox Err.Description
    End If
 
 
    Err.Clear
 
 
End Function

Code Module standard dans Excel :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Sub test()
Dim p As New Project1.Classe1, xl As Excel.Application, wb As Workbook, sh As Worksheet
Set xl = p.NewExcel: xl.Visible = True
Set wb = p.NewClasseur(xl)
Set sh = p.NewFeuille(wb)
sh.Range("D3") = "toto"
 If CBool(p.SerchXls(sh.Columns("D:D"), sh.Range("D1"), "toto", xlWhole, False)) Then
        MsgBox "Le numéro de commande est déja utilisé."
  End If
p.cn.TYPEBASE = ACCESS2012: p.cn.BASE = "C:\Users\rdurupt\Desktop\AccessBd\Test.accdb"
p.cn.OpenConnetion
Set Rs = p.cn.OpenRecordSet("select * from [table]")
sh.Range("D3").CopyFromRecordset Rs
End Sub

Créer un module de date d’expiration d’une application (comme un trial)

Macros et VBA Excel

Discussions similaires

Partager

Partager