FAQ Visual Basic Consultez toutes les FAQ

Nombre d'auteurs : 50, nombre de questions : 300, dernière mise à jour : 9 février 2020 

 
OuvrirSommaireDivers bisRoutines

Ajoutez cette déclaration au début de votre module :

vb
Sélectionnez
Private Declare Function GetTickCount Lib "kernel32" () As Long

GetTickCount renvoie le nombre de millisecondes qui s'est écoulé depuis le démarrage du système. Appelez-la au début de votre code, puis à la fin, et la différence entre les deux résultats vous donnera le nombre de millisecondes qui s'est écoulé entre les deux appels.

vb
Sélectionnez
Dim Debut As Long, Fin As Long
Debut = GetTickCount()
 
'ici le code à chronométrer
 
Fin = GetTickCount()
MsgBox "Temps mis en millisecondes : " & Fin - Debut
Créé le 29 juillet 2002  par Romain Puyfoulhoux

Il y a plusieurs méthodes pour faire cela. Habituellement on utilise un emplacement particulier du registre situé sous cette clé :
HKEY_CURRENT_USER\Software\VB and VBA Program Settings\appname\section\key

Cette partie du registre est directement manipulable avec les quatre fonctions suivantes :

  • SaveSetting appname, section, key, value : permet de créer ou de modifier une clé du registre.
  • GetSetting(appname, section, key [, default]) ou GetAllSettings((appname, section) : permet de récupérer une ou des clés
  • DeleteSetting appname, section, key : supprime une clé.

Bien sûr, ces fonctions ne permettent pas une gestion complète du registre mais elles vous permettent de stocker quelques valeurs très simplement. C'est ce que nous allons faire avec le code suivant.

vb
Sélectionnez
Private Sub Form_Load() 
 
'vérifie l'existence de la clé
If Len(GetSetting("MonAppli", "Demar", "DejaEx")) = 0 Then 
    'si elle n'existe pas création de celle-ci
    SaveSetting "MonAppli", "Demar", "DejaEx", "Vrai"
    'Le code placé ici ne s'exécutera qu'une fois
    MsgBox "Je n'apparaîtrais plus", vbInformation + vbOKOnly 
End If 
 
End Sub
Créé le 4 septembre 2003  par Jean-Marc Rabilloud

Voici une méthode utilisant les signets. Dans Microsoft Word, un signet est un emplacement nommé que l'on utilise comme référence. Il est ajouté via la commande Signets qui est dans le menu Insertion. Ici les signets vous serviront de conteneurs pour les informations envoyées par votre programme. Vous devez leur octroyer un nom afin de pouvoir les identifier depuis Visual Basic. Attention, vous ne pouvez pas ajouter plusieurs fois un signet du même nom.

Voici un exemple d'envoi de données. Dans votre projet, n'oubliez pas de cocher la référence Micorosft Word x.0 Object Library.

vb
Sélectionnez
Dim MyWord As Word.Application, doc As Word.Document
Dim signet As String, i As Long
 
Set MyWord = New Word.Application
 
With MyWord
 
    Set doc = .Documents.Open("c:\modele.doc")
    'Rs est un recordset Adodb, NomPers et PrenomPers sont des signets
    doc.Bookmarks("NomPers").Range.Text = Rs.Fields("nom").Value
    doc.Bookmarks("PrenomPers").Range.Text = Rs.Fields("prenom").Value
 
    ' exemple de signets allant de Mat1 à Mat11 remplis par les valeurs d'une table TbMat
    For i = 0 To 10
        signet = "Mat" & Trim(Str(i + 1))
        doc.Bookmarks(signet).Range.Text = TbMat(i)
    Next i
    doc.SaveAs "c:\etat.doc" 'enregistre sous un autre nom
    .Visible = True 'rend l'application visible
    Set doc = Nothing
End With
 
DoEvents
Set MyWord = Nothing

Dans cet exemple le modèle est enregistré sous un autre nom puis le document est rendu visible. Vous pouvez au contraire imprimer le document sans que l'utilisateur sache que Word est utilisé et sans que les modifications soient sauvegardées :

vb
Sélectionnez
doc.PrintOut
doc.Close wdDoNotSaveChanges
Créé le 28 juin 2004  par Khany, Romain Puyfoulhoux

On utilise la fonction ci-dessous qui attend en paramètres la chaine, la position de l'élément à extraire et le délimiteur. Cette fonction renvoie une chaine vide lorsqu'elle ne peut pas procéder à l'extraction.
Dans le cas d'une extraction partielle, cette fonction est beaucoup plus rapide qu'un Split.

vb
Sélectionnez
Function ExtraitElement(ChaineRecherche As String, Position As Long, Delim As String) As String
 
'Renvoie une chaine vide si l'extraction n'est pas possible
On Error GoTo Err_Function
 
Dim compteur As Long, LastPos As Long, CurPos As Long
 
If InStr(ChaineRecherche, Delim) = 0 Or Len(ChaineRecherche) = 0 Then Exit Function
LastPos = 1
Do
    CurPos = InStr(LastPos, ChaineRecherche, Delim)
    If CurPos = 0 Then
        If compteur = Position - 1 Then ExtraitElement = Mid(ChaineRecherche, LastPos)
        Exit Do
    Else
        compteur = compteur + 1
        If compteur = Position Then
            ExtraitElement = Mid(ChaineRecherche, LastPos, CurPos - LastPos)
            Exit Do
        End If
    End If
    LastPos = CurPos + 1
Loop While CurPos > 0
Exit Function
 
Err_Function:
    MsgBox "Error " & Err.Number & ": " & Err.Description
    Resume Next
 
End Function
Créé le 4 septembre 2003  par Jean-Marc Rabilloud

Certaines applications n'acceptent d'être ouverte qu'une seule fois. Si l'on essaie de l'ouvrir une deuxième fois, la fenêtre de la première instance repasse en premier plan et est restaurée si nécessaire.

Pour tester le code ci-dessous, créez un projet et ajoutez une form. Son nom est Form1 par défaut. Ajoutez ensuite le code ci-dessous dans un module standard. Enfin, sélectionnez "Sub Main" comme objet de démarrage dans les propriétés du projet.

vb
Sélectionnez
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
                                                                   (ByVal lpClassName As String, _
                                                                    ByVal lpWindowName As String) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
 
Private Const SW_RESTORE = 9
Private Const GW_HWNDPREV = 3
 
Private Sub Main()
 
Dim lngHandle As Long
 
'Cherche une fenêtre qui serait déjà ouverte
lngHandle = GetPreviousWindow
If lngHandle > 0 Then
    'fenêtre trouvée, on l'affiche
    DisplayWindow lngHandle
Else
    Form1.Show
End If
 
End Sub
 
Private Function GetPreviousWindow() As Long
 
Dim strTitre As String
Dim lngHwnd As Long
 
'Sauvegarde le titre de l'application et le modifie
'sinon on trouverait toujours une instance de l'application : celle qui vient d'être lancée
strTitre = App.Title
App.Title = "---" & App.Title
'Récupère le handle de la fenêtre principale (invisible)
lngHwnd = FindWindow("ThunderRT6Main", strTitre)
'Obtient le handle de la fenêtre visible
If lngHwnd > 0 Then GetPreviousWindow = GetWindow(lngHwnd, GW_HWNDPREV)
'Restaure le titre original
App.Title = strTitre
 
End Function
 
Private Sub DisplayWindow(ByVal lngHandle As Long)
 
ShowWindow lngHandle, SW_RESTORE
SetForegroundWindow lngHandle
 
End Sub

La Fonction GetPreviousWindow() renvoie le handle de la fenêtre de l'application si celle-ci a déjà été ouverte. La fonction DisplayWindow() restaure et met au premier plan la fenêtre dont le handle est passé en paramètre. Dans la procédure Main, nous recherchons une instance existante. Si nous en avons trouvé une, nous l'activons, sinon nous affichons Form1.

Il existe aussi un autre moyen :

vb
Sélectionnez
Private Sub Form_Load() 
    If App.PrevInstance Then 
        MsgBox "Désolé, une instance est déjà active" & vbCrLf & "Le programme va s'arréter" 
        End 
    End If 
End Sub
Créé le 17 février 2004  par Romain Puyfoulhoux

La lecture d'un fichier XML se fait à l'aide d'un parseur. Dans les références du projet, ajoutez Microsoft XML.

Voici un exemple qui affiche dans la fenêtre de débogage la liste des balises contenues dans un document xml.

vb
Sélectionnez
Private Sub BrowseChildNodes(root_node As IXMLDOMNode)
 
    Dim i As Long
 
    For i = 0 To root_node.childNodes.length - 1
        If root_node.childNodes.Item(i).nodeType <> 3 Then Debug.Print root_node.childNodes.Item(i).baseName
        BrowseChildNodes root_node.childNodes(i)
    Next
 
End Sub
 
Private Sub BrowseXMLDocument(ByVal filename As String)
 
    Dim xmlDoc As DOMDocument, root As IXMLDOMElement
 
    Set xmlDoc = New DOMDocument
    xmlDoc.async = False
    xmlDoc.Load filename
    Set root = xmlDoc.documentElement
    If Not root Is Nothing Then
        Debug.Print root.baseName
        BrowseChildNodes root
    End If
 
End Sub

Appelez simplement la procédure BrowseXMLDocument en passant en paramètre le chemin du fichier. Cette procédure ouvre le fichier puis appelle la procédure BrowseChildNodes qui parcoure l'ensemble des balises de façon récursive.

Créé le 6 septembre 2004  par Romain Puyfoulhoux

Lien : Home page de MSXML

Génération de 10 mots de passe de 8 caractères.

vb
Sélectionnez
Private Const CaracteresAutorises As String = "0123456789abcdefghijklmnopqrstuvwxyz" 
 
Public Sub main() 
    Dim Index As Integer 
 
    For Index = 1 To 10 
        Debug.Print Generer(8) 
    Next Index 
End Sub 
 
Public Function Generer(Longueur As Integer) As String 
    Dim Index As Integer 
 
    Randomize 
    For Index = 1 To Longueur 
        Generer = Generer & Mid(CaracteresAutorises, Int(Len(CaracteresAutorises) * Rnd()) + 1, 1) 
    Next Index 
End Function
Créé le 13 juin 2005  par Catbull

Dans une Form ajouter un contrôle PictureBox. Ajouter ces déclarations dans un module :

vb
Sélectionnez
Private Declare Function BitBlt Lib "gdi32.dll" ( _ 
     ByVal hDestDC As Long, _ 
     ByVal x As Long, _ 
     ByVal y As Long, _ 
     ByVal nWidth As Long, _ 
     ByVal nHeight As Long, _ 
     ByVal hSrcDC As Long, _ 
     ByVal xSrc As Long, _ 
     ByVal ySrc As Long, _ 
     ByVal dwRop As Long) As Long 
 
Private Declare Function GetDesktopWindow Lib "user32.dll" () As Long 
 
Private Declare Function GetDC Lib "user32.dll" ( _ 
     ByVal hwnd As Long) As Long 
 
Private Const SRCCOPY As Long = &HCC0020 
 
Public Sub ScreenShot(Pic As PictureBox) 
    Pic.AutoRedraw = True 
    Pic.Width = Screen.Width 
    Pic.Height = Screen.Height 
    Pic.Visible = False 
    BitBlt Pic.hDC, 0&, 0&, Screen.Width, Screen.Height, GetDC(GetDesktopWindow()), 0&, 0&, SRCCOPY 
    SavePicture Pic.Image, "C:\ScreenShot.bmp" 
End Sub

Appel de la procédure :

vb
Sélectionnez
ScreenShot Picture1
Créé le 13 juin 2005  par ridan

Lien : Page sources : capture d'écran
Lien : Page sources : capture d'écran via API
Lien : Page sources : capture d'écran via PrintScreen

Fonctionne sous Win 2000 et supérieur.

vb
Sélectionnez
Dim MyStr As String 
i = 1 
Do 
    If Environ(i) = "" Then 
        Exit Do 
    Else 
        MyStr = MyStr & Environ(i) & vbCrLf 
        i = i + 1 
    End If 
Loop
Créé le 13 juin 2005  par ridan
vb
Sélectionnez
Dim D as Double 
 
If isNumeric(Text1.Text) Then 
    D=CDbl(Text1.Text) 
 
    If D-Int(D) = 0 Then 
        'Le nombre est entier 
    Else 
        'Le nombre est décimal 
    End if 
Else 
    'Ce n'est pas un nombre 
End if
Créé le 13 juin 2005  par Catbull
vb
Sélectionnez
Private Function isInteger(Expression As Variant) As Boolean 
    Dim D As Double 
 
    If IsNumeric(Text1.Text) Then 
        D = CDbl(Text1.Text) 
        If D = Int(D) Then isInteger = True 
    End If 
End Function
Créé le 13 juin 2005  par Catbull
vb
Sélectionnez
Function Dec2Hex(dec As Long) As String 
    Dec2Hex = hex(dec) 
End Function 
 
Function Hex2Dec(hex As String) As Long 
    Hex2Dec = Val("&h" & hex) 
End Function 
 
Function Hex2Bin(hex As String) As String 
 
    Dim i As Byte 
    Dim resultat As String 
 
    For i = 1 To Len(hex) 
        Select Case Mid(hex, i, 1) 
            Case "0": resultat = resultat & "0000" 
            Case "1": resultat = resultat & "0001" 
            Case "2": resultat = resultat & "0010" 
            Case "3": resultat = resultat & "0011" 
            Case "4": resultat = resultat & "0100" 
            Case "5": resultat = resultat & "0101" 
            Case "6": resultat = resultat & "0110" 
            Case "7": resultat = resultat & "0111" 
            Case "8": resultat = resultat & "1000" 
            Case "9": resultat = resultat & "1001" 
            Case "A": resultat = resultat & "1010" 
            Case "B": resultat = resultat & "1011" 
            Case "C": resultat = resultat & "1100" 
            Case "D": resultat = resultat & "1101" 
            Case "E": resultat = resultat & "1110" 
            Case "F": resultat = resultat & "1111" 
        End Select 
    Next i 
 
    Hex2Bin = resultat 
 
End Function 
 
Function Bin2Dec(bin As String) As String 
 
    Dim i As Byte 
    Dim resultat As Long 
 
    resultat = 0 
 
    For i = 1 To Len(bin) 
        If Mid(bin, Len(bin) - i + 1, 1) = 1 Then 
            resultat = resultat + 2 ^ (i - 1) 
        End If 
    Next i 
 
    Bin2Dec = resultat 
 
End Function

Pour les autres conversions il suffit de combiner les fonctions...

Créé le 13 juin 2005  par hpj
 
Sélectionnez
Public Function DecimalToBinaire(DecVal As Double) As String
'Variable temporaire qui sert lors du traitement du nombre à convertir
Dim NbTmp As Double 
'Variable/Indice de boucle
Dim IndiceP as Integer 
NbTmp = DecVal
    For IndiceP = 1 To Int(Log(DecVal) / Log(2)) + 1
        DecimalToBinaire = CDbl(NbTmp Mod 2) & DecimalToBinaire
        NbTmp = CDbl(Int(NbTmp / 2))
    Next IndiceP
End Function

Il vous suffit ensuite de l'appeler ainsi pour convertir par exemple 1324 en binaire :

 
Sélectionnez
DecimalToBinaire(1324)
Mis à jour le 22 décembre 2008  par fdraven

Lien : Comment effectuer des conversions vers le Décimal, l'Hexadécimal ou le Binaire ?


Contrairement à la fonction Round qui arrondi un nombre à sa valeur la plus proche en fonction des décimales choisies,
cette fonction propose la fonction myRound qui arrondi un nombre à sa valeur supérieure et inférieur en fonction des décimales choisies.

 
Sélectionnez
Enum myRoundEnum
    myRoundup = -1
    myRoundDown = 1
End Enum
 
Public Function myRound(vValeur As Variant, Optional byNbDec As Byte, Optional eSens As myRoundEnum = myRoundup) As Variant
   myRound = eSens * Int(eSens * vValeur * 10 ^ byNbDec) / 10 ^ byNbDec
End Function


L'appel de cette Fonction :

 
Sélectionnez
Sub test()
MsgBox myRound(4.333, 1, myRoundup)
MsgBox myRound(4.333, 1, myRoundDown)
End Sub
Mis à jour le 22 décembre 2008  par Tofalu
 
Sélectionnez
Voici par exemple une fonction pour calculer un écart type sur les valeurs contenues dans un tableau :
 
Sélectionnez
Public Function EcartTypeP(tbl As Variant) As Double
    Dim Var1, Var2
    For i = 1 To UBound(tbl)
        Var1 = Var1 + (tbl(i) * tbl(i))    ' somme des carrés
        Var2 = Var2 + tbl(i)    'somme des valeurs
    Next
    EcartTypeP = Sqr(((UBound(tbl) * Var1) - (Var2 * Var2)) / (UBound(tbl) * UBound(tbl)))
End Function



Voici le code à mettre afin de tester cette fonction. Nous remplissons tout d'abord un tableau pour ensuite en calculer l'écart type dont le résultat s'affichera dans la fenêtre d'exécution.

 
Sélectionnez
Private Sub Bouton1_Click()
    Dim table(10)
    'remplir le tableau
For i = 1 To 10
        table(i) = i
    Next
    'dans un module faites ctrl+g pour afficher la fenêtre d'exécution
    Debug.Print EcartTypeP(table)
End Sub
Mis à jour le 22 décembre 2008  par ThierryAIM
vb
Sélectionnez
Function ispair(mavar As Long) As Boolean 
ispair = Not mavar And 1 
End Function

Exemples : ispair(2) retourne true ispair(1) retoune false

Créé le 13 juin 2005  par spacefrog

En parlant d'image plein écran, on peut penser à des situations différentes. Soit une image qui doit rester proportionnelle afin de ne pas être déformée, soit un fond de feuille uni qui peut être étiré sans perdre de qualité.

Le premier exemple s'attache à l'image proportionnelle :

Dans l'événement Click de l'image, placez le code suivant :

vb
Sélectionnez
Private Sub Picture1_Click() 
Form2.Image1.Picture = Picture1.Picture 
'intégration de l'image dans image1 de form2 
Form2.Show 'afficher form2 
Form2.Tag = Picture1.Height / Picture1.Width 
'calcul du rapport hauteur sur largeur de l'image à copier et envoi dans le tag de la form2 
End Sub

Dans le code de la form2, qui doit comporter un image et un timer, entrez ceci :

vb
Sélectionnez
Private Sub Form_Click() 
Unload Me 'décharger form2 
End Sub 
 
Private Sub Form_Load() 
Image1.Visible = False 
Timer1.Interval = 1 
Timer1.Enabled = True 
'ces comandes ne sont pas nécessaires mais elles permettent de ne pas avoir à entrer les caractéritiques des objets ci-dessus 
End Sub 
 
Private Sub Timer1_Timer() 
'le timer est utilisé car il faut un délai minimal avant que l'image se retrouve dans image1 
If Me.Tag > (Screen.Height / Screen.Width) Then 
    Timer1.Tag = 1 
Else
    Timer1.Tag = 0 
End If
'détermine si l'image est plus haute que large 
If Timer1.Tag = 1 Then 
    Me.PaintPicture Image1.Picture, (Screen.Width - (Screen.Width * (Screen.Height / Screen.Width) / _
        Me.Tag)) / 2, 0, Screen.Width * (Screen.Height / Screen.Width) / Me.Tag, Screen.Height
Else
Me.PaintPicture Image1.Picture, 0, (Screen.Height - (Screen.Height * (Screen.Width / Screen.Height) * _
       Me.Tag)) / 2, Screen.Width, Screen.Height * (Screen.Width / Screen.Height) * Me.Tag 
End If
'prendre image sur image1 
'si image moins large que l'écran par rapport à sa hauteur, centrer paintpicture 
'selon l'axe horisontal hauteur de l'image = hauteur de l'écran et largeur de l'image proportionelle 
'sinon centre l'image selon l'axe vertical,
'largeur de l'image = largeur de l'écran et hauteur de l'image proportionnelle 
Timer1.Enabled = False 
End Sub

Par contre, pour afficher un fond de feuille qui peut être un fond "plein écran", il suffit de définir les propriétés de la feuille de fond comme suit :

  • BorderStyle = 0 - None
  • WindowState = 2 - Maximized

Dans la feuille dite "de fond", placez un contrôle Image1 renommé ImgFond et le code suivant :

vb
Sélectionnez
Private Sub Form_Load()
    ImgFond.Picture = LoadPicture(PathGraphiques & "fdbleu.jpg")
End Sub
 
Private Sub Form_Resize()
    ImageFond Me
End Sub

Ensuite, dans un module BAS, placez la routine de redimensionnement :

vb
Sélectionnez
Public Sub ImageFond(Feuille As Form)
    Feuille.ImgFond.Move 0, 0, Feuille.ScaleWidth, Feuille.ScaleHeight
End Sub

Le contrôle image ne doit pas spécialement être étendu à toute la feuille, il faut juste spécifier sa propriété Stretch à True.

Créé le 13 juin 2005  par méphistopheles, Khany

Une astuce parmi d'autres consiste à utiliser la fonction de l'API Windows GetModuleFileName dans un module ou une form de votre application.

Déclarations :

vb
Sélectionnez
Private Declare Function GetModuleFileName Lib "kernel32" Alias "GetModuleFileNameA" _
(ByVal hModule As Long, ByVal lpFileName As String, ByVal nSize As Long) As Long

GetModuleFileName : cette fonction de l'API Windows retourne ByRef le chemin complet et le nom du fichier exécutable qui contient le module dans lequel cette fonction est appelée.
- renvoie {VB6 install path}\vb6.exe, si le programme est exécuté depuis l'environnement de développement de VB6 (l'IDE).
- renvoie {chemin du projet}\NomProjet.exe, dans le cas contraire.

