'Traitement derreur	p. 35

Sub Ouvrir()
Dim FN As String
  FN = "D:\ClasseurA.xls"
  On Error GoTo TraitErr
  Workbooks.Open Filename:=FN
  On Error GoTo 0
...  
...  
  Exit Sub
TraitErr:
  FN = InputBox("Impossible d'ouvrir " + FN + _
    vbCr + "Entrez la bonne dsignation")
  Resume
End Sub


'Initialisations de tableaux	p. 50

  Dim Vecteur(3) As Single, T(),NC
    Vecteur(1) = 1.5
  Vecteur(2) = 4.5
  Vecteur(3) = 12.78
  T = Array(1, 2, 3)
  NC = Array("Dupont", "Durand", "Duval")


'Ex. sur Select Case	p. 58

  Select Case Montant
	Case 0 To 2000
		Taux_Remise = 0
	Case 2001 To 5000
		Taux_Remise = 0.05
	Case 5001 To 10000
		Taux_Remise = 0.07
	Case Else
		Taux_Remise = 0.1
  End Select

  Select Case Situation_Famille
	Case "Mari"
		Nc = InputBox("Nom de votre conjoint ? ")
	Case "Divorc"
		D = InputBox("Date du divorce ? ")
  End Select


'Recherche dun lment	p. 61

  L = 0
  Do
    L=L+1
    If IsEmpty(Cells(L,1)) Then Exit Do
  Loop Until Cells(L,1).Value = "Dupont"


'Somme et moyenne	p. 62

  For N = 10.5 To 5 Step -1	
     MsgBox N				
  Next N					
  MsgBox  "A la fin, N = " & N

  SommeVentes = 0
  For L = 1 To 500  On suppose quil y a moins de 500 ventes
    If IsEmpty(Cells(L,1)) Then Exit For
    SommeVentes = SommeVentes + Cells(L,2).Value
  Next L
  MontantMoyen = SommeVentes / (L-1)  


'Transfert dune matrice	p. 62, 63

  Dim M(10,10) As Double
  For L = 1 To 10
    For K = 1 To 10
        If IsEmpty(Cells(L,K) Then
            M(L,K) = 0
        Else
            M(L,K) = Cells(L,K).Value
        End If
    Next K
  Next L


'Existence dune feuille dans un classeur	p. 63

  Dim Sh As Worksheet, Trouv As Boolean
  Trouv = False
  For Each Sh In activeWorkbook.Worksheets
    If Sh.Name = "Bilan" Then Trouv = True : Exit For
  Next


'Factorielle	p. 66

  Function Fact(N As Integer) As Long
    If N <= 1 Then Fact = 1 Else Fact = N * Fact(N-1)
  End Function


'Vrification  lentre dans une cellule	p. 72

 Private Sub Worksheet_Change(ByVal Target As Range)
  Select Case Target.Address
    Case "$J$6"
      If Not IsNumeric(Target.Value) Then MsgBox "Il faut un nombre"
      Target.Select
    Case "$J$8"
      If Not IsDate(Target.Value) Then MsgBox "Il faut une date"
      Target.Select
  End Select
 End Sub


'Ouvrir un classeur quand on clique sur son nom	  p. 79

 Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, _
       Cancel As Boolean)
  If Target.Column = 1 Then Cancel = True
 End Sub

 Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim t As String
    t = Target.Value
    If Right(t, 4) = ".xls" Then Workbooks.Open t
 End Sub


'Installer une bordure	p. 80

  With Selection.Borders(xlEdgeBottom)
	.LineStyle=xlDouble
	.Weight=xlThin
	.Color=RGB(255,0,0)
  End With


'Obtenir le commentaire dune cellule	p. 84

  Public Function TextCom(r As Range) As String
  Dim x As String
    On Error GoTo erxx
    x = r.Comment.Text
    On Error GoTo 0
    TextCom = x
    Exit Function
  erxx:
    x = ""
    Resume Next
  End Function


