Le but de ce code est de diffuser les plannings, tout en empéchant l'impression de ces derniers. Mouais c'est pas gentil mais le personnel perdait son planning tous les deux jours et le réimprimait. La personne chargée des plannings passait une après midi entière à aller les afficher, à chaque modification.
Planniciel propose de créer les fichiers dans plusieurs formats (.doc .xls .htm) j'ai retenu le format HTML car c'est celui qui rendait le meilleur aspect.
le programme en lui même est logé dans un dossier partagé (où j'ai donné les droits en écriture aux personnes chargées des plannings, le reste du personnel l'a en acces lecture et exécution seulement). Les ordinateurs des salles de soins (je bosse dans un hopital) ont un raccourci vers ce programme sur le bureau. Les fichiers HTML et .Txt que le programme appelle sont dans un dossier caché "pln" logé dans le même dossier que l'application (l'informaticien a réussi à empécher l'affichage des fichiers cachés sur ces PC).
Il affiche le mois en cours et le mois suivant.
Les fichiers 01.txt 02.txt .... 12.txt correspondent aux mois de l'année. Ils contiennent sur chaque ligne le nom du planning, le séparateur "<%;%>" et l'addresse partielle du fichier HTML du planning. Là maintenant nous sommes en septembre. dans le zip j'ai mis un planning anonymisé (celui de Antares) afin que vous puissiez voir le résultat.
voila, en espérant que ce code puisse vous inspirer pour d'autres programmes.
Source / Exemple :
Dim table() As String
Dim erri As String, chemin As String, r As Boolean
Dim i As Integer
Dim dateactu() As String, datemoissuivant() As String
Private Sub Command1_Click()
'*************** bouton retour*****************
'page blanche
WebBrowser1.navigate ("file://" & App.Path & "PLN\Blanc.HTM")
'Masquer l'affichage du planning
Command1.Visible = False
WebBrowser1.Visible = False
Picture1.Visible = False
VScroll1.Visible = False
HScroll1.Visible = False
'afficher la Frame de selection du planning
Frame1.Visible = True
End Sub
Private Sub Command2_Click()
'****************Bouton QUITTER******************
End
End Sub
Private Sub Form_Load()
erri = Date
'recherche du mois en cours
dateactu = Split(erri, "/")
Option1.Caption = "du mois " & dateactu(1) & "/" & dateactu(2)
'date mois suivant
erri = DateAdd("m", 1, Date)
datemoissuivant = Split(erri, "/")
Option2.Caption = "du mois " & datemoissuivant(1) & "/" & datemoissuivant(2)
'une page blanche par défaut dans le webbrowser (c'est inutile)
WebBrowser1.navigate ("file://" & App.Path & "\PLN\Blanc.HTM")
'chargement du fichier texte de données du mois en cours dans le tableau nommé table
r = ImportTxtFile(App.Path & "\PLN\" & dateactu(1) & ".txt", "<%;%>", table, erri)
List1.Clear
'remplir list box
For i = LBound(table(), 1) To UBound(table(), 1)
List1.AddItem (table(i, 1))
Next i
End Sub
Private Sub Form_Resize()
'condition pour ne pas planter en cas de réduction de l'application
If Form1.Height > 360 Then
Picture1.Top = 1320
Picture1.Height = Form1.Height - 2145
Picture1.Left = 0
Picture1.Width = Form1.Width - 150
VScroll1.Left = Picture1.Width - 250
VScroll1.Height = Picture1.Height
HScroll1.Top = Picture1.Top + Picture1.Height - 250
HScroll1.Width = Picture1.Width - VScroll1.Width
VScroll1.Height = Picture1.Height - HScroll1.Height
End If
End Sub
Private Sub Option1_click()
r = ImportTxtFile(App.Path & "\PLN\" & dateactu(1) & ".txt", "<%;%>", table, erri)
List1.Clear
'remplir list box
For i = LBound(table(), 1) To UBound(table(), 1)
List1.AddItem (table(i, 1))
Next i
End Sub
Private Sub Option2_click()
r = ImportTxtFile(App.Path & "\PLN\" & datemoissuivant(1) & ".txt", "<%;%>", table, erri)
List1.Clear
'remplir list box
For i = LBound(table(), 1) To UBound(table(), 1)
List1.AddItem (table(i, 1))
Next i
End Sub
'****************les barres de défillement***************
Private Sub VScroll1_Change()
WebBrowser1.Top = -VScroll1.Value
End Sub
Private Sub HScroll1_Change()
WebBrowser1.Left = -HScroll1.Value
End Sub
Private Sub List1_Click()
'************************Affichage du planning sélectionné***************
'condition écartant la première valeur de la listbox (valeur nulle)
If List1.ListIndex <> 0 Then
'masquer l'interface de choix du planning
Frame1.Visible = False
'afficher les objets nécessaires à la lecture du planning
Command1.Visible = True
Picture1.Visible = True
VScroll1.Visible = True
HScroll1.Visible = True
WebBrowser1.Visible = True
'charger le fichier html
chemin = "file://" & App.Path & "\" & table(List1.ListIndex, 2)
WebBrowser1.navigate (chemin)
'emplacement des objets relatif à la taille de la form
Call Form_Resize
End If
End Sub
Private Function ImportTxtFile(ByVal fileName As String, ByVal separator As String, ByRef tData() As String, ByRef errorString As String, Optional ByVal baseArray As Integer = 1) As Boolean
Dim f As Integer
Dim tLine() As String
Dim tSplit() As String
Dim buffer As String
Dim nbItem As Long
Dim k As Long, l As Long
On Error GoTo ImportTxtFile_ERR
f = FreeFile()
Open fileName For Binary As #f
buffer = Space$(LOF(f))
Get #f, , buffer
Close #f
tSplit() = Split(buffer, vbCrLf)
nbItem = UBound(Split(tSplit(0), separator)) + baseArray
ReDim tData(UBound(tSplit()) + baseArray, nbItem)
For k = LBound(tSplit()) To UBound(tSplit())
tLine = Split(tSplit(k), separator)
For l = LBound(tLine) To UBound(tLine)
tData(k + baseArray, l + baseArray) = tLine(l)
Next l
Next k
ImportTxtFile = True
ImportTxtFile_END:
Exit Function
ImportTxtFile_ERR:
errorString = Err.Description
Resume ImportTxtFile_END
End Function
Conclusion :
mouhaha mon commentaire est plus long que le code.
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.