La fonction ci-dessous retourne :
- Vrai si le programme tourne depuis l'IDE de Visual Basic
- Faux si le programme tourne depuis l'exécutable

(Nécessite la fonction ExtractFileName)

vb
Sélectionnez
Public Function IsRunningIDE() As Boolean
    On Error Resume Next
    Dim sBuffer As String
    Dim Ret As Integer
 
    sBuffer = String$(255, Chr$(0))
    Ret = GetModuleFileName(0, sBuffer, Len(sBuffer))
    If Ret > 0 Then
        sBuffer = Mid(sBuffer, 1, Ret)
        IsRunningIDE = Lcase(ExtractFileName(sBuffer) = "vb6.exe")
    End If
End Function
 
Private Sub Form_Load()
MsgBox IsRunningIDE
End Sub

NOTA : remplacez "vb6.exe" par votre version de Visual Basic, si vous utilisez une version antérieure

Créé le 2 mai 2006  par ThierryAIM

La fonction split, n'existe pas en vb5 mais on peu créer sa propre fonction :

 
Sélectionnez
Public Function Split(ByVal MyString As String, Optional ByVal Separator As String = " ") As Variant
  Dim iPosit As Long
  Dim Table() As String
  ReDim Table(0)
  iPosit = InStr(MyString, Separator)
  If iPosit = 1 Then
    MyString = Mid$(MyString, Len(Separator) + 1)
    iPosit = InStr(MyString, Separator)
  End If
  While iPosit > 0
    Table(UBound(Table)) = Left(MyString, iPosit - 1)
    MyString = Mid$(MyString, iPosit + Len(Separator))
    ReDim Preserve Table(UBound(Table) + 1)
    iPosit = InStr(MyString, Separator)
  Wend
  Table(UBound(Table)) = MyString
  Split = Table