'Afficher la BDi de choix de fichier	p. 88

 TraitErr:
  MsgBox "Impossible d'ouvrir " + FN + _
    vbCr + "Choisissez dans la BDi qui suit")  
  FN = Application.GetOpenFilename()
  Resume
 End Sub



Inhibition de labandon dun contrle	p. 96

 Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
  If IsNumeric(TextBox1.Text) Then
    B_Chercher.Enabled = True
    B_OK.Enabled = False
  Else
    Cancel = True
  End If
 End Sub 


'Remplissage dune liste, ajout  la liste	p. 97

 Private Sub ListBox1_Enter()
  ListBox1.Clear
  ListBox1.AddItem "..."
  ListBox1.AddItem "..."  ' et ainsi de suite ...
 End Sub
 Private Sub ListBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
  Dim t As String, i As Integer
  If ListBox1.Text = "" Then
    t = ""
    For i = 0 To ListBox1.ListCount - 1
      If ListBox1.Selected(i) Then t = t + ListBox1.List(i)
    Next i
  End If
  MsgBox ListBox1.Text + CStr(ListBox1.ListIndex) + t
 End Sub

 Private Sub ComboBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
  If ComboBox1.ListIndex = -1 Then ComboBox1.AddItem ComboBox1.Text
 End Sub


'Mettre une date dans une cellule	p. 107

  Dim dDatact As Date, cDatact As String

  dDatact=Date
  cDatact= CStr(dDatact)

  cDatact=Format(dDatact,"dd/mm/yyyy")

  Range("A2").NumberFormat="@"  On formate en texte
  Range("A2").Value=dDatact

  Range("A2").FormulaLocal=dDatact


'Type personnalis et dictionnaire	p. 110

  Type Donnes_Client 
	Nom As String
	Prnom As String
	Chiffre_Affaires As Single
	Ajour As Boolean
  End Type
  ...

  Dim Client As Donnes_Client
  Cells(L,1).Value=Client.Nom
  Cells(L,2).Value=Client.Prnom
  Cells(L,3).Value=Client.Chiffre_Affaires
  Cells(L,4).Value=Client.Ajour
  With Client
   .Nom = Cells(2, 1)
   .Prnom = Cells(2, 2)
   .Chiffre_Affaires = Cells(2, 3)
   .Ajour = Cells(2, 4)
  End With


  Dim Notes As Object  
  Set Notes=CreateObject("Scripting.Dictionary")
  Notes.Add "Andrani", 15   	 Ajout/cration dun lment
  Notes.Add "Dupont", 13
  Notes.Add "Durand", "Absent"
  ...
  MsgBox Notes("Dupont")    	 Utilisation comme mmoire 
  Notes("Durand")=12             associative
  Notes.Key("Dupont")= "Dupond"  Rectification dune cl
  Notes.Remove  "Einstein"   	 Suppression dun lment
  Notes.RemoveAll		 Vidage du dictionnaire
  Set Notes=Nothing		 Libration de la mmoire


'Comptage de mots diffrents	p. 111

Sub mots()
 Dim VarMots() As String
 Dim L As Integer, N As Integer, NMots As Integer, Mot As String, _
    tr As Boolean
 ReDim VarMots(10)  1re attribution, pas besoin de Preserve
 NMots = 0
 For L = 1 To 1000
  If IsEmpty(Cells(L, 1)) Then Exit For
  Mot = Cells(L, 1).Value
  tr = False
  If NMots > 0 Then
    For N = 1 To NMots
      If Mot = VarMots(N) Then tr = True: Exit For
    Next N
  End If
  If tr Then Exit For
  NMots = NMots + 1
  If NMots > UBound(VarMots) Then ReDim Preserve  _  
       VarMots(UBound(VarMots) + 10)
  VarMots(NMots) = Mot
 Next L
 For N = 1 To NMots
  Cells(N, 3).Value = VarMots(N)
 Next N


'Lister les sous-rpertoires	p. 113

 Sub Sousrep()
   Dim x As String, c As String
   c = "d:\Tsoft\"
   x = Dir(c, vbDirectory)
   While x <> ""
     If GetAttr(c + x) And vbDirectory Then Debug.Print x
     x = Dir
   Wend
 End Sub


