REFERENCE WEB :

      http://www.info-3000.com/vbvba/tableau.php

====================================================

Les tableaux :

Exemple basique

Sub Tableau()
  Dim Armoire(3)
  Armoire(1) = "Assiette"
  Armoire(2) = "Verre"
  Armoire(3) = "Serviette"
  MsgBox Armoire(1)
  MsgBox Armoire(2)
  MsgBox Armoire(3)
End Sub


--------------------------------------------------------------------------------

Exemple de tableau typé

Sub tableauV2()
  Dim Tableau(1 To 10) As Integer
  ' Tableau(3) = "test" Génère une erreur
  Tableau(4) = 775
End Sub

===================================================

Attribute VB_Name = "EnvironnementEtLoginName"
'renseignements sur l'environnement local et réseau

'Ron de Bruin, mpep
Sub PCInformation()
Dim msg
  msg = "UserName" & vbTab & Environ$("username") & vbNewLine _
      & "UserProfile" & vbTab & Environ("UserProfile") & vbNewLine _
      & "Computer #" & vbTab & Environ$("ComputerName") & vbNewLine _
      & "Logon Server" & vbTab & Environ$("Logonserver") & vbNewLine _
      & "UserDomain " & vbTab & Environ$("UserDomain")
  MsgBox msg, , "Environment Variables"
End Sub

'suite
Sub RetrieveLogonName()
Dim wshNetwork As Object
Dim LogonName As Variant

  Set wshNetwork = CreateObject("WScript.Network")
  LogonName = "Logon Name = " & wshNetwork.UserName
  MsgBox LogonName

End Sub

========================================================

Dim new_value As String
Dim txt As String
Dim i As Integer
Dim Buffer() As Byte
Dim Addr As Long
Dim sTemp As String
Dim i As Lon

Dim TLApp As TLI.TLIApplication
Dim TLInfo_XL As TLI.TypeLibInfo
Dim MemInfo As TLI.MemberInfo
Dim ConstInfo As TLI.ConstantInfo
Dim DestCell As Range
Dim hpl$
Dim MyData As DataObject

========================================================

Attribute VB_Name = "AvecDoublonsOuNon"

'savoir si une plage comporte ou non des doublons

Function HasDoublons(Plage As Range)

Dim Coll As New Collection, cell As Range
  On Error Resume Next
  For Each cell In Plage
    If cell.Text <> "" Then Coll.Add "zaza", cell.Text
  Next
  Err.Clear
  HasDoublons = Not (Coll.Count = Plage.Count)
End Function
Attribute VB_Name = "ChercherDansUneChaine"

========================================================

'Comment je peux tester facilement la présence d'un caractère dans une chaîne?

'la petite fonction suivante qui renvoie VRAI si Caractere est
'trouvé dans Chaine (Pierre Fauconnier, mpfe)

Function RechercheCar(Chaine, Caractere) As Boolean

Dim i As Integer
  For i = 1 To Len(Chaine)
    If Mid(Chaine, i, 1) = Caractere Then RechercheCar = True
  Next i
End Function

========================================================

'Y a t'il une fonction VBA qui renvoie le nombre d'occurences
'd'un caractère trouvées dans une chaîne

Function nbOcc(TexteCherché As String, Texte As String) As Integer

'Iznogood, mpfe
Dim i As Long
  Do
    i = InStr(i + 1, Texte, TexteCherché, 1)
    If i <> 0 Then nbOcc = nbOcc + 1
  Loop Until i = 0
End Function

========================================================

' Retourne le nombre d'occurences du 1er caractère de Texte2 dans Texte1
' utilisation de references-cellule et/ou textes entre quotes doubles.
' ex:  NbrOccurences(A5;A3)
'   ou NbrOccurences("Le blaba abcdefgh";"e")

Function NbrOccurences(Texte1, Texte2)

'GeeDee, mpfe
    NbrOccurences = 0
    For i = 1 To Len(Texte1)
    If Mid(Texte1, i, 1) = Left(Texte2, 1) Then NbrOccurences = NbrOccurences + 1
    Next
