Private Declare Function GetTickCount Lib "kernel32" () As Long

Dim Debut As Long, Fin As Long
Debut = GetTickCount()
 
'ici le code à chronométrer
 
Fin = GetTickCount()
MsgBox "Temps mis en millisecondes : " & Fin - Debut

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

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

doc.PrintOut
doc.Close wdDoNotSaveChanges

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

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

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

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

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

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

ScreenShot Picture1

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

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

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

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

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

DecimalToBinaire(1324)

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

Sub test()
MsgBox myRound(4.333, 1, myRoundup)
MsgBox myRound(4.333, 1, myRoundDown)
End Sub

Voici par exemple une fonction pour calculer un écart type sur les valeurs contenues dans un tableau :

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

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

Function ispair(mavar As Long) As Boolean 
ispair = Not mavar And 1 
End Function

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

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

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

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

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

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

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

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) + ")")

SC.Eval("unescape(" + Chr(34) + strEncode + Chr(34) + ")")

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

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

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

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

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

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

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

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