'Lecture-criture fichier	p. 115

 Sub Ecrit()
  Dim i As Integer
  Open "d:\Tsoft\e1.txt" For _ Output As #1
  Width #1, 3
  For i = 0 To 9
    Print #1, Chr(48 + i);
  Next i
  Close #1
 End Sub

 Sub Lit()
  Dim x As String
  Open "d:\Tsoft\e1.txt" For _ Input As #1
  Do
    Line Input #1, x
    Debug.Print x + "I"
  Loop Until EOF(1)
  Close #1
 End Sub


'Liste de tous les classeurs Excel dun rpertoire	p. 116

 Sub Rech()
  Dim n As Long, i As Integer
  With Application.FileSearch
    .LookIn = "d:\Tsoft"
    .Filename = "*.xls"
    .SearchSubFolders = True
    n = .Execute
    If n > 0 Then
      Debug.Print n & " " & .FoundFiles.Count
      For i = 1 To .FoundFiles.Count
        Debug.Print .FoundFiles(i)
      Next i
    End If
  End With
 End Sub


'BDi dynamique	p. 120

  Dim tb As Control
  Set tb = Controls.Add("Forms.TextBox.1", "TextBox1", True)
  tb.Left = 30
  tb.Top = 60
  tb.Text = "..."

 Private Sub CommandButton2_Click()
  If Me.Height > 180 Then
    CommandButton2.Caption = "Dtails"
    Me.Height = 180
  Else
    CommandButton2.Caption = "Rduire"
    Me.Height = 240
  End If
 End Sub


'Liste de fichiers, de sous-rpertoires	   p. 121

  Dim FS As Object, Rep As Object, ssRep As Object, Fich As Object
  Set FS = CreateObject("Scripting.FileSystemObject")
  Set Rep = FS.GetFolder("D:\Tsoft")
  For Each Fich In Rep.Files
    Debug.Print Fich.Name
  Next
  For Each ssRep In Rep.subFolders
    Debug.Print ssRep.Name & ssRep.Size
  Next
  Debug.Print FS.FileExists("D:\Tsoft\xx.pdf")
  Debug.Print FS.FolderExists("D:\Tsoft")


'Lecture de fichier texte	p. 121

  Dim FS As Object, Fich As Object
  Set FS = CreateObject("Scripting.FileSystemObject")
  Set Fich = FS.Opentextfile("D:\Tsoft\ess1.txt", 1, False)
  While Not Fich.AtEndOfStream
    Debug.Print Fich.ReadLine
  Wend
  Fich.Close
  Set FS = Nothing
  Set Fich = Nothing


'Utilisation du Compagnon Office	p. 122

  Dim FS As Object, Fich As Object
  Set FS = CreateObject("Scripting.FileSystemObject")
  Set Fich = FS.Opentextfile("D:\Tsoft\ess1.txt", 1, False)
  While Not Fich.AtEndOfStream
    Debug.Print Fich.ReadLine
  Wend
  Fich.Close
  Set FS = Nothing
  Set Fich = Nothing
 Assistant.FileName="offcat.act" 
 Assistant.Visible = False
  With Assistant.NewBalloon
    .Heading = "Attention"
    .Labels(1).Text = "la machine va s'teindre"
    .Labels(2).Text = "Je vous l'avais dit !"
    .Show
  End With

 Sub Langues()
 Dim bln As Balloon, la As String
  la = ""
  Assistant.Visible = False
  Set bln = Assistant.NewBalloon
  With bln
    .Heading = "Langues connues"
    .CheckBoxes(1).Text = "Anglais"
    .CheckBoxes(2).Text = "Allemand"
    .Button = msoButtonSetOkCancel
    .BalloonType = msoBalloonTypeButtons
    If .Show = msoBalloonButtonOK Then
      If .CheckBoxes(1).Checked Then la = la + "Anglais "
      If .CheckBoxes(2).Checked Then la = la + "Allemand "
      MsgBox "Langue(s) " + la
    End If
  End With
 End Sub