End Function

Cette fonction s'utilise comme la fonction split standard de VB6, vous trouverez plusieurs exemples dans cette faq.

Créé le 22 décembre 2008  par Delbeke

Lien : Une autre façon d'écrire la fonction voir FAQ Access 97

En utilisant la fonction JavaScrip, Escape :
cochez la référence à Microsoft Script Control

 
Sélectionnez
Dim strBase As String, strEncode As String, SC As New ScriptControl
    strBase = "Ceci est une chaîne encodée"
    SC.Language = "JavaScript"
    strEncode = SC.Eval("escape(" + Chr(34) + strBase + Chr(34) + ")")

L'inverse est aussi possible par l'utilisation de unescape

 
Sélectionnez
SC.Eval("unescape(" + Chr(34) + strEncode + Chr(34) + ")")
Créé le 2008-15-22  par DarkVader

Pour obtenir les propriétés d'un PDF (nom, titre, etc.), il faut lire le fichier en mode binary. L'utilisation des RegExp permettra d'accéder aux informations recherchées. C'est ce que fait la fonction suivante :

 
Sélectionnez
Function GetPDFTitle(ByVal strFic As String, strObj As String) As String
 
Dim fic As Integer
Dim strExp As String
Dim strBuff As String * 1024
Dim i As Integer
 
