Aide pour pb de date

[sebgo]

Bonjour le forum,
Je suis à la recherche d'aide pour procedure VBA me permettant de limiter le delai d'utilisation d'un fichier à un nombre de jours à l'ouverrture du fichier (par exemple à partir de 30 jours). N'étant pas expert dans la programmation j'ai bénéficié de l'aide d'un ami (que je salue au passage) mais le programme buggue à cause d'une ligne du code (le message à retourner). Voici le code:

Sub ouvre_ou_cree_evaluation()
Application.ScreenUpdating = False
'Teste si date.xls existe
If Dir('C:\\essai\\date.xls') = '' Then
'Teste si le répertoire essai existe.
'Si non, on crée le répertoire
If Dir('C:\\essai\\', vbDirectory) = '' Then MkDir 'C:\\essai'
'Crée le fichier avec la date du jour
Workbooks.Add
ActiveCell.FormulaR1C1 = Date
ActiveWorkbook.SaveAs Filename:='C:\\essai\\date.xls', FileFormat:=xlNormal, _
Password:='', WriteResPassword:='', ReadOnlyRecommended:=False, _
CreateBackup:=False
ActiveWindow.Close
End If
'Ouvrir et masquer le fichier evaluation
Workbooks.Open Filename:='C:\\essai\\date.xls'
If Range('A1').Value + 30 < Date Then
'la date est dépassée
ActiveWindow.Close
MsgBox 'Date d'utilisation dépassée', vbOKOnly, 'Désolé'
Else
'La date n'est pas dépassée
ActiveWindow.Close
MsgBox 'il vous reste' & 30 - Range('A1').Value, vbOKOnly, 'Attention'
End If
Application.ScreenUpdating = True
End Sub
En résumé je veux qu'il retourne le message suivant à la premiere ouverture du fichier de la journée (les autres ouvertures au cours de la même journée il n'affiche pas le message d'avertissement):
'Il vous reste x jours à utiliser ce fichier). X=Date expiration - Date du jour.
Merci d'avance pour votre aide et bon WE à tous.

 

[soft]

Je pense que ça doit faire qqchose comme ça :

Sub ouvre_ou_cree_evaluation()
Dim Ouverture1 As Boolean
Application.ScreenUpdating = False
Ouverture1 = True
'Teste si date.xls existe
If Dir('C:\\essai\\date.xls') = '' Then
'Teste si le répertoire essai existe.
'Si non, on crée le répertoire
If Dir('C:\\essai', vbDirectory) = '' Then MkDir 'C:\\essai'
'Crée le fichier avec la date du jour
Workbooks.Add
Range('A1') = Date
ActiveWorkbook.SaveAs Filename:='C:essaidate.xls', FileFormat:=xlNormal, _
Password:='', WriteResPassword:='', ReadOnlyRecommended:=False, _
CreateBackup:=False
ActiveWindow.Close
End If
'Ouvrir et masquer le fichier evaluation
Workbooks.Open Filename:='C:\\essai\\date.xls'
If Range('A1').Value + 30 < Date Then
'la date est dépassée
ActiveWindow.Close
MsgBox 'Date d'utilisation dépassée', vbOKOnly, 'Désolé'
Else
'La date n'est pas dépassée
'déjà ouvert aujourdhui
If Range('A2') = Date Then Ouverture1 = False
Range('A2') = Date
ActiveWindow.Close
End If
If Ouverture1 = True Then
MsgBox 'Il vous reste ' & (Range('A1').Value + 30) - Date & ' jours'
End If
End Sub

A part, ça, c'est pas très efficace comme protection ...

 

[sebgo]

Salut Soft, le Forum
Merci bcp pour ton aide. Je l'ai essayé mais il me renvoie le message pour l'enregistrement du fichier essaidate. En faite mon code initial marche si je remplace le dernier message par:
MsgBox 'Vous pouvez utiliser cette application', vbOKOnly, 'Information'
Ici il n'ya aucune reference au delai d'expiration. c'est ce que je veux changer.
Je vais continuer à chercher aussi de mon coté. Une fois encore merci.
Bonne journée à tous.

 

[soft]

Oui, apparemment les backs slash sont supprimés quand on enregistre un message ici.

Le fichier créer est dans 'c' répertoire 'essai' et s'apelle 'date.xls', donc il faut reprendre les lignes :

If Dir('C:\\essai\\date.xls') = '' Then
...
If Dir('C:\\essai', vbDirectory) = '' Then MkDir 'C:\\essai'
...
ActiveWorkbook.SaveAs Filename:='C:\\essai\\date.xls', FileFormat:=xlNormal, _
...
Workbooks.Open Filename:='C:\\essai\\date.xls'

Message édité par: soft, à: 22/10/2005 16:31

 

[sebgo]

Salut Soft, le Forum
Effectivement je m'étais dit que ce sont les backs slash qui ne marchaient pas car dans le code que j'ai envoyé ils ne sont pas aussi ressortis, donc j'ai pris le soins de les remettre mais il me demande si je veux enregistrer. Je crois que le probleme réside dans le dernier Msgbox. La formule (Range('A1').Value + 30) - Date semble incompatible. Peut-être que Range(A1).Value n'est pas de format date. En regardant de ce coté je crois que la soluce peut être trouvée.En effet ce n'est qu'une supposition.
Merci bcp et A+.

 

[soft]

Oui, change après

If Ouverture1 = True Then
.....
if isdate(Range('A1').Value) then
msgbox 'Il vous reste ' & (CDate(Range('A1').Value) + Day(30)) - Date & ' jours'
end if
End If
End Sub

 

[sebgo]

Salut Soft, le forum
J'ai apporté la drenière modification mais aucun changement.
Il me retourne le message d'enregistrement.
Encore merci pour ton aide
A+