'Marquer un dlai	p. 124

 Sub Delai(s As Single)
   s = Timer + s
   While Timer < s
      DoEvents
   Wend
 End Sub


'Traitements priodiques	p. 124, 125

 Dim L As Integer
 Sub act()
  L = 0
  action1
 End Sub
 Sub action1()
  L = L + 1
  Cells(L, 2).Value = L
  If L < 50 Then
    DoEvents
    Application.OnTime Now + _ 
       TimeValue("00:00:01"),"action1"
  End If
 End Sub

 Dim L As Integer, ac As Boolean
 Sub act2()
  L = 0
  While L<50
    ac = False
    Application.OnTime Now + _ 
       TimeValue("00:00:01"),"action2"  
    While Not ac
      DoEvents
    Wend
  Wend
 End Sub
 Sub action2()
  L = L + 1
  ac = True
  Cells(L, 2).Value = L
 End Sub


'Pilotage  distance de Word	p. 127

  Dim s
  s = Shell("notepad.exe x.txt", 1)  Appelle le bloc-notes
  AppActivate s                sur le fichier x.txt
  SendKeys "Bonjour{ENTER}"    ajoute Bonjour au dbut
  DoEvents
  SendKeys "^s"                sauve le fichier
  DoEvents
  SendKeys "%{F4}"             quitte le bloc-notes
  DoEvents

  Dim wd As Object
  Set wd = CreateObject("Word.Document")
  wd.content.insertafter Text:="Bonjour"
  wd.SaveAs "dw"
  wd.Close
  Set wd = Nothing


'Programmation objet : cration dobjets personnels	p. 128 sqq

'1re tape

'Le module de classe Voiture

Dim Car As String, Teinte As _ String
Private Sub Class_Initialize()
  Me.Genre = "Cabriolet"
  Me.Couleur = "Rouge"
End Sub
Public Property Get Couleur() _ As String
  Couleur = Teinte
End Property
Public Property Let Couleur(ByVal vNewValue As _ String)
  Teinte = vNewValue
End Property
Public Property Get Genre() _
As  Variant
  Genre = Car
End Property
Public Property Let Genre _ (ByVal vNewValue As Variant)
  Car = vNewValue
End Property

'Le module dutilisation Module 1

Sub essai()
  Dim V As New Voiture
  MsgBox V.Genre + " " + _ V.Couleur
  V.Couleur = "Bleu"
  V.Genre = "Berline"
  MsgBox V.Genre + " " + _ V.Couleur
End Sub

'2 tape

'Le module de classe Voiture

Dim Car As String, Teinte As _ String, Kilom As Long
Private Sub Class_Initialize()
  Dim s As String, p As Integer
  s=InputBox("Genre,Couleur?",_ "Voiture","Cabriolet,Rouge")
  p = InStr(s, ",")
  Me.Genre = Left(s, p - 1)
  Me.Couleur = Mid(s, p + 1)
  Kilom = 0
End Sub
Public Property Get Couleur() As String
  Couleur = Teinte
End Property
Public Property Let Couleur(ByVal vNewValue As _  String)
  Teinte = vNewValue
End Property
Public Property Get Genre()As _ Variant
  Genre = Car
End Property
Public Property Let Genre _ (ByVal vNewValue As Variant)
  Car = vNewValue
End Property
Public Property Get KM() As _ Variant
  KM = Kilom
End Property
Public Sub Rouler(k As Long)
  If k < 0 Then Exit Sub
  Kilom = Kilom + k
End Sub

'Le module dutilisation Module 1

Sub essai()
  Dim V As New Voiture
  MsgBox V.Genre & " " & V.Couleur & " " & V.KM & " km"
  V.Couleur = "Bleu"
  MsgBox V.Genre & " " & V.Couleur & " " & V.KM & " km"
  V.Rouler (10000)
  MsgBox V.Genre & " " & V.Couleur & " " & V.KM & " km"
  V.Genre = InputBox("Transformer en ?", "Voiture", V.Genre)
  MsgBox V.Genre & " " & V.Couleur & " " & V.KM & " km"