Dim reg As VBScript_RegExp_55.RegExp
Dim Match As VBScript_RegExp_55.Match
Dim Matches As VBScript_RegExp_55.MatchCollection
 
Set reg = New VBScript_RegExp_55.RegExp
 
reg.Global = True
reg.MultiLine = False
reg.IgnoreCase = True
reg.Pattern = "/" & strObj & " \((.*)\)"
 
Reset
 
fic = FreeFile
 
Open strFic For Binary Access Read As #fic
 
Do While Not EOF(fic)
    Get #fic, , strBuff
    strExp = strExp & strBuff
 
    If reg.Test(strExp) = True Then
        Set Matches = reg.Execute(strExp)
        For Each Match In Matches
            GetPDFTitle = Match.SubMatches(0)
        Next Match
        Exit Function
    Else
        strExp = right(strExp, 1024)
    End If
Loop
Reset
 
Set Match = Nothing
Set Matches = Nothing
Set reg = Nothing
 
End Function

Exemple d'utilisation :

 
Sélectionnez
getpdftitle( "d:\temp\20060331164202.pdf", "Title")

Il est possible de remplacer title par un des champs suivants :

  • CreationDate
  • ModDate
  • Title
  • Creator
  • Author
Mis à jour le 22 décembre 2008  par Cafeine