End Function

'Sans VBA (JièL, mpfe)
'=NBCAR(A1)-NBCAR(SUBSTITUE(MINUSCULE(A1);"e";""))

  Const Symb = "IVXLCDM"
  Dim I As Integer, J As Integer
  Dim K As Integer, L As Integer, S As Integer
  Dim C As String * 1, Prec As Boolean

Attribute VB_Name = "ChiffresRomainsChiffresArabes1"

========================================================

'----------------------------------------------------------------------
' Conversion d'un nombre < 4000 en chiffres romains (style "classique")
' vers un nombre en chiffres arabes
'----------------------------------------------------------------------
'Laurent Longre, mpfe

Function ROMINVERSE(Nombre As String)

  Const Symb = "IVXLCDM"
  Dim I As Integer, J As Integer
  Dim K As Integer, L As Integer, S As Integer
  Dim C As String * 1, Prec As Boolean

  On Error GoTo Erreur
  I = Len(Nombre)
  Do
    K = InStr(1, Symb, Mid$(Nombre, I, 1))
    If K = 0 Or K = J Then Err.Raise xlErrValue
    S = IIf(K Mod 2, 1, 5) * 10 ^ ((K - 1) \ 2)
    If K < J Then
      If Not Prec Then Err.Raise xlErrValue
      Select Case Mid$(Nombre, I, 2)
        Case Is = "ID", Is = "IM", Is = "VX", Is = "VD", _
        Is = "VM", Is = "LC", Is = "DM"
          Err.Raise xlErrValue
      End Select
      ROMINVERSE = ROMINVERSE - S
      I = I - 1
      Prec = False
    ElseIf K Mod 2 Then
      C = Mid$(Symb, K, 1)
      L = 0
      Do
        If Mid$(Nombre, I, 1) = C Then
          If L = 3 Then Err.Raise xlErrValue
          ROMINVERSE = ROMINVERSE + S
          I = I - 1
          L = L + 1
        Else
          Prec = L = 1
          Exit Do
        End If
      Loop While I
    Else
      ROMINVERSE = ROMINVERSE + S
      I = I - 1
      Prec = True
    End If
    J = K
  Loop While I
  Exit Function

Erreur:
  ROMINVERSE = CVErr(Err)

End Function

========================================================

Attribute VB_Name = "CompareChaines"

'Eric Jeanne, mpfe
'compare lettre à lettre 2 chaines de caractères
'renvoie -1 si elles sont identiques,
'ou le nombre de caractères qu'elles ont en commun,
'de la gauche vers la droite (sensible à la casse)

Function comparCh(ch1, ch2)

Dim lg1%, lg2%, i%

    Application.Volatile True

    If ch1 = ch2 Then
        comparCh = -1

    Else
        lg1 = Len(ch1)
        lg2 = Len(ch2)

        i = 1
            While Mid(ch1, i, 1) = Mid(ch2, i, 1)
                i = i + 1
            Wend

        comparCh = i - 1

    End If

End Function

Sub test()
    MsgBox comparCh("paul za", "paul zaza")
    MsgBox comparCh("paul za", "paul Zaza")
End Sub

=====================================================

Type TableauType
NomOrdi As String
JourAppel As Integer
Mois As Integer
Heure As Date
End Type
Dim Clas() As TableauType

=====================================================

Attribute VB_Name = "ExcelEtLaMusique"

'je voudrais exécuter une musique déjà contenue
'dans Windows, genre "c:\windows\media\canyon.mid".