End Sub

'3 tape

'Le Module dobjet Feuil1

Private WithEvents V As Voiture
Private Sub V_Panne()
  MsgBox "Panne  " & V.KM & " km"
End Sub
Sub essai()
  Set V = New Voiture
  MsgBox V.Genre & " " & V.Couleur & " " & V.KM & " km"
  V.Couleur = "Bleu"
  MsgBox V.Genre & " " & V.Couleur & " " & V.KM & " km"
  V.Rouler (10000)
  MsgBox V.Genre & " " & V.Couleur & " " & V.KM & " km"
  V.Genre = InputBox("Transformer en ?", "Voiture", V.Genre)
  MsgBox V.Genre & " " & V.Couleur & " " & V.KM & " km"
  V.Rouler (15000)
End Sub

'Le module de classe Voiture

Dim Car As String, Teinte As String, Kilom As Long

Public Event Panne()

Private Sub Class_Initialize()
  Dim s As String, p As Integer
  s = InputBox("Genre,Couleur ? ", "Voiture", "Cabriolet,Rouge")
  p = InStr(s, ",")
  Me.Genre = Left(s, p - 1)
  Me.Couleur = Mid(s, p + 1)
  Kilom = 0
End Sub
Public Property Get Couleur() As String
  Couleur = Teinte
End Property
Public Property Let Couleur(ByVal vNewValue As String)
  Teinte = vNewValue
End Property
Public Property Get Genre() As Variant
  Genre = Car
End Property
Public Property Let Genre(ByVal vNewValue As Variant)
  Car = vNewValue
End Property
Public Property Get KM() As Variant
  KM = Kilom
End Property

Public Sub Rouler(k As Long)
  If k < 0 Then Exit Sub
  Kilom = Kilom + k
  RaiseEvent Panne
End Sub


'Gestion dune barre de progression	p. 137

'Calendrier

'Appel de la BDi

 Sub ChDate()
  UF_ChoixDate.Show
  MsgBox "Vous avez choisi " + CStr(Dat)
 End Sub

'Dans le module associ  la BDi :

 Private Sub CommandButton1_Click()
  With Calendar1
    Dat = DateSerial(.Year, .Month, .Day)
  End With
  Unload Me
 End Sub

'Progression

 Sub Progres()
 Dim i As Integer
  Load UFP
  With UFP.ProgressBar1
    .Min = 0
    .Max = 50
    .Value = 0
    UFP.Show
    For i = 1 To 50   Boucle de progression
      Delai (0.5)     Il y a normalement ici un
      .Value = i      traitement plus complexe
    Next i
  End With
  Unload UFP
 End Sub


'Personnalisation de barres doutils ou de menus	p. 141, 142

  Dim nvBar As CommandBar, Bout As CommandBarButton
  Dim cbb As CommandBarComboBox, Men As CommandBarPopup
  Dim men1 As CommandBarPopup, men2 As CommandBarPopup
 Sub creBarre()
  Set nvBar = Application.CommandBars.Add(Name:="Barre2", _
    Position:=msoBarTop, MenuBar:=True, Temporary:=True)
  nvBar.Enabled = True
  nvBar.Visible = True
  Set Bout = nvBar.Controls.Add(msoControlButton)
  Bout.Picture = _ stdole.StdFunctions.LoadPicture("D:\Tsoft\memxlvba\Imb.bmp")
  Bout.OnAction = "pBout"
  Set cbb = nvBar.Controls.Add(msoControlComboBox)
  cbb.AddItem "Choix 1"
  cbb.AddItem "Choix 2"
  cbb.OnAction = "pcbb"
  Set Men = nvBar.Controls.Add(msoControlPopup)
  Men.Caption = "Menu0"
  Set men1 = Men.Controls.Add(msoControlPopup)
  men1.Caption = "Menu1"
  men1.OnAction = "pMen1"
  Set men2 = Men.Controls.Add(msoControlPopup)
  men2.Caption = "Menu2"
  men2.OnAction = "pMen2"
 End Sub
 
 Sub pBout()
   MsgBox "Bouton"
 End Sub
 Sub pcbb()
  MsgBox cbb.Text
 End Sub
 Sub pmen1()
  MsgBox men1.Caption
 End Sub
 Sub pmen2()
  MsgBox men2.Caption
 End Sub

 Sub Retablir()
  Dim x As CommandBar
  CommandBars("Barre2").Delete
  Set x = CommandBars("Worksheet Menu Bar")
  x.Enabled = True
  x.Visible = True
 End Sub

 Sub affBarres()
  Dim x As CommandBar
  For Each x In Application.CommandBars
    Debug.Print x.Name
  Next
 End Sub