Lien : Tutoriel : Le PDF gratuit pour Access
Lien : Les expressions rationnelles / régulières dans Access par la pratique
Lien : Comment utiliser les expression régulières en VB6

Ceci est plus une astuce qu'un vrai code
On utilise une référence As Microsoft XML,version 2.0 , qui en sous produit, fait le codage/decodage du base 64
fonction d'encodage :

 
Sélectionnez
Public Function Encode_Base64(Text As String) As String
 
  Dim Xml As New MSXML.DOMDocument
  Dim Conv As MSXML.IXMLDOMElement
  Dim Arr() As Byte
  If Text = "" Then
    Encode_Base64 = ""
    Exit Function
  End If
  Arr = StrConv(Text, vbFromUnicode)
  Set Conv = Xml.createElement("Base64")
  Conv.dataType = "bin.base64"
  Conv.nodeTypedValue = Arr
  Encode_Base64 = Conv.Text
End Function



fonction décode :

 
Sélectionnez
Public Function Decode_Base64(Text As String) As String
  Dim Xml As New MSXML.DOMDocument
  Dim Conv As MSXML.IXMLDOMElement
  If Text = "" Then
    Decode_Base64 = ""
    Exit Function
  End If
  Set Conv = Xml.createElement("Base64")
  Conv.dataType = "bin.base64"
  Conv.Text = Text
  Decode_Base64 = StrConv(Conv.nodeTypedValue, vbUnicode)