Private Declare Function mciExecute Lib "winmm.dll" _
(ByVal lpstrCommand As String) As Long

Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" _
    (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, _
    ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long

Declare Function sndPlaySoundA Lib "winmm.dll" _
    (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long

Private Declare Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" _
    (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long

Public Const MusicFile$ = "C:\Windows\Media\Canyon.mid"
Public Const WavFile$ = "C:\Windows\Media\Son Jungle corbeille.wav"

Const SND_SYNC = &H0
Const SND_ASYNC = &H1
Const SND_FILENAME = &H20000

'==========================
Sub JouerWAV()
'Alain Vallon, mpfe
'Le fichier WAV est joué de façon asynchrone (l'exécution de ton code
'continue pendant le zinzin)

    PlaySound WavFile, 0&, SND_ASYNC Or SND_FILENAME
End Sub


'===========================
Sub SonAPI()
'Eplucheur, mpfe

  sndPlaySoundA WavFile, 1
End Sub

'============================
'O. P Erlandsen (OK)
Sub PlayMidiFile(MidiFileName As String, Play As Boolean)
    If Dir(MidiFileName) = "" Then Exit Sub ' no file to play
    If Play Then
        mciExecute "play " & MidiFileName ' start playing
    Else
        mciExecute "stop " & MidiFileName ' stop playing
    End If
End Sub

Sub TestPlayMidiFile()
    PlayMidiFile MusicFile, True
    MsgBox "Click OK when the MIDI file starts playing..."
    MsgBox "Click OK to stop playing the MIDI file..."
    PlayMidiFile MusicFile, False
End Sub

'============================
'Robert Dezan, mpfe (OK)
Sub Jouer_la_musique()
    DoEvents
    ' paramètres de la musique
    Path_musique = "c:\windows\media\"
    Musique_Nom = "canyon.mid"
    ' jouer la musique
    Call Musique_jouer(Path_musique + Musique_Nom)
End Sub

Public Function Musique_jouer(ByVal Fichier As String, _
                              Optional ByVal Alias As Variant) As Boolean
Dim nRet As Long
    If IsMissing(Alias) Then Alias = "tune"
    ' stoppe la musique en cours d'exécution éventuellement
    Call Musique_Stopper(Alias)
    If mciSendString("open " & Fichier$ & " alias " & Alias, vbNullString, 0, 0) = 0 Then
        nRet = mciSendString("play " & Alias & " from 0", vbNullString, 0, 0)
        Musique_jouer = (nRet = 0)
    Else
        MsgBox "Impossible de jouer la musique." + vbLf + vbLf + "Problème de fichier ou de compatibilité"
        Musique_Stopper
    End If
End Function

Public Sub Musique_Stopper(Optional ByVal Alias As Variant)
    If IsMissing(Alias) Then Alias = "tune"
    Call mciSendString("stop " & Alias, vbNullString, 0, 0)
    Call mciSendString("close " & Alias, vbNullString, 0, 0)
End Sub

'============================

Attribute VB_Name = "AdresseIPduPC"

'renvoie l'adresse IP du PC (renvoi par défaut : 0.0.0.0)

Sub monIP()
'auteur inconnu

  fichTmp$ = "C:\windows\temp\IPaMoi.txt"
  ID = Shell("C:\windows\winipcfg /batch " & fichTmp, 1)
  Set fs = CreateObject("Scripting.FileSystemObject")
  Set f = fs.GetFile(fichTmp)
  Set ts = f.OpenAsTextStream(1, 0)
  For i = 1 To 6
    S = ts.Readline
  Next

  ts.Close
  Kill fichTmp
  MsgBox S

End Sub

Sub test()
  MsgBox AdrIP
End Sub

'la même chose, sous forme de fonction
Function AdrIP()
Dim fichTmp$, S$, ID&, fs As Object, f As Object, ts As Object

  fichTmp$ = "C:\windows\temp\IPaMoi.txt"
  ID = Shell("C:\windows\winipcfg /batch " & fichTmp, 1)
  Set fs = CreateObject("Scripting.FileSystemObject")
  Set f = fs.GetFile(fichTmp)
  Set ts = f.OpenAsTextStream(1, 0)
  For i = 1 To 6
    S = ts.Readline
  Next
  ts.Close
  Kill fichTmp

  AdrIP = Trim(Mid(S, InStr(1, S, ":") + 1))

End Function 'fs


=====================================================

Attribute VB_Name = "CreerPageWeb"


Sub PublishObjectExample()
'Robert Rosenberg, mpep

    Dim oPO As PublishObject

    'Set a reference to the Publish object
    Set oPO = ActiveWorkbook.PublishObjects.Add(xlSourceSheet, _
        "C:\My Documents\LABRCR\ExcelData\Page.htm", "District A", "", xlHtmlCalc)

    'Publish it (Save it as HTML)
    oPO.Publish True

    'Display the unique identifier number
    'This will be different each time this code is run.
    MsgBox oPO.DivID

End Sub

=====================================================

Attribute VB_Name = "DesactiverClavier"

'Désactiver et réactiver les touches du clavier
'Benoit Marchand, mpfe

Sub DésactiverClavier()
Dim clavier As String

  On Error Resume Next
  For Each K In Array("^", "%", "+^", "+%", "^%", "+^%", "")
    For i = 0 To 1000
      Select Case i
        Case 40, 41
          Application.OnKey K & "{" & Chr$(i) & "}", clavier
        Case Else
          Application.OnKey K & Chr$(i), clavier
      End Select
    Next i
  Next K
  Application.OnKey K & Chr$(i), clavier
  For Each K In Array("^", "%", "+^", "+%", "^%", "+^%", "")
    For i = 1 To 12
      Application.OnKey K & "{F" & i & "}", clavier
    Next i
  Next K
End Sub

Sub Rétablir()
Dim clavier As String

  On Error Resume Next
  For Each K In Array("^", "%", "+^", "+%", "^%", "+^%", "")
    For i = 0 To 1000
      Select Case i
        Case 40, 41
          Application.OnKey K & "{" & Chr$(i) & "}"
        Case Else
          Application.OnKey K & Chr$(i)
      End Select
    Next i
  Next K
  Application.OnKey K & Chr$(i)
  For Each K In Array("^", "%", "+^", "+%", "^%", "+^%", "")
    For i = 1 To 12
      Application.OnKey K & "{F" & i & "}"
    Next i
  Next K
End Sub

=====================================================
Attribute VB_Name = "ExcelEtLesImages"

'Insérer une image dans une zone de texte
Sub InserImage()
'Richard Herrmann, mpfe
    Sheets("Etiq").Activate
    ActiveSheet.Shapes("Texte 7").Select
    ChDir "E:\Mes Documents\Mes images" '<-- changez pour votre répertoire
    monimage = Application.GetOpenFilename _
                ("Images (*.bmp;*.gif;*.jpg),*.bmp;*.gif;*.jpg")
    If monimage <> False Then
        Selection.ShapeRange.Fill.UserPicture monimage
    End If
End Sub


'Pour exporter tous les graphiques incorporés dans la
'feuille "Feuil1" comme fichiers GIF dans le répertoire C:\Temp
'(C:\Temp\Chart1.gif, C:\Temp\Chart2.gif etc.)
Sub ExportGraphs()
'L Longre, mpfe
Dim Graph As ChartObject
    'adapter le nom de la feuille
    For Each Graph In Sheets("Feuil1").ChartObjects
        Graph.Chart.Export "C:\Temp\" & Graph.Name & ".gif", "GIF"
    Next Graph
End Sub

Sub ExportRangeAsGif()
'L Longre, mpfe
Dim Plage As Range
' Exportation en .gif de la plage A1:I25 (feuille active)

    Set Plage = ActiveSheet.Range("A1:I25")
    Application.ScreenUpdating = False
    Workbooks.Add
    Plage.CopyPicture
    ActiveSheet.Paste
    With ActiveSheet.ChartObjects.Add(0, 0, _
                Selection.Width, Selection.Height).Chart
        .Paste
        .Export "C:\Temp\Test.gif", "GIF"
    End With
    ActiveWorkbook.Close False

End Sub


=====================================================

Attribute VB_Name = "ExcelEtLesImages4"


'exporter une plage de cellules dans un fichier image

Sub testExport()
  CreateImageFile Range("A1:A25"), "d:\essaiGIF", "gif"
End Sub

'suivant les filtres installés sur votre système, vous pouvez également
'exporter, par ex, aux formats jpg, png , tga , tiff , wpg...

Sub CreateImageFile(TheExportRange As Range, _
                    TheFileName As String, _
                    TheFileFormat As String)
'Victor Eldridge, mpep

    TheExportRange.CopyPicture Appearance:=xlScreen, _
                               Format:=xlPicture

    Dim chtobj As ChartObject
    Set chtobj = TheExportRange.Parent.ChartObjects.Add(1, 1, 1, 1)

    With chtobj
        .Width = TheExportRange.Width + 8
        .Height = TheExportRange.Height + 8
        .Chart.ChartArea.Border.LineStyle = 0
        .Chart.Paste
        .Chart.Export Filename:=TheFileName & "." & TheFileFormat, _
                      FilterName:=TheFileFormat
        .Delete
    End With

    Set chtobj = Nothing

End Sub


=====================================================

Attribute VB_Name = "GraphiqueEnGIF"

'enregistrer un graphique comme une image au format .gif

Sub SaveAsGIF()
Dim graphique As Chart

  Set graphique = Worksheets("Feuil1").ChartObjects(1).Chart
  graphique.Export Filename:="D:\Graph1.gif", filtername:="GIF"

End Sub


Sub AllGraphsAsGIF()
'Laurent Longre
Dim Graph As ChartObject

  For Each Graph In Worksheets("Feuil1").ChartObjects
    Graph.Chart.Export "D:\" & Graph.Name & ".gif", "GIF"
  Next Graph

End Sub

=====================================================

Attribute VB_Name = "PlayMP3"

'jouer un fichier MP3 avec l'application associée à l'extension mp3

Private Declare Function ShellExecute Lib "shell32.dll" Alias _
    "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation _
    As String, ByVal lpFile As String, ByVal lpParameters _
    As String, ByVal lpDirectory As String, _
    ByVal nShowCmd As Long) As Long

Sub TestMP3()
'Dave Peterson, mpep
Dim cmdstring As String
Dim ret As Long

cmdstring = "C:\MusiquesMP3\Pauline Carton - Sous les palétuviers.mp3"

 ret = ShellExecute(0&, vbNullString, cmdstring, _
    vbNullString, vbNullString, vbNormalFocus)

End Sub


Sub TestWAV()
Dim cmdstring As String
Dim ret As Long

cmdstring = "C:\WINDOWS\MEDIA\Tada.wav"

 ret = ShellExecute(0&, vbNullString, cmdstring, _
    vbNullString, vbNullString, vbNormalFocus)

End Sub




=====================================================

Attribute VB_Name = "AleaNonVolatile"


'une fonction non volatile pour générer des nombres aléatoires
'compris entre deux bornes

Function Hasard(HLimite As Double, _
                BLimite As Double, _
                nDécimales As Integer) As Variant
'Patrick Penet, mpfe
  On Error Resume Next
  Randomize
  If nDécimales = 0 Then
    Hasard = Int((HLimite - BLimite + 1) * Rnd + BLimite)
  Else
    Hasard = FormatNumber((HLimite - BLimite + 1) _
                      * Rnd + BLimite, nDécimales)
  End If

End Function

'Ensuite, en A1 rentrer :
'=HASARD(1000;500;0)
'ou 1000 est la limite supérieure,
'500 la limite inférieure
'et 0 le nombre de décimales souhaitées.
'
'Pour provoquer le recalcul de la fonction : éditer
'le contenu de A1 (F2), et taper Entrée.
'(ou Ctrl+Alt+F9 fs)


'autre solution (nombre aléatoire quelconque)
Function StaticRand() 'LL
      StaticRand = Rnd
End Function

=====================================================