'Graphique	p. 144

Dim m As Integer
  Charts.Add
  With ActiveChart
   .SetSourceData Source:=Sheets("Feuil2"). _
        Range("A1:F5"), PlotBy:=xlRows
   For m = 1 To 4
      .SeriesCollection(m).XValues = Sheets("Feuil2") _
          .Range("B1:F1").Value
      .SeriesCollection(m).Values = Sheets("Feuil2") _
          .Range("B" & m + 1 & ":F" & m + 1).Value
      .SeriesCollection(m).Name = Sheets("Feuil2") _
          .Range("A" & m + 1).Value
   Next m
   .ChartType = xlLine
   .Location Where:=xlLocationAsNewSheet
   .Axes(xlCategory, xlPrimary).HasTitle = True
   .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Annes"
   .Axes(xlValue, xlPrimary).HasTitle = True
   .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Tonnes"
   .PlotArea.Interior.ColorIndex = 20    Gris
   .Axes(xlValue).MajorGridlines.Border.LineStyle = xlDot
   .ChartArea.Font.Size = 15
   .Deselect
   .Move
  End With

  .SetSourceData Source:=Sheets("Feuil3") _
        .Range("A1:D3"),PlotBy:=xlRows
  For m = 1 To 2
      .SeriesCollection(m).XValues = Array(2000, 2001, 2002)
      .SeriesCollection(m).Values = Array(100 * m, 80 * m, 150 * m)
      .SeriesCollection(m).Name = "Srie " + CStr(m)
  Next m


'Parcourir la partie utile dune feuille , trouver la 1re ligne vide	p. 145

 For Ligne=Dbut To 65536
	If IsEmpty(Cells(Ligne,Col)) Then Exit For
 ... ' faire ce quon a  faire sur les lignes utiles
 Next Ligne
' Ici Ligne=n de la premire ligne vide

  Cells(L,C).Select
  PLV=ActiveCell.CurrentRegion.Rows.Count+1


'Parcourir la partie utile dune feuille pour rechercher une donne	p. 145

  For Ligne=Dbut To 65536
	If IsEmpty(Cells(Ligne,Col)) Then Exit For
	If Cells(Ligne,Col).Value=VATR Then Exit For
  Next Ligne
' Ici Ligne=n de la premire ligne vide ou de la valeur trouve
  If Not IsEmpty(Cells(Ligne,Col)) Then MsgBox "Trouv !"

  Tr=False
  For Ligne=Dbut To 65536
	If IsEmpty(Cells(Ligne,Col)) Then Exit For
	If Cells(Ligne,Col).Value=VATR Then Tr=True:Exit For
  Next Ligne
  If Tr then MsgBox "Trouv !"

  Cells(Dbut,Col).Select
  Tr=False
  For Ligne=Dbut To ActiveCell.CurrentRegion.Rows.Count
	If Cells(Ligne,Col).Value=VATR Then Tr=True: Exit For
  Next Ligne
  If Tr then MsgBox "Trouv !"