End Function

Vous pouvez utiliser une version plus récente de "Microsoft XML", dans ce cas modifiez les déclarations de variables en remplaçant MSXML... par MSXML2...

Créé le 22 décembre 2008  par Delbeke

Le codage Quote-Printable est un codage ou toutes les lettres non comprises dans l'intervalle [33-60] [62-126] sont remplacés par =XX , ou XX est le code ascii du caractère.
Le tout est découpé en ligne de 76 caractères maximum.
fonction d'encodage :

 
Sélectionnez
Public Function EncodeQuotedPrintable(Text As String) As String
  Dim lPntIn As Long        'compteur caractères dans Text
  Dim lPntOut As Long       'position insertion dans buffer
  Dim lLenLign As Long      'Longeur ligne en cours
  Dim Buffer As String      'buffer reception du codage
  Dim Char As String        'le caratére en cours d'analyse
  Dim AsciiCode As Integer  'son code asccii
  If Text = "" Then
    EncodeQuotedPrintable = ""
    Exit Function
  End If
  Buffer = String(Len(Text) * 3, 0) ' au max, 3 caractères en sortie pour chaque caractère en entrée
  lPntOut = 1
  lLenLign = 1
  For lPntIn = 1 To Len(Text)
    Char = Mid(Text, lPntIn, 1)
    AsciiCode = Asc(Char)
    Select Case AsciiCode
    Case 33 To 60, 62 To 126
      'caractère litéral
      'tous ces caractères peuvent être acceptés tels quels
      Mid(Buffer, lPntOut, 1) = Char
      lPntOut = lPntOut + 1
      lLenLign = lLenLign + 1
    Case 9, 32
      '----------------------------------------
      'version abandonnée
      'Mid(Buffer, lPntOut, 1) = Char
      'lPntOut = lPntOut + 1
      'lLenLign = lLenLign + 1
      '----------------------------------------
      'le caractère blanc et le caractère tab sont censés être acceptés sans codage
      'mais pas s'ils terminent une ligne ! auquel cas il doivent être codés.
      'Comme ce n'est pas simple à coder, je les code tous
      Mid(Buffer, lPntOut, 3) = "=" & Right("00" & Hex(AsciiCode), 2)
      lPntOut = lPntOut + 3
      lLenLign = lLenLign + 3
    Case Else
      'on code tous les autres caractères
      Mid(Buffer, lPntOut, 3) = "=" & Right("00" & Hex(AsciiCode), 2)
      lPntOut = lPntOut + 3
      lLenLign = lLenLign + 3
    End Select
    If lLenLign > 72 Then
      'si on arrive en bout de ligne (qui ne doit pas passer 76 caractères)
      'on insére une continuation de ligne ( =CRLF )
      Mid(Buffer, lPntOut, 3) = "=" & vbCrLf
      lPntOut = lPntOut + 3
      lLenLign = 1
    End If
  Next
  EncodeQuotedPrintable = Left(Buffer, lPntOut - 1)
  'si on termine par "= & vbcrlf , on le retire
  If Right(EncodeQuotedPrintable, 3) = "=" & vbCrLf Then
    EncodeQuotedPrintable = Left(EncodeQuotedPrintable, Len(EncodeQuotedPrintable) - 3)
  End If
