Webntcvs : consultation d'un référenciel nt-cvs depuis un navigateur web
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.
Avis aux amateurs qui voudrait améliorer ce code !!!
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 !!!
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.