'Insrer un lment  sa place dans lordre alphabtique	p. 146

 For Ligne=Dbut To 65536
  If IsEmpty(Cells(Ligne,Col)) Then Exit For
  If NouvNom<Cells(Ligne,Col).Value Then
    Cells(Ligne,Col).EntireRow.Insert
    Exit For
  End IF
 Next Ligne
 ' Ici Ligne=n de la premire ligne vide ou de la ligne vide insre
 Cells(Ligne,Col).Value=NouvNom
 ... ' Autres donnes


'Regroupement de donnes	p. 146

  Set FD=Sheets("Dpart") : Set FC=Sheets("Cumuls")
  For Ligne=Dbut To 65536
   If IsEmpty(FD.Cells(Ligne,Colnom)) Then Exit For
   Nom=FD.Cells(Ligne,Colnom).Value 
   For Ligne2=Dbut To 65536
      If IsEmpty(FC.Cells(Ligne2,Colnom)) Then Exit For
      If Nom=FC.Cells(Ligne2,Colnom).Value Then Exit For
   Next Ligne2
   FC.Cells(Ligne2,Colnom).Value=Nom
   FC.Cells(Ligne2,ColCA).Value=FC.Cells(Ligne2,ColCA).Value _
           + FD.Cells(Ligne,ColCA).Value
  Next Ligne


'Lire dans un fichier classeur sans louvrir	p. 146

 Range("B5").FormulaLocal = "='D:\Tsoft\[Clf.xls]Feuil1'!A1"
 Debug.Print Range("B5").Value