End Function



fonction décode :

 
Sélectionnez
Public Function DecodeQuotedPrintable(Text As String) As String
  Dim lPntIn As Long      'compteur caractères dans Text
  Dim lPntOut As Long     'position insertion dans buffer
  Dim Buffer As String    'buffer reception du dé-codage
  Dim Char As String      'le caratére en cours d'analyse
  Dim AsciiCode As String 'son code asccii en hexadécimal
  If Text = "" Then
    DecodeQuotedPrintable = ""
    Exit Function
  End If
  Buffer = String(Len(Text), 0)  ' au max, 1 caractère en sortie pour chaque caractère en entrée
  lPntOut = 1
 
  For lPntIn = 1 To Len(Text)
    Char = Mid(Text, lPntIn, 1)
    Select Case Char
    Case "="
      AsciiCode = Mid(Text, lPntIn + 1, 2)
      If AsciiCode = vbCrLf Then
        'caractère continuation de ligne
        lPntIn = lPntIn + 2
      Else
        'caractère codé
        Mid(Buffer, lPntOut, 1) = Chr(Val("&H" & AsciiCode))
        lPntOut = lPntOut + 1
        lPntIn = lPntIn + 2
      End If
    Case Else
      'caractère litéral
      Mid(Buffer, lPntOut, 1) = Char
      lPntOut = lPntOut + 1
    End Select
  Next
  DecodeQuotedPrintable = Left(Buffer, lPntOut - 1)
