Webntcvs : consultation d'un référenciel nt-cvs depuis un navigateur web

Soyez le premier à donner votre avis sur cette source.

Vue 7 488 fois - Téléchargée 808 fois

Description

Serveur HTTP permettant d?afficher le référentiel d?un serveur CVS sous NT, à la façon de WebCVS, sans l?installation d?Apache, Python et Perl !!!

Le programme intègre :
- Gestion du protocole HTTP (le port est paramétrable par le fichier .INI)
- Recherche du 'référentiel' sur serveur NT-CVS dans la base de registre.
- Lecture et nagigation dans les 'modules' et fichiers à partir de ces référentiels.
- Téléchargement de la dernière version d'un fichier (en 'natif' dans le code)
- Composition d?une page HTML avec gestion de tableaux (via des Classes VB maison) ou Intégration dans un modèle de page HTML.
- Limitation de certaine partie du référenciel à un ou plusieurs user. (non de machine ou masque sur l'adresse IP)
- Démarrage avec la session de windows ou en tant que service.

Source / Exemple :


Extrait des deux modules les plus intéressant du ZIP...

  - WebNTCVS_HTTP.bas : Gestion du serveur HTTP (via un controle Winsock situé sur la form
  - WebNTCVS.bas      : Lecture du repository, composition de la page HTML

~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Module WebNTCVS_HTTP.bas
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Attribute VB_Name = "MdlHTTP"
'=======================================================================================
' WebNTCVS : Gestion du protocule HTTP
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' (C) Patrick Moire
' http://jeux.cartes.free.fr
' jeux.cartes@free.fr
'=======================================================================================
Option Explicit

'_______________________________________________________________________________________
'
' Extrait de : http://www.commentcamarche.net/internet/http.php3
'_______________________________________________________________________________________
'
' Une requête HTTP a la syntaxe suivante (<crlf> signifie retour chariot ou saut de ligne):
'
' | METHODE URL VERSION<crlf>
' | EN-TETE : Valeur<crlf>
' | .
' | .
' | .
' | EN-TETE : Valeur<crlf>
' | Ligne vide<crlf>
' | CORPS DE LA REQUETE
'
'  Voici donc un exemple de requête HTTP:
'
' | GET http://www.commentcamarche.net HTTP/1.0
' | Accept : text/html
' | If-Modified-Since : Saturday, 15-January-2000 14:37:11 GMT
' | User-Agent : Mozilla/4.0 (compatible; MSIE 5.0; Windows 95)
 
'  Commandes
'
'   GET     Requête de la ressource située à l'URL spécifiée
'   HEAD    Requête de l'en-tête de la ressource située à l'URL spécifiée
'   POST    Envoi de données au programme situé à l'URL spécifiée
'   PUT     Envoi de données à l'URL spécifiée
'   DELETE  Suppression de la ressource située à l'URL spécifiée
'
'  En -têtes
'
'   Accept            Type de contenu accepté par le browser (par exemple text/html). Voir types MIME
'   Accept-Charset    Jeu de caractères attendu par le browser
'   Accept-Encoding   Codage de données accepté par le browser
'   Accept-Language   Langage attendu par le browser (anglais par défaut)
'   Authorization     Identification du browser auprès du serveur
'   Content-Encoding  Type de codage du corps de la requête
'   Content-Language  Type de langage du corps de la requête
'   Content-Length    Longueur du corps de la requête
'   Content-Type      Type de contenu du corps de la requête (par exemple text/html). Voir types MIME
'   Date              Date de début de transfert des données
'   Forwarded         Utilisé par les machines intermédiaires entre le browser et le serveur
'   From              Permet de spécifier l'adresse e-mail du client
'   From              Permet de spécifier que le document doit être envoyé s'il a été modifié depuis une certaine date
'   Link              Relation entre deux URL
'   Orig-URL          URL d'origine de la requête
'   Referer           URL du lien à partir duquel la requête a été effectuée
'   User-Agent        Chaîne donnant des informations sur le client, comme le nom et la version du navigateur, du système d'exploitation
'
'
'
'
' Une réponse HTTP a la syntaxe suivante (<crlf> signifie retour chariot ou saut de ligne):
'
' | VERSION-HTTP CODE EXPLICATION<crlf>
' | EN-TETE : Valeur<crlf>
' | .
' | .
' | .
' | EN-TETE : Valeur<crlf>
' | Ligne vide<crlf>
' | CORPS DE LA REPONSE
'
'  Voici donc un exemple de réponse HTTP:
'
' | HTTP/1.0 200 OK
' | Date : Sat, 15 Jan 2000 14:37:12 GMT
' | Server:  Microsoft -IIS / 2#
' | Content-Type : text/HTML
' | Content-Length : 1245
' | Last-Modified : Fri, 14 Jan 2000 08:25:13 GMT
'
'
'  En-têtes de réponse
'
'   Content-Encoding  Type de codage du corps de la réponse
'   Content-Language  Type de langage du corps de la réponse
'   Content-Length    Longueur du corps de la réponse
'   Content-Type      Type de contenu du corps de la réponse (par exemple text/html). Voir types MIME
'   Date              Date de début de transfert des données
'   Expires           Date limite de consommation des données
'   Forwarded         Utilisé par les machines intermédiaires entre le browser et le serveur
'   Location          Redirection vers une nouvelle URL associée au document
'   Server            Caractéristiques du serveur ayant envoyé la réponse
'
'  Les codes de réponse
'
'     Ce sont les codes que vous voyez lorsque le navigateur n'arrive pas à vous fournir la page demandée.
'   Le code de réponse est constitué de trois chiffres: le premier indique la classe de statut et les suivants
'   la nature exacte de l'erreur.
'
'   200  OK                   La requête a été accomplie correctement
'   201  CREATED              Elle suit une commande POST, elle indique la réussite, le corps du reste du document est sensé indiquer l'URL à laquelle le document nouvellement créé devrait se trouver.
'   202  ACCEPTED             La requête a été acceptée, mais la procédure qui suit n'a pas été accomplie
'   203  PARTIAL INFORMATION  Lorsque ce code est reçu en réponse à une commande GET, cela indique que la réponse n'est pas complète.
'   204  NO RESPONSE          Le serveur a reçu la requête mais il n'y a pas d'information à renvoyer
'   205  RESET CONTENT        Le serveur indique au navigateur de supprimer le contenu des champs d'un formulaire
'   206  PARTIAL CONTENT      Il s'agit d'une réponse à une requête comportant l'en-tête range. Le serveur doit indiquer l'en-tête content-Range
'
'   30x Redirection Ces codes indiquent que la ressource n'est plus à l'emplacement indiqué
'
'   301 MOVED                 Les données demandées ont été transférées à une nouvelle adresse
'   302 FOUND                 Les données demandées sont à une nouvelle URL, mais ont cependant peut-être été déplacées depuis...
'   303 METHOD                Cela implique que le client doit essayer une nouvelle adresse, en essayant de préférence une autre méthode que GET
'   304 NOT MODIFIED          Si le client a effectué une commande GET conditionnelle (en demandant si le document a été modifié depuis la dernière fois) et que le document n'a pas été modifié il renvoie ce code.
'
'   40x  Erreur due au client Ces codes indiquent que la requête est incorrecte
'
'   400  BAD REQUEST          La syntaxe de la requête est mal formulée ou est impossible à satisfaire
'   401  UNAUTHORIZED         Le paramètre du message donne les spécifications des formes d'autorisation acceptables. Le client doit reformuler sa requête avec les bonnes données d'autorisation
'   402  PAYMENT REQUIRED     Le client doit reformuler sa demande avec les bonnes données de paiement
'   403  FORBIDDEN            L 'accès à la ressource est tout simplement interdit
'   404  NOT FOUND            Classique! Le serveur n'a rien trouvé à l'adresse spécifiée. Parti sans laisser d'adresse... :)
'
'   50x  Erreur due au serveur Ces codes indiquent qu'il y a eu une erreur interne du serveur
'
'   500  INTERNAL ERROR       Le serveur a rencontré une condition inattendue qui l'a empêché de donner suite à la demande (comme quoi il leur en arrive des trucs aux serveurs...)
'   501  NOT IMPLEMENTED      Le serveur ne supporte pas le service demandé (on ne peut pas tout savoir faire...)
'   502  BAD GATEWAY          Le serveur a reçu une réponse invalide de la part du serveur auquel il essayait d'accéder en agissant comme une passerelle ou un proxy
'   503  SERVICE UNAVAILABLE  Le serveur ne peut pas vous répondre à l'instant présent, car le trafic est trop dense (toutes les lignes de votre correspondant sont occupées veuillez rappeler ultérieurement)
'   504  GATEWAY TIMEOUT      La réponse du serveur a été trop longue vis-à-vis du temps pendant lequel la passerelle était préparée à l'attendre (le temps qui vous était imparti est maintenant écoulé...)

Private Declare Sub GetSystemTime Lib "kernel32" (lpSystemTime As SYSTEMTIME)
Private Declare Function GetDateFormat Lib "kernel32" Alias "GetDateFormatA" (ByVal Locale As Long, ByVal dwFlags As Long, lpDate As SYSTEMTIME, ByVal lpFormat As String, ByVal lpDateStr As String, ByVal cchDate As Long) As Long

Private Type SYSTEMTIME
  wYear As Integer
  wMonth As Integer
  wDayOfWeek As Integer
  wDay As Integer
  wHour As Integer
  wMinute As Integer
  wSecond As Integer
  wMilliseconds As Integer
End Type

Public Enum EnumLangue
  LANG_DEFAULT = &H0
  LANG_AFRIKAANS = &H36
  LANG_ALBANIAN = &H1C
  LANG_ARABIC = &H1
  LANG_ARMENIAN = &H2B
  LANG_ASSAMESE = &H4D
  LANG_AZERI = &H2C
  LANG_BASQUE = &H2D
  LANG_BELARUSIAN = &H23
  LANG_BENGALI = &H45
  LANG_BULGARIAN = &H2
  LANG_CATALAN = &H3
  LANG_CHINESE = &H4
  LANG_CROATIAN = &H1A
  LANG_CZECH = &H5
  LANG_DANISH = &H6
  LANG_DUTCH = &H13
  LANG_ENGLISH = &H9
  LANG_ESTONIAN = &H25
  LANG_FAEROESE = &H38
  LANG_FARSI = &H29
  LANG_FINNISH = &HB
  LANG_FRENCH = &HC
  LANG_GEORGIAN = &H37
  LANG_GERMAN = &H7
  LANG_GREEK = &H8
  LANG_GUJARATI = &H47
  LANG_HEBREW = &HD
  LANG_HINDI = &H39
  LANG_HUNGARIAN = &HE
  LANG_ICELANDIC = &HF
  LANG_INDONESIAN = &H21
  LANG_ITALIAN = &H10
  LANG_JAPANESE = &H11
  LANG_KANNADA = &H4B
  LANG_KASHMIRI = &H60
  LANG_KAZAK = &H3F
  LANG_KONKANI = &H57
  LANG_KOREAN = &H12
  LANG_LATVIAN = &H26
  LANG_LITHUANIAN = &H27
  LANG_MACEDONIAN = &H2F
  LANG_MALAY = &H3E
  LANG_MALAYALAM = &H4C
  LANG_MANIPURI = &H58
  LANG_MARATHI = &H4E
  LANG_NEPALI = &H61
  LANG_NORWEGIAN = &H14
  LANG_ORIYA = &H48
  LANG_POLISH = &H15
  LANG_PORTUGUESE = &H16
  LANG_PUNJABI = &H46
  LANG_ROMANIAN = &H18
  LANG_RUSSIAN = &H19
  LANG_SANSKRIT = &H4F
  LANG_SERBIAN = &H1A
  LANG_SINDHI = &H59
  LANG_SLOVAK = &H1B
  LANG_SLOVENIAN = &H24
  LANG_SPANISH = &HA
  LANG_SWAHILI = &H41
  LANG_SWEDISH = &H1D
  LANG_TAMIL = &H49
  LANG_TATAR = &H44
  LANG_TELUGU = &H4A
  LANG_THAI = &H1E
  LANG_TURKISH = &H1F
  LANG_UKRAINIAN = &H22
  LANG_URDU = &H20
  LANG_UZBEK = &H43
  LANG_VIETNAMESE = &H2A
  LANG_YIDDISH = &H3D
End Enum

'===============================================================================================
' Reception Requette HTTP
'===============================================================================================

Public Sub HTTPRecept(Wsk As Winsock, Buffer As String)
  
  Dim CmdLine As Variant
  Dim Cmd As Variant
  
  Dim Id As Long
  Dim ExtendFile As String
  
   '--------------------------- Recherche de la methode...
    CmdLine = Split(Buffer, vbLf)
    Cmd = Split(CmdLine(0), " ")
    Select Case UCase(Trim(Cmd(0)))
      
     '- - - - - - - - - - - - Requête de la ressource située à l'URL spécifiée
      Case "GET"
        If Cmd(1) = "/" Or Left(Cmd(1), 5) = "/CVS?" Then
          Buffer = MdlCVS.MakePage(Cmd(1), GetHostNameFromIP(Wsk.RemoteHostIP))
        Else
          Id = FreeFile
          On Error GoTo OpenFile
           Open App.Path & Replace(Cmd(1), "/", "\") For Input As Id: Close Id
           Open App.Path & Replace(Cmd(1), "/", "\") For Binary As Id
          On Error GoTo ReadFile
           Buffer = Input(LOF(Id), Id)
          On Error GoTo 0
          Close Id
          ExtendFile = ".gif"
        End If
        Envoie Wsk, MakeEntete("200 OK", Buffer, ExtendFile)
        
     '- - - - - - - - - - - - Requête de l'en-tête de la ressource située à l'URL spécifiée
      Case "HEAD"
        Envoie Wsk, MakeEntete("501 NOT IMPLEMENTED")
     
     '- - - - - - - - - - - - Envoi de données au programme situé à l'URL spécifiée
      Case "POST"
        Envoie Wsk, MakeEntete("501 NOT IMPLEMENTED")
      
     '- - - - - - - - - - - - Envoi de données à l'URL spécifiée
      Case "PUT"
        Envoie Wsk, MakeEntete("501 NOT IMPLEMENTED")
      
     '- - - - - - - - - - - - Suppression de la ressource située à l'URL spécifiée
      Case "DELETE"
        Envoie Wsk, MakeEntete("501 NOT IMPLEMENTED")
     
     '- - - - - - - - - - - - Commande non reconnu
      Case Else
        Envoie Wsk, MakeEntete("400 BAD REQUEST")
    End Select
    Exit Sub
    
OpenFile:
  Envoie Wsk, MakeEntete("404  NOT FOUND")
  Exit Sub
    
ReadFile:
  Close Id
  Envoie Wsk, MakeEntete("401  UNAUTHORIZED")
  Exit Sub

Resume
End Sub

'===============================================================================================
' Emission Réponce HTTP
'===============================================================================================

Private Sub Envoie(Wsk As Winsock, ByVal Texte As String)
  Wsk.SendData Texte
End Sub

'-----------------------------------------------------------------------------------------------
' Creation Entete HTTP
'-----------------------------------------------------------------------------------------------

Private Function MakeEntete(Status As String, Optional Data As String, Optional DataType As String) As String
  MakeEntete = "HTTP/1.0 " & Status & vbCrLf & _
               "Date : " & HTTPDate(LANG_ENGLISH) & vbCrLf & _
               "Server:  " & App.EXEName & "/" & App.Major & "." & App.Minor & App.Revision & vbCrLf
  If Data > "" Then MakeEntete = MakeEntete & _
               "Content-Length : " & Len(Data) & vbCrLf & _
               "Content-Type : " & GetProfileString("mime", DataType, "text/html") & vbCrLf & _
               vbCrLf & Data
End Function

'-----------------------------------------------------------------------------------------------
' Récupération la date sous la forme "Sat, 15 Jan 2000 14:37:12 GMT" dans une langue choisie !
'-----------------------------------------------------------------------------------------------

Private Function HTTPDate(Optional pLangue As EnumLangue) As String
  Dim Buffer As String * 255
  Dim SysTime As SYSTEMTIME
    GetSystemTime SysTime
    GetDateFormat pLangue, 0, SysTime, "ddd, dd MMM dd yyyy", Buffer, Len(Buffer)
    HTTPDate = Left$(Buffer, InStr(1, Buffer, Chr$(0)) - 1) & " " & Format(SysTime.wHour, "00") & ":" & Format(SysTime.wMinute, "00") & ":" & Format(SysTime.wSecond, "00") & " GMT"
End Function

~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Module WebNTCVS.bas
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Attribute VB_Name = "MdlCVS"
'=======================================================================================
' WebNTCVS : Gestion des informations du serveur CVS
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' (C) Patrick Moire
' http://jeux.cartes.free.fr
' jeux.cartes@free.fr
'=======================================================================================
Option Explicit

Const REG_SZ = 1 ' Unicode nul terminated string
Const REG_BINARY = 3 ' Free form binary

Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long

Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003

' Entête d'un fichier sauvegarde par CVS
'
' |   head  1.1;
' |   access;
' |   symbols;
' |   locks; strict;
' |   comment @# @;
' |   expand  @b@;
' |
' |
' |   1.1
' |   date  2005.07.21.08.29.58;  author pamoire; state Exp;
' |   branches;
' |   next  ;
' |   deltatype text;
' |   permissions 666;
' |   commitid  c6c42df5d05234c;
' |   kopt  b;
' |   filename  Tracabilite_boucherie.pdf;

'====================================================================================
' Conposition d'une page HTML
'====================================================================================

Public Function MakePage(Racine As Variant, Optional UserName As String)
  
  Dim cfile As ClsFile
  Dim oDoc As New HTMLDocument
  Dim oTable As New HTMLTable
   
    oDoc.BodyAttrib(vbHTMLBodyBgColor) = "#ECE9D8" '"SILVER"
    oDoc.Head.Title = "CVS REPOSITORY"
    
    oDoc.BodyElement.Add oDoc.Normalize("{DIRECTORY} : " & GetTitre(Racine) & vbCrLf)
    oDoc.BodyElement.Add oDoc.Normalize(vbCrLf)
    
    oTable.Attrib(vbHTMLTableWidth) = "100%"
    oTable.Attrib(vbHTMLTableBorder) = "0"
  
    oTable.AddColumn , "5%", vbCenter, vbCenter
    oTable.AddColumn , "50%", vbCenter, vbLeftJustify
    oTable.AddColumn , "20%", vbCenter, vbCenter
    oTable.AddColumn , "5%", vbCenter, vbCenter
    oTable.AddColumn , "20%", vbCenter, vbCenter
    
    For Each cfile In GetFileOf(Racine, UserName)
      oTable.AddRow
      If cfile.Directory Then
        oTable.Text(1) = "<a href=""" & cfile.Link & """><img border=""0"" src=""" & cfile.GetIconFile() & """></a>"
        oTable.Text(2) = "<a href=""" & cfile.Link & """><font size=""3"">{" & cfile.Name & "}</font></a>"
      Else
        oTable.Text(1) = "<img border=""0"" src=""" & cfile.GetIconFile() & """>"
        If cfile.Icon = IconDeleted Then
          oTable.Text(2) = "<font size=""3""><strike><em>" & cfile.Name & "</em></strike></font>"
        Else
          oTable.Text(2) = "<font size=""3"">" & cfile.Name & "</font>"
        End If
      End If
      oTable.Text(3) = "<font size=""2"">" & cfile.DTMaj & "</font>"
      oTable.Text(4) = "<font size=""3"">" & cfile.Author & "</font>"
      oTable.Text(5) = "<font size=""3"">" & cfile.Version & "</font>"
    Next
    
    oDoc.BodyElement.Add oTable.HTML
    
    MakePage = oDoc.HTML
   Set oDoc = Nothing
  
End Function

'- - - - - - - - - - - - Recupération du titre

Private Function GetTitre(Racine As Variant) As String
  Dim Param As Variant
    Param = Split(Racine, "?")
    On Error Resume Next
    GetTitre = "{" & Trim(Param(1)) & "}"
    GetTitre = GetTitre & Param(2)
    On Error GoTo 0
End Function

'====================================================================================
' Lecture d'un répertoire (ou repository)
'====================================================================================

Private Function GetFileOf(Racine As Variant, Optional UserName As String) As Collection
  
  Dim CVSAttrib As New ClsCVSAttrib
  
  Dim cfile As ClsFile
  Dim Repository As ClsFile
  Dim PathFile As String
  Dim FileName As String
  Dim Param As Variant
  Dim getFile As Collection
  
    Racine = Replace(Racine, "%20", " ")
    Param = Split(Racine, "?")
    Set GetFileOf = getRepository()
    If Param(0) = "/CVS" Then
      
      On Error GoTo ErrRepository
        Set Repository = GetFileOf.Item(UCase(Param(1)))
      On Error Resume Next
        PathFile = Param(2)
      On Error GoTo 0
      
      Set getFile = New Collection
      
        Set cfile = New ClsFile
         cfile.Name = ""
         cfile.Icon = IconBack
         cfile.Path = PreviousDirectory(Replace(Repository.Path & PathFile, "/", "\"))
         If Len(cfile.Path) - Len(Repository.Path) >= 0 Then
           cfile.Link = "CVS?" & Repository.Name & "?" & Mid(cfile.Path, Len(Repository.Path) + 1)
         End If
         cfile.Directory = True
        getFile.Add cfile
        
        FileName = Dir(Replace(Repository.Path & PathFile, "/", "\") & "\*.*", vbDirectory + vbNormal)
        While FileName > ""
          If Left(FileName, 1) <> "." And FileName <> "CVSROOT" And FileName <> "CVS" Then
            If Not Locked(Repository.Name & PathFile & "/" & FileName, UserName) Then
              
              Set cfile = New ClsFile
               cfile.Name = FileName
               cfile.Path = Replace(Repository.Path & PathFile, "/", "\") & "\" & FileName
               cfile.Link = "CVS?" & Repository.Name & "?" & PathFile & "/" & FileName
               cfile.DTMaj = FileDateTime(cfile.Path)
               cfile.Directory = GetAttr(cfile.Path) And vbDirectory
               cfile.Icon = IIf(cfile.Directory, IconDirectory, IconDefault)
               
               If Right(FileName, 2) = ",v" Then
                 If CVSAttrib.GetAttib(cfile.Path) Then
                   cfile.Name = IIf(CVSAttrib.FileName = "", cfile.Name, CVSAttrib.FileName)
                   cfile.Version = CVSAttrib.Version
                   cfile.Author = CVSAttrib.Author
                   Select Case CVSAttrib.kopt
                     Case "b"
                       cfile.Icon = IconBinary
                     Case "kv"
                       cfile.Icon = IconText
                   End Select
                   If CVSAttrib.State = "dead" Then cfile.Icon = IconDeleted
                 End If
               End If
               
               getFile.Add cfile, UCase(cfile.Name)
              Set cfile = Nothing
              
            End If
          End If
          FileName = Dir
          DoEvents
        Wend
      Set GetFileOf = getFile
    End If
    
ErrRepository:
    On Error GoTo 0
    Triebulle GetFileOf
    
End Function

'- - - - - - - - - - - - Retourne le chemin du repertoire précédent

Private Function PreviousDirectory(Racine As String) As String
  Dim Pos As Long
  Dim Slach As Boolean
    Slach = (Right(Racine, 1) = "\")
    Pos = InStrRev(Racine, "\", IIf(Slach, 2, 1))
    PreviousDirectory = Left(Racine, Pos - IIf(Slach, 0, 1))
End Function

Private Function Locked(Racine As String, Optional UserName As String) As Boolean
  Dim LstUser As String
    LstUser = GetProfileString("Locked", Racine)
    If LstUser <> "" Then
      Locked = True
      If InStr(1, LstUser & ";", IIf(UserName > "", UserName, GetUser) & ";", vbTextCompare) > 0 Then
        Locked = False
      End If
    End If
End Function

'- - - - - - - - - - - - Trie Bulle

Private Sub Triebulle(liste As Collection)
 Dim I As Long
 Dim J As Long
 Dim cfile As New ClsFile
  For I = 1 To liste.Count - 1
    For J = I + 1 To liste.Count
      If liste(I).Trie > liste(J).Trie Then
         cfile.Serialize = liste(J).Serialize
         liste(J).Serialize = liste(I).Serialize
         liste(I).Serialize = cfile.Serialize
      End If
    Next
  Next
End Sub
  

'=======================================================================================
' Lecture Repository de NTCVS dans la base de registre
'=======================================================================================

Public Function getRepository() As Collection
 
 Dim hKey As Long
 Dim strBufa As String
 Dim lDataBufSize As Long
 Dim lValueType As Long
 
 Dim Index As Long
 Dim cfile As ClsFile
 Set getRepository = New Collection
   
    If RegOpenKey(HKEY_LOCAL_MACHINE, "SOFTWARE\Cvs\PServer", hKey) <> 0 Then
      Set cfile = New ClsFile
       cfile.Name = "(Aucun 'Repositpory' NT-CVS de disponible !)"
      getRepository.Add cfile
    Else
    
      Index = 0
      While RegQueryValueEx(hKey, "Repository" & Trim(Index), 0, lValueType, ByVal 0, lDataBufSize) = 0
        Set cfile = New ClsFile
         cfile.Name = RegQueryStringValue(hKey, "Repository" & Trim(Index) & "Name")
         cfile.Icon = IconDirectory
         cfile.Note = RegQueryStringValue(hKey, "Repository" & Trim(Index) & "Description")
         cfile.Path = RegQueryStringValue(hKey, "Repository" & Trim(Index))
         cfile.Link = "CVS?" & cfile.Name
         cfile.Directory = True
         getRepository.Add cfile, UCase(cfile.Name)
        Set cfile = Nothing
        Index = Index + 1
      Wend
   
    End If
    
End Function

'----------------------------------------------------------------------------------------

Function RegQueryStringValue(ByVal hKey As Long, ByVal strValueName As String) As String
  
  'KPD-Team 1998
  'URL: http://www.allapi.net/
  'E-Mail: KPDTeam@Allapi.net
  
   '- - - Working
    Dim strData As Integer
    Dim lValueType As Long
    Dim strBuf As String
    Dim lDataBufSize As Long
    
   '- - - retrieve nformation about the key
    If RegQueryValueEx(hKey, strValueName, 0, lValueType, ByVal 0, lDataBufSize) = 0 Then
      
     '- - String Value
      If lValueType = REG_SZ Then
        strBuf = String(lDataBufSize, Chr$(0))
        If RegQueryValueEx(hKey, strValueName, 0, 0, ByVal strBuf, lDataBufSize) = 0 Then
          RegQueryStringValue = Left$(strBuf, InStr(1, strBuf, Chr$(0)) - 1)
        End If
        
     '- - Binaty Value
      ElseIf lValueType = REG_BINARY Then
        If RegQueryValueEx(hKey, strValueName, 0, 0, strData, lDataBufSize) = 0 Then
          RegQueryStringValue = strData
        End If
      
      End If
    End If
End Function

Conclusion :


Avis aux amateurs qui voudrait améliorer ce code !!!

Codes Sources

A voir également

Ajouter un commentaire

Commentaires

Messages postés
32
Date d'inscription
vendredi 19 mai 2000
Statut
Membre
Dernière intervention
21 juillet 2015

la... ca dépasse mes compétences !
Messages postés
4936
Date d'inscription
lundi 17 février 2003
Statut
Modérateur
Dernière intervention
14 février 2014
32
en vb... tu peux faire des DLL COM qui peuvent être appelées depuis une page asp
Messages postés
32
Date d'inscription
vendredi 19 mai 2000
Statut
Membre
Dernière intervention
21 juillet 2015

A ma connaissance, les extentions CGI pour IIS ne peuvent pas être écrite en VB ! (les informations passent par le flux "standard" STDIN ou STDOUT. Bien qu'il soit possible de créer une console en VB, il n'est pas possible de récupéré "la console" qui à lancer l'application VB...)

Cela explique pourquoi de tels "extentions" doivent être ecrites en C++, Python ou Perl.

PS: Ammélioration en cours :
- Serveur HTTP intégrer (traitement des images)
- Afficahge des versions & commentaires des fichiers.
Messages postés
4936
Date d'inscription
lundi 17 février 2003
Statut
Modérateur
Dernière intervention
14 février 2014
32
beau travail... mais pourquoi recréer un serveur web ?
pourquoi ne pas se baser sur IIS et fournir des extensions ?

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.