'Copie dun fichier	p. 146

  Open "D:\Tsoft\ess1.txt" For Input As #1
  Open "D:\Tsoft\ess1cop.txt" For Output As #2
  While Not EOF(1)
    x = Input(1, #1)
    Print #2, x;
  Wend
  Close 2
  Close 1


'Reprer le maximum dans une liste	p. 147

  Lmax=1 : MaxProv=Cells(Lmax,Col).Value
  For Ligne=2 To 65536
    If Cells(Ligne,Col).Value>Lmax then
        Lmax=Ligne : MaxProv=Cells(Lmax,Col).Value        
    End If
  Next Ligne
  MsgBox "Maximum " & MaxProv & "  la ligne " & Lmax


'Recherche dichotomique dans un tableau ou une feuille	p. 147

 Function Dicho(NomCher As String, Col As Integer, Ldep As Long) _
     As Long
  Dim Linf As Long, Lsup As Long, Lmil As Long
  Linf = 2
  Lsup = ActiveCell.CurrentRegion.Rows.Count
  If (NomCher > Cells(Lsup, Col).Value) Or (NomCher < _
    Cells(Linf, Col).Value) Then Dicho = 0: Exit Function 
  If NomCher = Cells(Linf, Col) Then Dicho = Linf: Exit Function
  If NomCher = Cells(Lsup, Col) Then Dicho = Lsup: Exit Function
  Lmil = (Linf + Lsup) \ 2
  While (Lmil <> Linf) And (NomCher <> Cells(Lmil, Col).Value)
    If NomCher > Cells(Lmil, Col).Value Then
      Linf = Lmil : Lmil = (Linf + Lsup) \ 2
    Else
      If NomCher < Cells(Lmil, Col).Value Then
        Lsup = Lmil : Lmil = (Linf + Lsup) \ 2
      End If
    End If
  Wend
  If NomCher = Cells(Lmil, Col).Value Then Dicho=Lmil Else Dicho = 0
 End Function


'Somme et moyenne des lments dun tableau	p. 147

  S=0
  N=0
  For I=LBound(Valeurs) To UBound(Valeurs)
    N=N+1
    S=S+Valeurs(I)
  Next I
  M=S/N


'Fonction dcelant si un classeur est ouvert	p. 148

 Function Ouvert(Nom as String, Optional F As Boolean=False) As _
     Boolean
   Dim W As Workbook, Tr As Boolean
   Tr=False
   For Each W In Workbooks
      If F Then
         If W.FullName=Nom then Tr=True: Exit For
      Else
         If W.Name=Nom then Tr=True: Exit For
      End If
   Next
   Ouvert=Tr
 End Function


'Fichier texte  longueur de ligne constante	p. 148

 Sub EcritLargConst()
  Dim i As Integer, Ligne As String, Larg As Integer
  Larg = 10 : Ligne = Space(Larg)  'Largeur  dcider
  Open "d:\Tsoft\ess2.txt" For Output As #1
  For i = 0 To 9
    Mid(Ligne, 1) = Chr(48 + i)    'ou toute donne
    Print #1, Ligne + vbCr;        'de largeur < Larg
  Next i
  Close #1
 End Sub


'Choix exclusifs dans le Compagnon Office	p. 148

 Sub Assist()
 Dim bln As Balloon
  Assistant.Visible = False : Set bln = Assistant.NewBalloon
  With bln
    .Heading = "Langue connue" : .Labels(1).Text = "Anglais"
    .Labels(2).Text = "Allemand" : .Button = msoButtonSetNone
    .BalloonType = msoBalloonTypeButtons : .Mode = msoModeModeless 
    .Callback = "Traite"  Procdure appele ds quon a cliqu
    .Show                 sur un des boutons ; elle doit avoir
  End With                les 3 args. indiqus notamment lbtn
 End Sub                   qui fournit le n du bouton cliqu
 Sub Traite(bln As Balloon, lbtn As Long, lPriv As Long)
  Const la = "Anglais Allemand"
  If lbtn > 0 Then MsgBox "Langue " & Mid(la, 1 + 8 * (lbtn - 1), 8)
  bln.Close  Ncessaire  cause du mode Modeless
 End Sub


'Initialisation au dmarrage	p. 153

 Public InitFait As Boolean
 Sub Init()
   InitFait=True
   ...

 Sub NouvCli()
   If Not InitFait Then Init
   ...

 Private Sub Workbook_Open()
   InitFait=False
 End Sub


'Systme daide	  p. 154

' Attention, ceci n'est pas du VBA :
<html>
<body>
<pre>
<font face=arial>
votre texte (sa prsentation sera
respecte grce  la balise pre)
</font>
</pre>
</body>
</html>

' Maintenant, on a du VBA

 Sub Aide()
  ThisWorkbook.FollowHyperlink Address:=ThisWorkbook.Path &  _
             "\aide.htm", NewWindow:=True
 End Sub

' Version qui fonctionne aussi sur MAC :

 Sub Aide()
  ThisWorkbook.FollowHyperlink Address:=ThisWorkbook.Path &  _
             Application.PathSeparator & "aide.htm", NewWindow:=True
 End Sub


'Gestion avec dictionnaire des donnes	p. 155

 Public Function AdrDon(Wk As Workbook,NomDon As String) As String
 Dim i as Integer
   With Wk.Sheets("DictDon")
    For i=2 to 100
      If IsEmpty(.Cells(i,1)) Then Exit For
      If .Cells(i,1).Value=NomDon Then AdrDon=.Cells(i,2).Value: _
            Exit Function
    Next i 
   End With
  AdrDon=""
 End Function
 Public Function PrendDon(Wk As Workbook,NomDon As String) As Variant
 Dim Adre As String, p as Integer
  Adre=AdrDon(Wk,NomDon)
  If Adre="" Then
    PrendDon=""
    MsgBox  NomDon +" Non trouv"
  Else
    p = InStr(Adre, "!")
    PrendDon = Wk.Sheets(Left(Adre, p - 1)). _
       Range(Mid(Adre, p + 1)).Value
  End If
 End Function
 Public Sub MetDon(Wk As Workbook,NomDon As String, Donne As _
               Variant)
 Dim Adre As String, p as Integer
  Adre=AdrDon(Wk,NomDon)
  If Adre="" Then
    MsgBox  NomDon +" Non trouv"
  Else
    p = InStr(Adre, "!")
    Wk.Sheets(Left(Adre, p - 1)).Range(Mid(Adre, _
      p + 1)).Value = Donne  
  End If
 End Sub


