DIFFUSION VIA UN INTRANET DES PLANNINGS DU LOGICIEL "PLANNICIEL"

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

Télécharger le zip