End Function

Vous pouvez utiliser une version plus récente de "Microsoft XML", dans ce cas modifiez les déclarations de variables en remplaçant MSXML... par MSXML2...

Créé le 22 décembre 2008  par Delbeke

Une adaptation du QuickSort des sources algo de développez : page sources algo

 
Sélectionnez
Public Function QUICKSORT(ByRef Tableau() As Integer, Optional ByVal Debut As Integer = -1, _
Optional ByVal Fin As Integer = -1)
'attention, ne pas avoir un tableau avec des indices négatifs.
If Debut = -1 Then Debut = LBound(Tableau, 1)
If Fin = -1 Then Fin = UBound(Tableau, 1)
 
Dim Pivot As Integer
Dim Gauche As Integer
Dim Droite As Integer
Dim temp As Integer
Pivot = Debut
Gauche = Debut
Droite = Fin
Do
If Tableau(Gauche) >= Tableau(Droite) Then
    temp = Tableau(Gauche)
    Tableau(Gauche) = Tableau(Droite)
    Tableau(Droite) = temp
    Pivot = Gauche + Droite - Pivot
End If
If Pivot = Gauche Then
    Droite = Droite - 1
Else
    Gauche = Gauche + 1
End If
DoEvents
Loop Until Gauche = Droite
  If Debut < Gauche - 1 Then QUICKSORT Tableau, Debut, Gauche - 1
  If Fin > Droite + 1 Then QUICKSORT Tableau, Droite + 1, Fin
End Function
Créé le 22 décembre 2008  par méphistopheles


Voici une solution en utilisant les API.


Coller ce code dans un nouveau module :

 
Sélectionnez
Private Declare Function FoldString Lib "kernel32.dll" Alias _
        "FoldStringA" (ByVal dwMapFlags As Long, ByVal lpSrcStr As Long, _
        ByVal cchSrc As Long, ByVal lpDestStr As Long, ByVal cchdest As Long) As Long
 
Function OteAccents(ByVal str As String) As String
 
    Dim i As Integer
    OteAccents = Space(Len(str))
 
    For i = 0 To (Len(str) - 1) * 2 Step 2
        FoldString &H40, StrPtr(str) + i, 1, StrPtr(OteAccents) + i, 1
    Next i
 
End Function
Mis à jour le 22 décembre 2008  par Cafeine
  

Les sources présentées sur cette page sont libres de droits et vous pouvez les utiliser à votre convenance. Par contre, la page de présentation constitue une œuvre intellectuelle protégée par les droits d'auteur. Copyright © 2013 Developpez Developpez LLC. Tous droits réservés Developpez LLC. Aucune reproduction, même partielle, ne peut être faite de ce site ni de l'ensemble de son contenu : textes, documents et images sans l'autorisation expresse de Developpez LLC. Sinon vous encourez selon la loi jusqu'à trois ans de prison et jusqu'à 300 000 € de dommages et intérêts.