https://www.pencomdesign.com/technical-support/vba-software-example/
VBA Software

Visual Basic for Applications Serial Port Software Example
For this demonstration we will be using the mscomm32.ocx driver in VBA 
to control a RS232 serial port and USB virtual serial port that is created 
with the USB driver installed on your system for our USB products.  
This allows a seamless transition between our RS232 and USB devices.
For example, you can be in Access, Excel, or Word and start a macro that 
would power up an external data acquisition unit and receive data into
 the software utilizing VBA, serial control, and one of our serial relay
 boards with I/O.  You could control room lighting, or any other device 
 that you would like to turn ON or OFF from within an application, just 
 think of the many possibilities.
Visual Basic for Applications has many of Visual Basic's commands and 
controls, that can be utilized for control applications.  
We will show you how to use this powerful application to control 
our serial relay boards.

For this demonstration we will use Excel's VBA editor,
 but any of the software that has built in VBA support will work.  
 Start Excel and select >> Tools >> Macro >> Visual Basic Editor,
 from the pull down menus as shown in the picture below, or use Alt+F11 shortcut.
After VBA is loaded, Right Click in the project window,
 Select >> Insert >> Userform and a blank form will be loaded, with a control tool box as shown below.
Now we are going to add a serial port control to the control box so that we may use it in our application
For this demonstration we are going to use the mscomm32.ocx communication driver, depending on what 
other MS applications you have loaded on your system, 
this driver may or may not be available on your system.
Right click in the controls box and select >> Additional Controls
controle supplementaires ..
MicroSoft Communications Control, version 6
mscomm32.ocx
Select this control and place your cursor on the user form, click the left button and the control will be placed on the screen. 
rajoute un icone telephone dans là boite à outils

=============================
Dim Status_Com As Integer
Dim Speed As Integer

Private Sub BP_Open_Com_Click()
 On Error Resume Next    'Error handler
    If MSComm1.PortOpen = False Then  'check if the serial port is open
        MSComm1.PortOpen = True       'check if the serial port is open
    End If
    If Err Then
    MsgBox Error$, 48     'Display error in message box
    Else
    MsgBox "Port COM" + Chr$(MSComm1.CommPort + 48) + " ouvert : " + MSComm1.Settings
    Status_Com = 1
    BP_Open_Com.BackColor = &HC0FFC0
    End If
    
   


End Sub


Private Sub BP_Send_Msg_Click()
Dim A$, B$
Dim L As Integer
If (Status_Com = 1) Then
 A$ = TextBox1 + Chr$(13)
 L = Len(A$)
 B$ = Str$(L)
 If (L > 1) Then
     MSComm1.Output = A$
     MsgBox "Envoi de " + B$ + " bytes"
    Else
     MsgBox "Message vide ! ou Com non dispo."
     End If
 Else
    BP_Send_Msg.BackColor = &HFF&
    MsgBox "Port Com not Open !"
 End If
   BP_Send_Msg.BackColor = 12632256
End Sub

Private Sub BP_Close_COM_Click()
 ' On Error Resume Next    'Error handler
    If MSComm1.PortOpen = True Then    'check if the serial port is open
        MSComm1.PortOpen = False       'close the serial port
        Status_Com = 0
    BP_Open_Com.BackColor = 12632256
    End If
    If Err Then MsgBox Error$, 48     'Display error in message box
End Sub




Private Sub ComboBox1_Change()
On Error Resume Next    'Error handler
 MSComm1.PortOpen = False
MSComm1.Settings = Combox1.Text + ",N,8,1"
End Sub

Private Sub SpinButton1_Change()
MSComm1.CommPort = Str$(SpinButton1.Value)
TextBox2.Text = Str$(SpinButton1.Value)
End Sub



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


https://www.pencomdesign.com/technical-support/vba-software-example/vba-serial-driver/
NETcomm OCX Driver  - 
This driver is a replacement for the mscomm32.ocx with some small differences.
  You may view the information on the driver, author and setup information, by following the link above. 
for WIN7
 Win 7 NETcomm driver setup program
 NetcommW7.zip
 
Windows API Calls -  Instead of a driver this code uses calls to the Windows API and eliminates the need for a OCX driver.    
CommIO.zip
ou may directly download the API serial I/O software,
 it's a 7K zip file.  
 Please note, for this demonstration we only need the CommIO.bas source code 
 to use in this demo.
 
 
 

================================================================
  TOUR DE FRANCE
12/07/2017
voir TDF_2017.xls

via internet
http://www.letour.fr/le-tour/2017/fr/classements.html
selectionner ETAPE
-choisir l'etape xx concernée 
- l'etape
s'affiche "Classements à l'issue de l'etape XX"
- Suite
 pour voir tous les coureurs 
-selectionner en dessous de RANG 
 1 ... jusqu'au dernier classement .. en fin de ligne 
 passe en surligné
 click droit : COPIER
------------------
Excel
TDF_2017 est ouvert 
contient 2 macros
voir _Velo2017_Macro_170712.bas

La feuile est deja preparée pour recevoir uniquement les donnees de l'etape 
positionner la souris en B5 ,juste en dessous de RANG 
 => click droit COLLER
 Outils 
   Macro
	Macros :	Arrange
		enleve les retours à la ligne des cellules 
		et met les bonnes largeurs de colonnes

Dans la feuille nommée "BASE"
SELECTIONNER LE NUMERO de l'etape avec les fleches + ou - (de la toupie)
Outils 
   Macro
		Macros :    Surlignes_Francais
					passe en gras et surligne en vert , tous les Francais
					passe en gras et surligne en Jaune , les favoris du tour
					
La feuille ETAPE_XX ainsi selectionnée se rafraichit et montre 
les Francais sur fond VERT et les Favoris sur fond JAUNE					
			
					
Nota:
La mise en page est exactement celle de la page HTML recupére sur
http://www.letour.fr/le-tour/2017/fr/classements.html 
Liste de nom (excel)
Listes		
Coureurs_F	='Les Etapes'!$H$12:$H$51	
Dossard_F	='Les Etapes'!$I$12:$I$51	
Tous_Les_Coureurs	=Etape_01!$B$5:$E$200	
et sur feuille Base
liste des dossard Francais				B5:C43
Liste des dossard Favoris/ vedettes		I5:J18
Parcours et profil dans chaque feuille d'Etape
Le nom de la feuille doit etre Etape_xx      xx = 01 à 21			
en A1 : Numero de l'etape
en C1 : formule : =NBVAL(C5:C200)    affiche le nb de coureurs en licence
en D1 : resultat du calcul Macro tri des francais : Affiche le nb de francais dans les 30 premiers 	
en A3 : le nom de l'etape (ville de depart et ville d'arrivée)	
en C2 : le Nb de Kms de l'etape

				

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

10/08/2014
reinstallation Excel 97 Office CD BASF rouge
sur PC ASUS CM6431  WIN8 .. WIN10.1
====================
22 oct 2014
Probleme avec Macro de Budget_1410.xls
Impossuble d'activer la Macro
meme avec pwd : PF
dans programmes files/Microsoftoffice
click droit
proprietes
autoriser .. de partout
voir capture ecran

22/07/2014
Excel problem ...  A$=str$(i) ne marche plus !!!
iocomp analog pack
http://www.iocomp.com/Downloads/Evaluations.aspx
Rechargement des Activex IoComp resout le probleme !
IocompComponentsEV406SP3-ActiveX.exe

========



=========================================================================
Temperature_Precipitation_2014_2008.xls

Private Sub Arrangement_Prevision_3j_Laboisse_Cde1_Click()
   Range("A5").Select
    Selection.ClearContents
    Selection.Delete Shift:=xlToLeft
    Range("A13").Select
    Selection.Delete Shift:=xlToLeft
    Range("A22").Select
    Selection.Delete Shift:=xlToLeft
    Range("A31").Select
    Selection.Delete Shift:=xlToLeft
    Range("A5:A35").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .ShrinkToFit = False
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .ShrinkToFit = False
        .MergeCells = False
    End With
    Range("F5:F35").Select
    Selection.Replace What:="mm", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
    Selection.Replace What:="--", Replacement:="0,0", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
      Selection.Replace What:=".", Replacement:=",", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .ShrinkToFit = False
        .MergeCells = False
    End With
    Range("J5").Select
End Sub

Private Sub CommandButton1_Click()
Call Arange_Prevision_3j
End Sub

Private Sub Radar_Pluies_Click()
' rev 10/08/2014
Dim a$, B$, C$, D$
a$ = "http://www.infoclimat.fr/cartes/observations-meteo/archives/radar-precipitations/"
D$ = "h/carte-zoomable.html#9/45.9222892/5.119629"
Range("H24").Select
B$ = ActiveCell.Value
a$ = a$ + B$ + "/"
Range("H23").Select
B$ = ActiveCell.Value
a$ = a$ + B$ + "/2014/"
Range("H25").Select
B$ = ActiveCell.Value
If Len(B$) < 2 Then B$ = "0" + B$
URL = a$ + B$ + D$
Range("G26").Select
ActiveCell.Value = URL
Range("G26").Select
Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
Application.WindowState = xlNormal
Range("G17").Select
End Sub


==============================================================
Ressortir l'ascii du fichier Mikroc *.IHEX

Option Explicit

Private Sub CommandButton1_Click()
Call Extirpe_ascii_eeprom
End Sub

Option Explicit

Dim i, j, k, l, M As Integer
Dim a$, b$, c$, D$, E$, F$

Sub Extirpe_ascii_eeprom()

    Sheets("Feuil1").Select
    Range("A1:A18").Select
    Selection.Copy
    Sheets("EEPROM_list").Select
    Range("A1").Select
    ActiveSheet.Paste
    Range("A23").Select


D$ = ""
j = 0
For k = 2 To 17
a$ = Trim(Str(k))
Range("B" & a$).Select
b$ = ActiveCell.Value
'Debug.Print a$, b$,
E$ = ""
M = (k - 2) * 16
For i = 1 To 31

c$ = Mid$(b$, i, 2)
If (c$ = "FF") Then
    D$ = ". "
    i = i + 1
  '  Exit For
Else
  If (c$ <> "00") Then
    l = Hex2Dec(c$)
    If (l < 20) Then
    If l = 13 Then D$ = "<CR>"
    If l = 10 Then D$ = "<LF>"
    If l < 10 Then D$ = "."
   Else
     D$ = Chr$(l)
   End If
   i = i + 1
Else
    D$ = "0"
End If

End If
' Debug.Print D$;
 E$ = E$ + D$
Next i
'Debug.Print E$
Range("C" & a$).Select
ActiveCell.FormulaR1C1 = M
Range("D" & a$).Select
ActiveCell.FormulaR1C1 = E$



Next k
End Sub


Function Hex2Dec(strHex As String) As Variant
' Convertit une chaîne en hexadécimal en une valeur décimale.
' Fourchette des entrées valides de "0" à "FFFFFFFF" (4'294'967'295)
' Pour les nombres > que FFFFFFF (268'435'455)on doit convertir
' le nombre négatif en nombre de type Long non signé.
' A cet effet, on ajoute 2^32 (4294967296#) au résultat
  Dim varResultat As Variant
  Const Correction = 4294967296#
  On Error GoTo TraitementErreur
  varResultat = CDec("&H" & strHex)
  If varResultat > 0 Then
     Hex2Dec = varResultat
  Else
     Hex2Dec = CDec(Correction + varResultat)
  End If
Fin:
  Exit Function
TraitementErreur:
  If Err.Number = 6 Then
     MsgBox "Dépassement de capacité, le nombre maximum est FFFFFFFF", vbCritical, "Erreur de conversion Hex / Dec"
     Resume Fin
  End If
End Function





==========================================================
_Velo_2014.xls
Macro tri 
Private Sub CommandButton2_Click()
' Macro enregistrée le 30/10/2011 par Paul
Dim A$, B$, R$
  Windows("_Velo_2014.xls").Activate
   Sheets("Kms 2014").Select
  NSV = Range("E57").Value
    R$ = "R" & Trim$(Str$(NSV + 1))
    B$ = "=SERIES('Kms 2014'!R1C17,,'Kms 2014'!R2C17:" 'R51C17,2)"
  A$ = B$ & R$ & "C17,2)"
   Debug.Print "R$="; R$
   Debug.Print "A$="; A$
   ActiveSheet.ChartObjects("Graphique 10").Activate
' ActiveSheet.ChartObjects("Graphique 4").Activate
    ActiveChart.PlotArea.Select
    ActiveChart.SeriesCollection(2).Select
    DoEvents
    ActiveChart.SeriesCollection(2).Formula = A$ '_
       DoEvents
  ActiveChart.Walls.Select
    
    ActiveChart.SeriesCollection(3).Select
     B$ = "=SERIES('Kms 2014'!R1C4,,'Kms 2014'!R2C4:"
    A$ = B$ & R$ & "C4,3)"
       Debug.Print "R$="; R$
   Debug.Print "A$="; A$
    ActiveChart.SeriesCollection(3).Formula = A$ ' _
     '   "=SERIES('Kms 2011'!R1C4,,'Kms 2011'!R2C4:R51C4,3)"
     
    ActiveChart.SeriesCollection(1).Select
    B$ = "=SERIES('Kms 2014'!R1C3,,'Kms 2014'!R2C3:"
    A$ = B$ & R$ & "C3,1)"
       Debug.Print "R$="; R$
   Debug.Print "A$="; A$
    ActiveChart.SeriesCollection(1).Formula = A$ ' _
     '   "=SERIES('Kms 2011'!R1C3,,'Kms 2011'!R2C3:R51C3,1)"
  
    ActiveWindow.Visible = False
    Windows("_Velo_2014.xls").Activate
     Range("E58").Select
End Sub

Private Sub CommandButton1_Click()
 Dim i, k, App As Integer
 Dim KmsVTT, NbkmsVTT, NbkmsR, KmsApp, NbkmsApp As Single
 Dim A$, B$
 NbkmsVTT = 0
 App = 0
 k = 0
 Windows("_Velo_2014.xls").Activate
 Sheets("Kms 2014").Select
 NSV = Range("E57").Value
 For i = 2 To NSV + 1
  A$ = "C" & Trim$(Str$(i))
  B$ = "A" & Trim$(Str$(i))
  Debug.Print B$
  Range(B$).Select
  If (ActiveCell.Value = "V") Then
    k = k + 1
     Debug.Print k
    Range(A$).Select
    KmsVTT = ActiveCell.Value
    NbkmsVTT = NbkmsVTT + KmsVTT
  End If
  Range(B$).Select
  If (ActiveCell.Value = "A") Then
    App = App + 1
    Debug.Print App
    Range(A$).Select
    KmsApp = ActiveCell.Value
    NbkmsApp = NbkmsApp + KmsApp
  End If
 Next i
  
 Range("I57").Select
 ActiveCell.Value = NbkmsVTT
 Range("F57").Select
 ActiveCell.Value = k
   
 Range("I59").Select
 ActiveCell.Value = NbkmsApp
   Range("F59").Select
 ActiveCell.Value = App

 Range("F58").Select
 ActiveCell.Value = NSV - k - App
 NbkmsR = Range("C57").Value - NbkmsVTT - NbkmsApp
 Range("I58").Select
 ActiveCell.Value = NbkmsR

 NSV = Range("E57").Value
 Range("E57").Select
End Sub



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

sereine.xls

Private Sub Button_Every_1hr_Click()
Dim j As Integer
Dim T1 As Variant

For j = 0 To 10
Debug.Print Date, Time,
'Debug.Print Time + 0.042  ' Time + 1heure
'T1 = Time + 0.0001  '=> 9 secondes
'T1 = Time + 0.00001 ' => 1 seconde
T1 = Time + 0.042  '=> 1heure
While Time < T1
DoEvents
Wend
Debug.Print j, Time
j = j
Call Lit_page_web_Click
Next j
End Sub

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



http://mypage.bluewin.ch/w.stucki/Programmes.htm
Bibliothèque de programmes de calcul
Cette bibliothèque, que l'on stockera par exemple sous le nom de LibMath.mda, comprend les modules
suivants: Aire et Volume 
Manipulation de Nombres 
Math Complexe 
Trigonométrie 
Statistiques 
Manipulation de chaînes de caractères 
Calculs de Dates et de Temps 
Tri à bulles 
Programme de gestion des bibliothèques de procédures 
Lister les procédures des objets d'une Bdd 
Retour à Trucs et Astuces de MS-Access 
 

Aire et Volume
Option Compare Database 
Option Explicit 
' Compilé et testé par Walter Stucki Network Computing International, AT&T, SperryUNIVAC 

Function ACercle(Rayon As Double) As Double
' Aire d'un cercle à partir du rayon
' Utilise PI() du module de Trigonométrie
  ACercle = Rayon * Rayon * PI()
End Function

Function ARect(L As Double, w As Double) As Double
' Aire d'un rectangle
  ARect = L * w
End Function

Function ARing(RayonInterne As Double, RayonExterne As Double) As Double
' Aire d'un anneau définit à partir de 2 rayons
  ARing = ACercle(RayonExterne) - ACercle(RayonInterne)
End Function

Function ASphere(R As Double) As Double
' Aire d'une sphère à partir du rayon
  ASphere = 4 * PI() * R * R
End Function

Function ACarré(Côté As Double) As Double
' Aire du carré en fonction du côté
  ACarré = Côté * Côté
End Function

Function ACarré2(Diag As Double) As Double
  ACarré2 = Diag * Diag / 2
<' Aire du carré en fonction de la diagonale P>
End Function

Function ATrap(H As Double, L1 As Double, L2 As Double)
' Aire du Trapèze à partir de la longueur des côtés parallèles
' et de la hauteur perpendiculaire
  ATrap = H * (L1 + L2) / 2
End Function

Function ATriangle(L As Double, H As Double) As Double
' Aire du triangle à partir de la longueur d'un côté et de la hauteur perpendiculaire
  ATriangle = L * H / 2
End Function

Function ATriangle2(A As Double, B As Double, C As Double) As Double
' Aire du triangle à partir de la longueur des 3 côtés
Dim CosC As Double
  CosC = (A * A + B * B - C * C) / (2 * A * B)
  ATriangle2 = A * B * Sqr(1 - CosC * CosC) / 2
End Function

Function RectDiag(w As Double, L As Double) As Double
' Longueur de la diagonale d'un rectangle en fonction des 2 côtés
  RectDiag = Sqr(w * w + L * L)
End Function

Function SquareDiag(L As Double) As Double
' Longueur de la diagonale d'un carré de côté L
  SquareDiag = L * Sqr(2)
End Function

Function VCone(H As Double, R As Double) As Double
' Volume d'un cône en fonction du rayon de sa base et de sa hauteur
  VCone = H * R * R * PI() / 3
End Function

Function VCylindre(H As Double, R As Double) As Double
' Volume d'un Cylindre en fonction de sa hauteur et du rayon
' Utilise PI() du module Trigonométrie
  VCylindre = PI() * R * R * H
End Function

Function VTuyau(H As Double, RayonExterne As Double, RayonInterne As Double) As Double
' Volume d'un Tuyau en soustrayant 2 cylindres
  VTuyau = VCylindre(H, RayonExterne) - VCylindre(H, RayonInterne)
End Function

Function VPyramide(H As Double, AireBase As Double) As Double
' Volume d'une pyramide ou d'un cône en fonction de l'aire de sa base et de sa hauteur
  VPyramide = H * AireBase / 3
End Function

Function VSphere(R As Double) As Double
' Volume d'une sphère en fonction de son rayon
  VSphere = PI() * R * R * R * 4 / 3
End Function

Function VPyramideTronc(H As Double, AireBase1 As Double, AireBase2 As Double) As Double
' Volume d'une pyramide tronquée en fonction de sa hauteur, de l'aire de sa base et celle de son
sommet
  VPyramideTronc = H * (AireBase1 + AireBase2 + Sqr(AireBase1) * Sqr(AireBase2)) / 3
End Function

Haut du document Trucs et Astuces MS-Access 

Manipulation Nombres 

Option Compare Database ' 
Option Explicit 
' compilé et testé par Walter Stucki Network Computing International, AT&T, Sperry Univac 

Public Function MontantEnLettre(Montant) As String
' Objectif: convertir des montants en lettre selon les règles orthographiques en vigueur
' en Suisse romande. Par exemple pour un chèque bancaire
' Version valable pour un maximum de 999'999'999.99
Dim varnum, varnumD, varnumU, varlet, résultat, bytcent As Byte
'varnum : pour stocker les parties du nombre que l'on va découper
'varlet : pour stocker la conversion en lettres d'une partie du nombre
'varnumD: pour stocker la partie dizaine d'un nombre à 2 chiffres
'varnumU: pour stocker la partie unité d'un nombre à 2 chiffres
'résultat: pour stocker les résultats intermédiaires des différentes étapes
Static chiffre(1 To 19) '*** tableau contenant le nom des 19 premiers
'nombres en lettres
chiffre(1) = "un"
chiffre(2) = "deux"
chiffre(3) = "trois"
chiffre(4) = "quatre"
chiffre(5) = "cinq"
chiffre(6) = "six"
chiffre(7) = "sept"
chiffre(8) = "huit"
chiffre(9) = "neuf"
chiffre(10) = "dix"
chiffre(11) = "onze"
chiffre(12) = "douze"
chiffre(13) = "treize"
chiffre(14) = "quatorze"
chiffre(15) = "quinze"
chiffre(16) = "seize"
chiffre(17) = "dix-sept"
chiffre(18) = "dix-huit"
chiffre(19) = "dix-neuf"
Static dizaine(1 To 9) '*** tableau contenant les noms des dizaines
dizaine(1) = "dix"
dizaine(2) = "vingt"
dizaine(3) = "trente"
dizaine(4) = "quarante"
dizaine(5) = "cinquante"
dizaine(6) = "soixante"
dizaine(7) = "septante"
dizaine(8) = "huitante"
dizaine(9) = "nonante"

'*** Le traitement des milliards n'est pas pris en compte
If Montant > 999999999.99 Then
   MsgBox "Les milliards ne sont pas traités par ce programme @ @", vbCritical, "Conversion
Montant en Lettres"
   Exit Function
End If

'*** Traitement du cas zéro
If Montant >= 1 Then
   résultat = ""
Else
   résultat = "zéro"
GoTo FinTraitement
End If

'*** Traitement des millions
varnum = Int(Montant / 1000000)
If varnum > 0 Then
   GoSub CentaineDizaine
   résultat = varlet + " million"
   If varlet <> "un" Then résultat = résultat + "s"
End If

'*** Traitement des milliers
varnum = Int(Montant) Mod 1000000
varnum = Int(varnum / 1000)
If varnum > 0 Then
   GoSub CentaineDizaine
   If varlet <> "un" Then
      résultat = résultat + " " + varlet
      résultat = résultat & " mille"
   Else
      résultat = "mille"
   End If
End If

'*** Traitement des centaines et dizaines
varnum = Int(Montant) Mod 1000
If varnum > 0 Then
   GoSub CentaineDizaine
   résultat = résultat + " " + varlet
End If
résultat = LTrim(résultat)
varlet = Right$(résultat, 4)
'*** Traitement du "s" final pour mille, cent et du "de" pour million
Select Case varlet
   Case "ille"
      If Montant <> 1000 Then résultat = résultat + "s"
    Case "cent"
        If bytcent <> 1 Then résultat = résultat + "s"
    Case "lion", "ions"
      résultat = résultat + " de"
End Select

FinTraitement:
'*** Indication du terme Franc
   résultat = résultat + " Franc"
   If Montant >= 2 Then résultat = résultat + "s"
'*** Traitement des centimes
   varnum = Int((Montant - Int(Montant)) * 100 + 0.5) '*** On additionne 0,5 afin de compenser
                                                      '*** les erreurs de calcul dues aux arrondis
   If varnum > 0 Then
      GoSub CentaineDizaine
      résultat = résultat + " et " + varlet + " centime"
      If varnum > 1 Then résultat = résultat + "s"
   End If
'*** Conversion 1ère lettre en majuscule
   résultat = UCase(Left(résultat, 1)) + Right(résultat, Len(résultat) - 1)
'*** Renvoie du résultat de la fonction et fin de la fonction
   MontantEnLettre = résultat
Exit Function
CentaineDizaine:
   varlet = ""
'*** Traitement des centaines
   If varnum >= 100 Then
      varlet = chiffre(Int(varnum / 100))
      varnum = varnum Mod 100
      If varlet = "un" Then
         varlet = "cent "
         bytcent = 1
      Else
         varlet = varlet + " cent "
      End If
   End If
'*** Traitement des dizaines
   If varnum <= 19 Then '*** Cas où la dizaine est <20
      If varnum > 0 Then
         varlet = varlet + chiffre(varnum)
      End If
   Else
      varnumD = Int(varnum / 10) '*** chiffre des dizaines
      varnumU = varnum Mod 10 '*** chiffre des unités
'*** génération des dizaines en lettres
      varlet = varlet + dizaine(varnumD)
'*** traitement du séparateur des dizaines et unités
      If varnumU = 1 Then
         varlet = varlet + " et "
      Else
         If varnumU <> 0 Then
            varlet = varlet + "-"
         End If
      End If
   End If
'*** génération des unités
   If varnumU <> 0 Then
      varlet = varlet + chiffre(varnumU)
   End If
'*** Suppression des espaces à gauche et retour
   varlet = RTrim(varlet)
   Return
End Function

Sub ArrayBitFlip(A() As Long, N As Integer)
' Inverse le bit N dans le tableau A() - suppose 32 bits par élément
' Retourne A() inchangé si N est invalide

Dim Element As Integer
  Element = N \ 32 + LBound(A)
  If Element <= UBound(A) And N >= 0 Then BitFlip A(Element), N Mod 32
End Sub

Sub ArrayBitReset(A() As Long, N As Integer)
' Repositionne le bit N dans le tableau A() - suppose 32 bits par élément
' Retourne A() inchangé si N est invalide
Dim Element As Integer
  Element = N \ 32 + LBound(A)
  If Element <= UBound(A) And N >= 0 Then BitReset A(Element), N Mod 32
End Sub

Sub ArrayBitSet(A() As Long, N As Integer)
' Positionne le bit N dans le tableau A() - suppose 32 bits par élément
' Retourne A() inchangé si N est invalide
Dim Element As Integer
  Element = N \ 32 + LBound(A)
  If Element <= UBound(A) And N >= 0 Then BitSet A(Element), N Mod 32
End Sub

Function ArrayBitTest(A() As Long, N As Integer) As Integer
' Positionne le bit N dans le tableau A() - suppose 32 bits par élément
' Retourne A() inchangé si N est invalide

Dim Element As Integer
  Element = N \ 32 + LBound(A)
  If Element <= UBound(A) And N >= 0 Then
    ArrayBitTest = BitTest(A(Element), N Mod 32)
  Else
    ArrayBitTest = False
  End If
End Function

Sub BitFlip(X As Long, N As Integer)
' Inverse le bit N dans X
' Retourne X inchangé N est invalide
Dim Mask As Long
  Mask = BitMask(N)
' 2 méthodes
' X = IIf(X And Mask, X And Not Mask, X Or Mask)
  X = X And Not Mask Or (X And Not Mask Or Mask And Not X) And Mask
End Sub

Function BitMask(N As Integer) As Long
' Retourne un Masque qui peut être utilisé pour positionner un bit.
' Retourne 0 si N est hors de la fourchette  0..31.  Ceci cause
' les fonctions dépendantes à retourner les données inchangées.
Dim i As Integer, Mask As Long
  If N < 0 Or N > 31 Then
    BitMask = 0
    Exit Function
  End If
  If N = 31 Then
    BitMask = -1
  Else
    Mask = 1
    For i = 1 To N
      Mask = Mask + Mask
    Next i
    BitMask = Mask
  End If
End Function

Sub BitReset(X As Long, N As Integer)
' Repositionne le bit N dans X
' Retourne X inchangé si N est invalide
  X = X And Not BitMask(N)
End Sub

Sub BitSet(X As Long, N As Integer)
' Positionne le bit N dans X
' Retourne X inchangé si N est invalide
  X = X Or BitMask(N)
End Sub

Function BitTest(X As Long, N As Integer) As Integer
' Teste le bit N dans X - retourne True ou False
' Retourne False si N est invalide
  BitTest = (X And BitMask(N)) <> 0
End Function

Function Ceiling(N, ByVal Precision)
' Similaire à la fonction Ceiling d'Excel (plafond)
' Arrondi au niveau de précision supérieur.
' Precision ne peut pas être 0.
Dim Temp As Double
  Precision = Abs(Precision)
  Temp = Int(N / Precision) * Precision
  If Temp = N Then
    Ceiling = N
  Else
    Ceiling = Temp + Precision * Sgn(Temp)
  End If
End Function

Function DecToHex(ByVal X As Double) As String
' Conversion Décimal à Hexadécimal
Dim Result As String, i As Integer, Temp As Integer
  Result = Hex(Int(X)) & "."
  X = X - Int(X)
  For i = 1 To 16
    X = X * 16
    Result = Result & Hex(X)
    X = X - Int(X)
  Next i
  DecToHex = Result
End Function

Function Floor(N, ByVal Precision)
' Similaire à la fonction Floor (plancher) d'Excel.
' Arrondi au niveau de précision inférieur
' Precision ne peut pas être 0.
  Precision = Abs(Precision)
  Floor = Int(N / Precision) * Precision
End Function

Function Frac2Num(X)
' Analyse une fraction standard de format "a/b" ou "a b/c" et retourne un nombre.
' par exemple "2/5" ou "3 1/2" sont des entrées valides.
Dim Temp As String, P As Integer, N As Double, Num As Double, Den As Double
  If VarType(X) < 2 Or VarType(X) = 7 Then
    Frac2Num = Null
  ElseIf VarType(X) <> 8 Then
    Frac2Num = X
  Else
    Temp = Trim$(X)
    P = InStr(Temp, " ")
    If P = 0 Then
      If InStr(Temp, "/") = 0 Then
        N = Val(Temp)
      Else
        N = 0
      End If
    Else
      N = Val(Left$(Temp, P - 1))
      Temp = Mid$(Temp, P + 1)
    End If
    P = InStr(Temp, "/")
    If P <> 0 Then
      Num = Val(Left$(Temp, P - 1))
      Den = Val(Mid$(Temp, P + 1))
      If Den <> 0 Then
        N = N + Num / Den
      End If
    End If
    Frac2Num = N
  End If
End Function

Function GCF(ByVal X As Long, ByVal Y As Long) As Long
' Retourne le plus grand dénominateur commun
' soit le plus grand nombre divisible par X et Y
Dim Temp As Long
  X = Abs(X)        ' rend les 2 nombres positifs
  Y = Abs(Y)
  Temp = X Mod Y
  Do While Temp > 0
    X = Y
    Y = Temp
    Temp = X Mod Y
  Loop
  GCF = Y
End Function

Function Hex2Dec(strHex As String) As Variant
' Convertit une chaîne en hexadécimal en une valeur décimale.
' Fourchette des entrées valides de "0" à "FFFFFFFF" (4'294'967'295)
' Pour les nombres > que FFFFFFF (268'435'455)on doit convertir 
' le nombre négatif en nombre de type Long non signé.
' A cet effet, on ajoute 2^32 (4294967296#) au résultat
  Dim varResultat As Variant
  Const Correction = 4294967296#
  On Error GoTo TraitementErreur
  varResultat = CDec("&H" & strHex)
  If varResultat > 0 Then
     Hex2Dec = varResultat
  Else
     Hex2Dec = CDec(Correction + varResultat)
  End If
Fin:
  Exit Function

TraitementErreur:
  If Err.Number = 6 Then
     MsgBox "Dépassement de capacité, le nombre maximum est FFFFFFFF", vbCritical, "Erreur de
conversion Hex / Dec"
     Resume Fin
  End If
End Function

Function IsPrime(ByVal X As Long) As Integer
' Retourne TRUE si le nombre est un nombre premier.
' Traite les nombres négatifs comme des nombres positifs,
' ainsi -3 et 3 retournent TRUE.
Dim i As Integer, A As Double
  IsPrime = True
  X = Abs(X)                                  ' Ignore le signe
  If X = 0 Or X = 1 Then                      ' Cas spécial pour 0 et 1
    IsPrime = False
  ElseIf X = 2 Then                           ' Cas spécial pour 2 (le seul nombre pair à être
premier)
  ElseIf (X And 1) = 0 Then                   ' Special case all other even numbers (not prime)
    IsPrime = False
  Else                                        ' Itération seulement dans les nombres impairs
    For i = 3 To Int(Sqr(X)) Step 2
      A = X / i
      If A = X \ i Then
        IsPrime = False
        Exit Function
      End If
    Next i
  End If
End Function

Function LCM(ByVal X As Integer, ByVal Y As Integer) As Long
' Retourne le plus petit commun multiple
' soit le plus petit nombre pour lequel X et Y sont des facteurs
Dim Temp As Long
  X = Abs(X)        ' Rend les nombres positifs
  Y = Abs(Y)
  LCM = Y * (X \ GCF(X, Y))
End Function

Function Log10(X As Double) As Double
' Log base 10
  Log10 = Log(X) / Log(10)
End Function

Function Log2(X As Double) As Double
' Log base 2
  Log2 = Log(X) / Log(2)
End Function

Function LogN(X As Double, N As Double) As Double
' Log base N
  LogN = Log(X) / Log(N)
End Function

Function Max2(A As Variant, B As Variant) As Variant
' Retourne la plus grande de 2 valeurs
  Max2 = IIf(A > B, A, B)
End Function

Function Max3(A As Variant, B As Variant, C As Variant) As Variant
' Retourne la plus grande de 3 valeurs
  If A > B Then Max3 = Max2(A, C) Else Max3 = Max2(B, C)
End Function

Function Min2(A As Variant, B As Variant) As Variant
' Retourne la plus petite de 2 valeurs
  Min2 = IIf(A < B, A, B)
End Function

Function Min3(A As Variant, B As Variant, C As Variant) As Variant
' Retourne la plus petite de 3 valeurs
  If A < B Then Min3 = Min2(A, C) Else Min3 = Min2(B, C)
End Function

Function Num2Frac(X)
' Convertit un nombre décimal en une fraction normalisée et détermine
' automatiquement un dénominateur entre 2 and 8.
Dim Temp As String, Fixed As Double
  If (VarType(X) < 2) Or (VarType(X) > 6) Then
    Num2Frac = X
  Else
    X = Abs(X)
    Fixed = Int(X)
    If Fixed > 0 Then
      Temp = Str(Fixed)
    End If
    Select Case X - Fixed
      Case Is < 0.1
        If Fixed > 0 Then
          Temp = Temp
        Else
          Temp = Str(X)
        End If
      Case 0.1 To 0.145
        Temp = Temp + " 1/8"
      Case 0.145 To 0.182
        Temp = Temp + " 1/6"
      Case 0.182 To 0.225
        Temp = Temp + " 1/5"
      Case 0.225 To 0.29
        Temp = Temp + " 1/4"
      Case 0.29 To 0.35
        Temp = Temp + " 1/3"
      Case 0.35 To 0.3875
        Temp = Temp + " 3/8"
      Case 0.3875 To 0.45
        Temp = Temp + " 2/5"
      Case 0.45 To 0.55
        Temp = Temp + " 1/2"
      Case 0.55 To 0.6175
        Temp = Temp + " 3/5"
      Case 0.6175 To 0.64
        Temp = Temp + " 5/8"
      Case 0.64 To 0.7
        Temp = Temp + " 2/3"
      Case 0.7 To 0.775
        Temp = Temp + " 3/4"
      Case 0.775 To 0.8375
        Temp = Temp + " 4/5"
      Case 0.8735 To 0.91
        Temp = Temp + " 7/8"
      Case Is > 0.91
        Temp = Str(Int(X) + 1)
    End Select
    Num2Frac = Temp
  End If
End Function

Function Num2FracA(X, Dénominateur As Long)
' Convertit un nombre décimal en fraction mais ne la normalise pas.
' exemple 3 2/4 -> 3 2/4
Dim Temp As String, Fixed As Double, Numérateur As Long
  If (VarType(X) < 2) Or (VarType(X) > 6) Then
    Num2FracA = X
    Exit Function
  End If
  X = Abs(X)
  Fixed = Int(X)
  Numérateur = Int((X - Fixed) * Dénominateur + 0.5) 'Arrondi arithmétique
  If Numérateur = Dénominateur Then
    Fixed = Fixed + 1
    Numérateur = 0
  End If
  If Fixed > 0 Then
    Temp = Str(Fixed)
  End If
  If Numérateur > 0 Then
    Temp = Temp & " " & Numérateur & "/" & Dénominateur
  End If
  Num2FracA = Temp
End Function

Function Num2FracB(X, ByVal Dénominateur As Long)
' Convertit un nombre décimal en fraction et la normalise.
' exemple 3 2/4 -> 3 1/2
Dim Temp As String, Fixed As Double, Numérateur As Long, Facteur As Long
  If (VarType(X) < 2) Or (VarType(X) > 6) Then
    Num2FracB = X
    Exit Function
  End If
  X = Abs(X)
  Fixed = Int(X)
  Numérateur = Int((X - Fixed) * Dénominateur + 0.5) 'Arrondi arithmétique
  If Numérateur = Dénominateur Then
    Fixed = Fixed + 1
    Numérateur = 0
  End If
  If Fixed > 0 Then
    Temp = Str(Fixed)
  End If
  If Numérateur > 0 Then
    Facteur = GCF(Numérateur, Dénominateur)
    Temp = Temp & " " & Numérateur / Facteur & "/" & Dénominateur / Facteur
  End If
  Num2FracB = Temp
End Function

Function Num2Roman(ByVal N As Integer) As String
' Convertit un nombre décimal en nombre romain
' Entrée valide dans la fourchette 1-3999
Const Digits = "IVXLCDM"
Dim i As Integer, Digit As Integer, Temp As String
  i = 1
  Temp = ""
  Do While N > 0
    Digit = N Mod 10
    N = N \ 10
    Select Case Digit
      Case 1
        Temp = Mid(Digits, i, 1) & Temp
      Case 2
        Temp = Mid(Digits, i, 1) & Mid(Digits, i, 1) & Temp
      Case 3
        Temp = Mid(Digits, i, 1) & Mid(Digits, i, 1) & Mid(Digits, i, 1) & Temp
      Case 4
        Temp = Mid(Digits, i, 2) & Temp
      Case 5
        Temp = Mid(Digits, i + 1, 1) & Temp
      Case 6
        Temp = Mid(Digits, i + 1, 1) & Mid(Digits, i, 1) & Temp
      Case 7
        Temp = Mid(Digits, i + 1, 1) & Mid(Digits, i, 1) & Mid(Digits, i, 1) & Temp
      Case 8
        Temp = Mid(Digits, i + 1, 1) & Mid(Digits, i, 1) & Mid(Digits, i, 1) & Mid(Digits, i, 1) &
Temp
      Case 9
        Temp = Mid(Digits, i, 1) & Mid(Digits, i + 2, 1) & Temp
    End Select
    i = i + 2
  Loop
  Num2Roman = Temp
End Function

Function Oct2Dec(S As String) As Long
' Convertit un nombre Octal (base 8) en décimal. Séries 1100 et 2200 d'ordinateurs UNIVAC
' Fourchette valide de '0' à '37777777777'
  Oct2Dec = Val("&O" & S)
End Function

Function Round2(X)
' Arrondi un nombre à 2 positions décimales
' Utilise l'arrondi arithmétique
  Round2 = Int(X * 100 + 0.5) / 100
End Function

Function Round2C(X)
' Arrondi une valeur monétaire à 2 positions décimales
' Utilise l'arrondi arithmétique
  If IsNull(X) Then
    Round2C = Null
  Else
    Round2C = CCur(Int(X * 100 + 0.5) / 100)
  End If
End Function

Function Round2CB(X As Variant) As Variant
' Arrondi bancaire d'une valeur monétaire à 2 décimales.
Dim Temp As Currency, ITemp As Currency, Digit As Integer
  If IsNull(X) Then Exit Function
  Round2CB = CCur(X / 100) * 100
End Function

Function RoundN(X, N As Integer)
' Arrondi un nombre à N positions décimales
' Utilise l'arrondi arithmétique
' N doit être dans la fourchette de 0-10 pour l'obtention de résultats corrects.
Dim Facteur As Long
  Facteur = 10 ^ N
  RoundN = Int(X * Facteur + 0.5) / Facteur
End Function

Function ArrondiG(Nombre As Double, Fraction As Integer, Direction As Integer)
'Objectif: Fonction générale d'arrondi jusqu'à 9'999'999'999'999.999
'Nombre: valeur à arrondir
'Fraction: Dénominateur de la fraction utilisée pour arrondir, par exemple 100 pour arrondir à 2
décimales,
' 4 pour arrondir au 1/4, 1000 pour arrondir à 3 décimales, etc.
'Direction: 1 = arrondi au plus proche, 2 arrondi au suivant, 3 arrondi au précédent
Dim NumFrac As Double, AFrac As Double, AFrac2 As Double, NouvArrond As Double
NumFrac = Nombre - Int(Nombre)
AFrac = 1 / Fraction
NumFrac = NumFrac / AFrac
NumFrac = Int(NumFrac + 0.5)
AFrac2 = AFrac * NumFrac
NouvArrond = Int(Nombre) + AFrac2
Select Case Direction
   Case 1 'arrondi arithmétique au plus proche
      ArrondiG = NouvArrond
   Case 2 'arrondi arithmétique au suivant (plus haut)
      If NouvArrond >= Nombre Then
         ArrondiG = NouvArrond
      Else
         ArrondiG = NouvArrond + AFrac
      End If
   Case 3 'arrondi arithmétique au prédédent (plus bas)
      If NouvArrond < Nombre Then
         ArrondiG = NouvArrond
      Else
         ArrondiG = NouvArrond - AFrac
      End If
   End Select
End Function

Public Function ArrondiGlobal(ByVal Nombre As Variant, NbreDec As Long) As Double
'Objectif:  Fonction générale d'arrondi au plus proche, jusqu'à 9'999'999'999'999.999
'Arguments: Nombre = valeur à arrondir, NbreDec = nombre de décimales désirées pour le résultat
Dim dblFraction As Double, varTemp As Variant, intSgn As Integer
If Not IsNumeric(Nombre) Then
'génère une erreur indiquant que l'on a fourni un paramètre incorrect
    Err.Raise 5
End If
'Calcul de la fraction utilisée pour arrondir au nombre voulu de décimales
dblFraction = 10 ^ NbreDec
'Est-ce un nombre négatif ou positif ?
'intSgn contiendra -1, 0, ou 1
intSgn = Sgn(Nombre)
Nombre = Abs(Nombre)
'Effectue le calcul principal
varTemp = CDec(Nombre) * dblFraction + 0.5
'Termine le calcul de l'arrondi
ArrondiGlobal = intSgn * Int(varTemp) / dblFraction
End Function

Sub Sieve()
' Génère un tableau des 1000 premiers nombres Premier
' Utilise la technique d'Eratosthenes
ReDim P(1 To 1000)
Dim PCount As Integer, i As Long, J As Integer, IsPrime As Integer, X As Long
  PCount = 0
  i = 2
  Do While PCount < 1000
    IsPrime = True
    For J = 1 To PCount - 1
      X = P(J)
      If i / X = i \ X Then
        IsPrime = False
        Exit For
      End If
    Next J
    If IsPrime Then
      PCount = PCount + 1
      P(PCount) = i
      Debug.Print i;
    End If
    i = i + 1
  Loop
End Sub

Function ToBRoundInt(X As Variant) As Long
' Lit une variable de type Variant, la convertit en un nombre et l'arrondit selon la méthode
bancaire.
' Valeur Null/Non-numérique est convertie à zéro.
' Exemple n.5 arrondi au nombre pair le plus proche.
' soit 1.5 -> 2, mais 0.5 -> 0
' Les fractions inférieures à .5 sont toujours arrondies vers le bas, et les fractions
' supérieures sont toujours arrondies vers le haut.
  If Not IsNumeric(X) Then
    ToBRoundInt = 0
  Else
    ToBRoundInt = X ' Arrondi bancaire
  End If
End Function

Function ToCurr(X As Variant) As Currency
' Convertit une variable de type Variant en valeur monétaire.
' Valeur Null/non-numerique est convertie à zéro.
  If Not IsNumeric(X) Then
    ToCurr = 0
  Else
    ToCurr = X
  End If
End Function

Function ToFloat(X As Variant) As Double
' Convertit une variable de type Variant en nombre double précision.
' Valeur Null/non-numerique est convertie à zéro.
  If Not IsNumeric(X) Then
    ToFloat = 0
  Else
    ToFloat = X
  End If
End Function

Function ToInt(X As Variant) As Long
' Convertit une variable de type Variant en integer/long.
' Valeur Null/non-numerique est convertie à zéro.
  If Not IsNumeric(X) Then
    ToInt = 0
  Else
    ToInt = Int(X)   ' Tronque les décimales
  End If
End Function

Function ToRoundInt(X As Variant) As Long
' Convertit une variable de type Variant en nombre entier et l'arrondit en utilisant l'arrondi
Arithmétique.
' Valeur Null/non-numerique est convertie à zéro.
' .0-.4999... arrondi vers le bas
' .5-.9999... arrondi vers le haut
  If Not IsNumeric(X) Then
    ToRoundInt = 0
  Else
    ToRoundInt = Int(X + 0.5) ' Arrondi arithmétique
  End If
End Function

Function ToString(X As Variant) As String
' Convertit une variable de type Variant en chaîne de caractères.
' Null converti à "".
  If IsNull(X) Then
    ToString = ""
  Else
    ToString = X
  End If
End Function

Sub Texte1_AfterUpdate()
' Détermine si le nombre saisi dans la zone Texte1 est pair ou impair.
' On utilise l'opérateur And pour comparer le nombre avec 1.
Dim blnEstImpair As Boolean
blnEstImpair = CLng(Me!Texte1.Text) And 1
If blnEstImpair = True Then
   MsgBox "le nombre testé est impair @ @"
Else
   MsgBox "le nombre testé est pair @ @"
End If
End Sub
  Haut du document Trucs et Astuces MS-Access 


Math Complexe 
Option Compare Database 
Option Explicit 

' compilé et testé par Walter Stucki Network Computing International, AT&T, Sperry UNIVAC '
nécessite le module Manipulation Nombres et le module Trigonométrie

Type Complex
  i As Double
  R As Double
End Type
Type Polar
  Z As Double        ' Magnitude
  Th As Double       ' Angle Theta
End Type

Sub Complex2Polar(A As Complex, Result As Polar)
' Convertit un nombre complexe en format polaire
  Result.Z = IMMag(A)
  Result.Th = ATan2(A.R, A.i)       ' du module Trigonométrie
End Sub

Sub IMAdd(A As Complex, B As Complex, Result As Complex)
' Addition de 2 nombres complexes
  Result.i = A.i + B.i
  Result.R = A.R + B.R
End Sub

Sub IMConjugate(A As Complex, Result As Complex)
' Retourne le Conjugate de A
  Result.R = A.R
  Result.i = -A.i
End Sub

Sub IMDiv(A As Complex, B As Complex, Result As Complex)
' Divise A par B
Dim B1 As Complex
  IMInverse B, B1
  IMProduct A, B1, Result
End Sub

Sub IMExp(A As Complex, Result As Complex)
' Effectue e^A où A est un nombre complexe
Dim A1 As Complex, Z As Double
  A1 = A
  Z = Exp(A1.R)
  Result.R = Z * Cos(A1.i)
  Result.i = Z * Sin(A1.i)
End Sub

Function IMFormat(A As Complex) As String
' Formate un nombre complexe sous forme de chaîne de caractères
  If A.i >= 0 Then
    IMFormat = A.R & " + " & A.i & "i"
  Else
    IMFormat = A.R & " - " & Abs(A.i) & "i"
  End If
End Function

Sub IMInverse(A As Complex, Result As Complex)
' Calcule l'inverse de A, de manière à ce que A * Result = 1
Dim Temp As Double
  Temp = A.R * A.R + A.i * A.i
  Result.R = A.R / Temp
  Result.i = -A.i / Temp
End Sub

Sub IMln(A As Complex, Result As Complex)
' Retourne le logarithme naturel de A
Dim A1 As Complex
  A1 = A
  Result.R = Log(IMMag(A1))
  Result.i = ATan2(A1.R, A1.i)
End Sub

Sub IMLog10(A As Complex, Result As Complex)
' Calcule le Log de A  en base 10
  IMln A, Result
  IMRProduct Result, Log10(Exp(1)), Result  ' Log10 du module Manipulation Nombres
End Sub

Sub IMLog2(A As Complex, Result As Complex)
' Calcule le Log de A en base 2
  IMln A, Result
  IMRProduct Result, Log2(Exp(1)), Result   ' Log2 du module Manipulation Nombres
End Sub

Function IMMag(A As Complex) As Double
' Retourne la magnitude d'un nombre complexe
  IMMag = Sqr(A.R * A.R + A.i * A.i)
End Function

Function IMPFormat(A As Polar) As String
' Formate un nombre polaire sous forme d'une chaîne de caractères
  If A.Th >= 0 Then
    IMPFormat = A.Z & " + " & A.Th & "Th"
  Else
    IMPFormat = A.Z & " - " & Abs(A.Th) & "Th"
  End If
End Function

Sub IMPower(A As Complex, B As Complex, Result As Complex)
' A^B les deux termes étant des nombres complexes
Dim Temp1 As Complex, Temp2 As Complex
  IMln A, Temp1
  IMProduct Temp1, B, Temp2
  IMExp Temp2, Result
End Sub

Sub IMProduct(A As Complex, B As Complex, Result As Complex)
' Multiplie 2 nombres complexes
Dim A1 As Complex, B1 As Complex
  A1 = A
  B1 = B
  Result.i = A1.i * B1.R + A1.R * B1.i
  Result.R = A1.R * B1.R - A1.i * B1.i
End Sub

Sub IMRDiv(A As Complex, B As Double, Result As Complex)
' Divise A par la valeur scalaire de B
  Result.R = A.R / B
  Result.i = A.i / B
End Sub

Sub IMRPower(A As Complex, B As Double, Result As Complex)
' Effectue A^B où A est un nombre complexe et B est un nombre réel
Dim APolar As Polar
  Complex2Polar A, APolar
  APolar.Z = APolar.Z ^ B
  APolar.Th = APolar.Th * B
  Polar2Complex APolar, Result
End Sub

Sub IMRProduct(A As Complex, B As Double, Result As Complex)
' Multiplie A par la valeur scalaire de B
  Result.R = A.R * B
  Result.i = A.i * B
End Sub

Sub IMSqr(A As Complex, Result As Complex)
' Calcule la racine carrée d'un nombre complexe
Dim A1 As Polar
  Complex2Polar A, A1
  A1.Z = Sqr(A1.Z)
  A1.Th = A1.Th / 2
  Polar2Complex A1, Result
End Sub

Sub IMSub(A As Complex, B As Complex, Result As Complex)
' Soustraction de 2 nombres complexes
  Result.i = A.i - B.i
  Result.R = A.R - B.R
End Sub

Sub IMTest()
Dim A As Complex, B As Complex, C As Complex, D As Complex, E As Complex, P As Polar
  A.R = 3: A.i = 4
  B.R = 5: B.i = -3
  Debug.Print "A", IMFormat(A)
  Debug.Print "B", IMFormat(B)
  Complex2Polar A, P
  Polar2Complex P, D
  Debug.Print "A -> P -> A", IMPFormat(P), IMFormat(D)
  IMInverse A, C
  IMProduct A, C, D
  Debug.Print "Inverse A", IMFormat(C), IMFormat(D)
  IMConjugate A, C
  Debug.Print "Conjugate", IMFormat(C)
  Debug.Print "Magnitude", IMMag(A)
  IMAdd A, B, C
  IMSub C, B, D
  Debug.Print "A+B,-B", IMFormat(C), IMFormat(D)
  IMProduct A, B, C
  IMDiv C, B, D
  Debug.Print "A*B,/B", IMFormat(C), IMFormat(D)
  IMRProduct A, 5, C
  IMRDiv C, 5, D
  Debug.Print "A*5,/5", IMFormat(C), IMFormat(D)
  IMSqr A, C
  IMRPower C, 2, D
  Debug.Print "Sqr(A),^2", IMFormat(C), IMFormat(D)
  IMln A, C
  IMExp C, D
  Debug.Print "Ln A,e^", IMFormat(C), IMFormat(D)
  IMLog10 A, C
  D.R = 10: D.i = 0
  IMPower D, C, E
  Debug.Print "Log10 A,10^", IMFormat(C), IMFormat(E)
  IMLog2 A, C
  D.R = 2: D.i = 0
  IMPower D, C, E
  Debug.Print "Log2 A,2^", IMFormat(C), IMFormat(E)
  IMPower A, B, C
  IMInverse B, D
  IMPower C, D, E
  Debug.Print "A^B,^(1/B)", IMFormat(C), IMFormat(E)
End Sub

Sub Polar2Complex(A As Polar, Result As Complex)
' Convertit un format polaire en nombre complexe
  Result.R = A.Z * Cos(A.Th)
  Result.i = A.Z * Sin(A.Th)
End Sub
  Haut du document Trucs et Astuces MS-Access 

Trigonométrie 
Option Compare Database 
Option Explicit 
' compilé et testé par Walter Stucki Network Computing International 

Function ArcCos(X As Double) As Double
' Inverse du Cosinus
  If X = 1 Then
    ArcCos = 0
  ElseIf X = -1 Then
    ArcCos = -PI()
  Else
    ArcCos = Atn(X / Sqr(-X * X + 1)) + PI() / 2
  End If
End Function

Function Arccosec(X As Double) As Double
' Inverse de la Cosécante
  Arccosec = Atn(X / Sqr(X * X - 1)) + (Sgn(X) - 1) * PI() / 2
End Function

Function Arccotan(X As Double) As Double
' Inverse de la Cotangente
  Arccotan = Atn(X) + PI() / 2
End Function

Function ArcSec(X As Double) As Double
' Inverse de la Sécante
  ArcSec = Atn(X / Sqr(X * X - 1)) + Sgn(Sgn(X) - 1) * PI() / 2
End Function

Function ArcSin(X As Double) As Double
' Inverse du Sinue
  If X = 1 Then
    ArcSin = PI() / 2
  ElseIf X = -1 Then
    ArcSin = -PI() / 2
  Else
    ArcSin = Atn(X / Sqr(-X * X + 1))
  End If
End Function

Function ATan2(X As Double, Y As Double) As Double
' Retourne l'ArcTangente basé sur les coordonnées de X et Y
' Si X et Y sont tous deux à zéro une erreur se produit.
' La valeur de l'axe des X est supposée être +0, allant dans le sens positif dans la direction
' opposée aux aiguilles d'une montre, et dans le sens négatif dans le sens des aiguilles d'une
montre.
  If X = 0 Then
    If Y = 0 Then
      ATan2 = 1 / 0
    ElseIf Y > 0 Then
      ATan2 = PI() / 2
    Else
      ATan2 = -PI() / 2
    End If
  ElseIf X > 0 Then
    If Y = 0 Then
      ATan2 = 0
    Else
      ATan2 = Atn(Y / X)
    End If
  Else
    If Y = 0 Then
      ATan2 = PI()
    Else
      ATan2 = (PI() - Atn(Abs(Y) / Abs(X))) * Sgn(Y)
    End If
  End If
End Function

Function Cosec(X As Double) As Double
' Cosécante
  Cosec = 1 / Sin(X)
End Function

Function Cotan(X As Double) As Double
' Cotangente
  Cotan = 1 / Tan(X)
End Function

Function Deg2Rad(X As Double) As Double
' Conversion de degrés en radians
  Deg2Rad = X / 180 * PI()
End Function

Function HArccos(X As Double) As Double
' Inverse du Cosinus Hyperbolique
  HArccos = Log(X + Sqr(X * X - 1))
End Function

Function HArccosec(X As Double) As Double
' Inverse de la Cosécante Hyperbolique
  HArccosec = Log((Sgn(X) * Sqr(X * X + 1) + 1) / X)
End Function

Function HArccotan(X As Double) As Double
' Inverse de la Tangente Hyperbolique
  HArccotan = Log((X + 1) / (X - 1)) / 2
End Function

Function HArcsec(X As Double) As Double
' Inverse de la Sécante Hyperbolique
  HArcsec = Log((Sqr(-X * X + 1) + 1) / X)
End Function

Function HArcsin(X As Double) As Double
' Inverse du Sinus Hyperbolique
  HArcsin = Log(X + Sqr(X * X + 1))
End Function

Function HArctan(X As Double) As Double
' Inverse de la Tangente Hyperbolique
  HArctan = Log((1 + X) / (1 - X)) / 2
End Function

Function HCos(X As Double) As Double
' Cosinus Hyperbolique
  HCos = (Exp(X) + Exp(-X)) / 2
End Function

Function HCosec(X As Double) As Double
' Hyperbolic Cosecant = 1/HSin(X)
  HCosec = 2 / (Exp(X) - Exp(-X))
End Function

Function HCotan(X As Double) As Double
' Cotangente Hyperbolique = 1/HTan(X)
  HCotan = (Exp(X) + Exp(-X)) / (Exp(X) - Exp(-X))
End Function

Function HSec(X As Double) As Double
' Sécante Hyperbolique = 1/HCos(X)
  HSec = 2 / (Exp(X) + Exp(-X))
End Function

Function HSin(X As Double) As Double
' Sinus Hyperbolique
  HSin = (Exp(X) - Exp(-X)) / 2
End Function

Function HTan(X As Double) As Double
' Tangente Hyperbolique = HSin(X)/HCos(X)
  HTan = (Exp(X) - Exp(-X)) / (Exp(X) + Exp(-X))
End Function

Function PI() As Double
  PI = Atn(1) * 4
End Function

Function Rad2Deg(X As Double) As Double
' Conversion de Radians en Degrés
  Rad2Deg = X / PI() * 180
End Function

Function Sec(X As Double) As Double
' Sécante
' Attention à PI/2 et 3PI/2 radians (90 & 270 degrés)
  Sec = 1# / Cos(X)
End Function

Haut du document Trucs et Astuces MS-Access 
Programme de gestion des bibliothèques de procédures 
On crée une bdd GestionBibliothèque.mdb pour gérer une telle bibliothèque. Elle comprend une table
tblProcédures avec la structure suivante:


Nom rubrique
 Type de donnée
 Taille
 Index
 
NoFonction
 AutoNumérique
  
 Clé primaire
 
NomFonction
 Texte
 35
 Avec doublons
 
CodeVBA
 Mémo
  
  
 
MotsClé
 Mémo
  
  
 
Ensuite on a créé une requête reprenant toutes les rubriques mais en triant sur le NomFonction
pour servir de fondement au formulaire de gestion de la bibliothèque, qui permet de visualiser
toutes les rubriques de la table et de la gérer.

Ce formulaire comporte des boutons de navigation personnalisés (Premier, Précédent, Suivant,
Dernier, Ajouter) et les boutons de commande pour la gestion (Sauvegarder, Annuler, Supprimer,
Rechercher, Copier le code et Filtrer).

Une liste déroulante modifiable indépendante, cboFind, invisible de prime abord, est déroulée
automatiquement en actionnant le bouton Rechercher. Cette liste est peuplée via une requête séparée
reqRechercheProcédures. Elle liste les deux premières rubriques de la table. La 1ère étant.masquée,
l'usager obtient la liste des noms de fonctions actuellement disponibles. 

Private Sub cmdRechercher_Click()
If Me.Dirty Then
   MsgBox "Sauvegardez d'abord vos modifications.", 64, _
          "Bibliothèque des procédures"
   Exit Sub
End If
cboFind.Visible = True ' Afficher la liste déroulante modifiable
cboFind.Requery
cboFind = "" 'Initialise la liste déroulante à NULL.
cboFind.SetFocus
cboFind.Dropdown 'Déroule la liste.
End Sub
  

Private Sub cboFind_AfterUpdate()
DoCmd.Echo False ' Masquer les actions à l'écran
NoFonction.Visible = True ' Montrer la clé primaire.
NoFonction.SetFocus ' Se positionner sur la clé primaire.
DoCmd.FindRecord cboFind ' Rechercher l'enregistrement
NomFonction.SetFocus ' Se positionner sur le nom de la procédure
NoFonction.Visible = False ' Masquer la clé primaire.
cboFind = "" ' Initialiser la liste déroulante à NULL
cboFind.Visible = False ' Masquer la liste déroulante.
DoCmd.Echo True ' Visualiser les actions à l'écran
End Sub
  

Private Sub cmdCopier_Click()
  If MsgBox("Copier cette procédure vers le presse-papier ?", _
     292, "Bibliothèque des procédures") <> 6 Then Exit Sub
  DoCmd.Echo False
  CodeVBA.SetFocus
  ' copier le code VBA vers le presse-papier
  RunCommand acCmdCopy
  ' retour au bouton Copier
  cmdCopier.SetFocus
  DoCmd.Echo True
End Sub
 

Haut du document Trucs et Astuces MS-Access 

Tri à Bulles

Function TriABulles()
' Objectif: Trier en ordre décroissant les nombre contenus dans un tableau contenant un nombre
variable d'entiers
' Ce tableau sera peuplé par une requête qui y placera les montants de dons reçus.
Dim Permuté As Integer 'Indicateur de permutation, si 0 aucune permutation n'a été effectuée
Dim Temp As Integer 'Zone de travail pour autoriser la permutation de deux valeurs
Dim I As Integer 'Compteur utilisé pour gérer les boucles d'instructions répétitives
Dim TableauMontants() 'tableau de taille dynamique car on ne connaît pas le nombre de dons
Dim strSQL As String, rs As Recordset
strSQL = "SELECT DISTINCTROW Don FROM tblDons"
Set rs = CurrentDb.OpenRecordset(strSQL)
rs.MoveLast 'Pour renseigner la propriété RecordCount
rs.MoveFirst
'Redimensionne le tableau sur la base de la taille du recordset
ReDim TableauMontants(0 To rs.RecordCount - 1)
' Peuple le tableau avec les valeurs du recordset
For I = 0 To UBound(TableauMontants)
   TableauMontants(I) = rs!Don
   rs.MoveNext
Next I
' Effectue le tri à bulles décroissant
Do
   Permuté = 0
   For I = 0 To UBound(TableauMontants) - 1
' Comparaison entre deux éléments successifs pour savoir lequel est le plus plus grand
      If TableauMontants(I) < TableauMontants(I + 1) Then<>
         ' Le plus grand est placé devant par permutation
         Temp = TableauMontants(I)
         TableauMontants(I) = TableauMontants(I + 1)
         TableauMontants(I + 1) = Temp
         Permuté = 1 'Indicateur indique que la permutation a été effectuée
      End If
   Next I
Loop While Permuté = 1
' Quand plus aucune permutation n'est effectuée, le tableau est trié
' Présentation du résultat
For I = 0 To UBound(TableauMontants)
   Debug.Print TableauMontants(I)
Next I
End Function
Haut du document Trucs et Astuces MS-Access 

Lister les procédures de code des objets de la Bdd

Une bibliothèque de programmes contient les fonctions et les procédures des modules standards et
des modules de classe indépendants de plusieurs bases de données, ce qui permet à l'administrateur
de localiser rapidement le code qui pourrait être réutilisé dans une application.

Le listage des procédures de code des objets (modules standards, modules de classe indépendants,
modules de formulaire et d'états) d'une Bdd permet surtout de faciliter l'entretien d'une
application dont la complexité augmente avec sa durée de vie au vu des changements nécessités par
l'évolution des affaires. D'autre part, il arrive souvent que plusieurs développeurs ont contribués
à la réalisation de la version initiale et des modifications ultérieures.

Le module standard ci-après est une contribution de Laurent Moilneu.

'// I M P O R T A N T :
'// --------------------------
'// Ce code fonctionne à partir de la version Access 2000 car on utilise le VBE
'// Activez la référence à la bilbiothèque :
'// 'Microsoft Visual Basic for Application Extensibility 5.x'
'//

'//----()---()---()- DECLARATION DES VARIABLES ()---()---()---()---()---()-\\
'//
Private Const ERR_mdl As String = "MD_ManipModule"
Private Const C_cl As String = "_"

Private moCdMo As CodeModule
Private msProjet As String '// Nom du projet de la Bdd.
'//
'//----()---()---()---()---()---()---()---()---()---()---()---()---()---()-\\

Public Function gfn_ScanObjet(sObj As String) As Byte
'//----o----o----o---Procedure header sample---o----o----o----o----o----o--\\
'//
'// Procédure : gfn_ScanObjet
'// Auteur : Laurent Moilneu
'// Date : 07/08/2001 11:11:10
'// Modif :
'// Objectif : Obtenir le contenu du code de l'objet indiqué.
'//
'// ENTREE <-
'// sObj : Nom de l'objet à utiliser(module, formulaire ou état).
'//
'// SORTIE ->
'// 1 si l'exécution s'est déroulée correctement.
'//
'//
'//----o----o----o----o----o----o----o----o----o----o----o----o----o----o--\\
On Error GoTo ERR_ScanObjet

Const ERR_proc As String = "gfn_ScanObjet"
Dim prg As VBProject
Dim iIDVbc As Integer
Dim sTMp As String

'// Obtenir le nom du projet de la Bdd.
sTMp = CurrentProject.FullName
For Each prg In VBE.VBProjects

If prg.FileName = sTMp Then
msProjet = prg.Name
End If
Next prg
Set prg = Nothing

'// Obtenir l'identificateur du composant Visual Basic de l'objet.
iIDVbc = fn_ObtenirIDVbComp(sObj) '// |--->

If iIDVbc = 0 Then
MsgBox "Cet objet ne dispose pas de module.", vbInformation
Exit Function
End If

With VBE.VBProjects(msProjet).VBComponents(iIDVbc)
Set moCdMo = .CodeModule
End With

'// Liste les procédures du module.
Call fn_ScanModule '// |--->

Set moCdMo = Nothing
gfn_ScanObjet = 1

SORTIE_ScanObjet:
Exit Function
ERR_ScanObjet:
MsgBox Err.Number & vbCrLf & Err.Description, vbCritical, _
ERR_mdl & " " & ERR_proc
Resume SORTIE_ScanObjet
End Function

Private Function fn_ScanModule() As Byte
'//----o----o----o---Procedure header sample---o----o----o----o----o----o--\\
'//
'// Procédure : fn_ScanModule
'// Auteur : Laurent Moilneu
'// Date : 07/08/2001 14:56:23
'// Modif :
'//
'// Objectif : Recherche les déclarations de procédure dans un module.
'//
'// SORTIE ->
'// 1 l'exécution s'est déroulée correctement.
'//----o----o----o----o----o----o----o----o----o----o----o----o----o----o--\\
On Error GoTo ERR_ScanMdl
Const ERR_proc As String = "fn_ScanModule"
Const C_ap As String = "'"

Dim sLig As String
Dim sLigProc As String '// Ligne de déclaration de la procédure.
Dim sProc As String '// Nom de la procédure.
Dim lngNbLigDec As Long '// Nombre de lignes de la déclaration du module.
Dim lngNbLigMdl As Long '// Nombre de lignes du module.
Dim lngLigF As Long '// N° de la dernière ligne de la procédure.
Dim lngLig As Long '// Compteur pour la boucle.

'// Nombre de lignes de la section déclaration du module.
lngNbLigDec = moCdMo.CountOfDeclarationLines
'// Nombre de lignes du module.
lngNbLigMdl = moCdMo.CountOfLines

'// Boucle sur les lignes du module (sauf celles de la déclaration).
lngNbLigDec = lngNbLigDec + 1
For lngLig = lngNbLigDec To lngNbLigMdl
'// Extraire la ligne en cours.
sLig = LTrim(moCdMo.Lines(lngLig, 1))

'// Passe les lignes de commentaires ou vides.
If (sLig = "") Or (Left(sLig, 1) = C_ap) Then GoTo LIG_SUIV

'// Extraire le nom de la procédure de la ligne en cours.
If fn_ExtractNomProc(lngLig, sProc, sLigProc, lngLigF) = 1 Then '// |--->
'// Passe à la procédure suivante.
lngLig = lngLigF + 1
Debug.Print sProc & vbCrLf & sLigProc
End If

LIG_SUIV:
Next lngLig

fn_ScanModule = 1

SORTIE_ScanMdl:
Exit Function
ERR_ScanMdl:
MsgBox Err.Number & vbCrLf & Err.Description, vbCritical, _
ERR_mdl & " " & ERR_proc
Resume SORTIE_ScanMdl
End Function

Private Function fn_ExtractNomProc _
(lngLig As Long, sProc As String, _
sLigProc As String, lngLigF As Long) As Byte
'//----o----o----o---Procedure header sample---o----o----o----o----o----o--\\
'//
'// Procédure : fn_ExtractNomProc
'// Auteur : Laurent Moilneu
'// Date : 09/08/2001 09:56:13
'// Modif :
'//
'// Objectif : Extraire le nom de la procédure de la ligne en cours.
'//
'// ENTREE <-
'// lngLig : N° de la ligne en cours
'// sProc : RETOURNE le nom de la procédure.
'// sLigProc : RETOURNE la ligne entière de la déclaration.
'// lngLigF : RETOURNE le n° de la dernière ligne de la procédure.
'//
'// SORTIE ->
'// 1 Si un nom de procédure à été obtenu.
'//
'//----o----o----o----o----o----o----o----o----o----o----o----o----o----o--\\
On Error GoTo ERR_ExtProc
Const ERR_proc As String = "fn_ExtractNomProc"
Const T_PRP As String = "Property"
Const C_end As String = "End "

Dim lngTypeProc As Long '// Type de la procédure.
Dim lngLigProc As Long '// N° ligne de déclaration de la procédure.
Dim sTypeP As String '// Type de la procédure.
Dim sTMp As String
Dim sMemProc As String
Dim lngLD As Long
Dim lngCD As Long
Dim lngLF As Long
Dim lngCF As Long

sMemProc = sProc '// Mémorise la procédure en cours.

'// Obtenir le nom de la procédure, pour la ligne en cours.
sProc = moCdMo.ProcOfLine(lngLig, lngTypeProc)
If (sProc = "") Then Exit Function
'// Extraire le N° de la ligne de la déclaration de la procédure.
'// Nécessaire car elle peut être décalée, par rapport à la
'// ligne en cours, à cause des lignes de commentaires.
lngLigProc = moCdMo.ProcBodyLine(sProc, lngTypeProc)

'// Extraire la ligne de la procédure.
sLigProc = LTrim(moCdMo.Lines(lngLigProc, 1))

'// Si la ligne se termine par '_', la mettre sur une seule ligne.
'// lngLig est mis à jour.
If Right(sLigProc, 1) = C_cl Then
sLigProc = fn_ExtractLigneEntiere(lngLigProc) '// |--->
End If

'// Déterminer le type de la procédure.
sTypeP = fn_ExtractTypeProc(sLigProc, lngTypeProc) '// |--->

'// Obtenir la 'véritable' dernière ligne de la procédure.
lngLD = lngLigProc
sTMp = sTypeP
If Left(sTMp, 8) = T_PRP Then '// Property ?
sTMp = T_PRP
End If
sTMp = C_end & sTMp
Call moCdMo.Find(sTMp, lngLD, lngCD, lngLF, lngCF, True, True)

'// Le reste du module est en commentaires, donc
'// on est toujours dans la même procédure.
If (sMemProc = sProc) And (lngLigF = lngLD) Then
Exit Function
End If

lngLigF = lngLD
fn_ExtractNomProc = 1

SORTIE_ExtProc:
Exit Function
ERR_ExtProc:
MsgBox Err.Number & vbCrLf & Err.Description, vbCritical, _
ERR_mdl & " " & ERR_proc
Resume SORTIE_ExtProc
End Function

Public Function fn_ExtractTypeProc _
(sLig As String, lngTypeProc As Long) As String
'//----o----o----o---Procedure header sample---o----o----o----o----o----o--\\
'//
'// Procédure : ExtracTypeProc
'// Auteur : Laaurent Moilneu
'// Date : 09/08/2001 09:56:13
'// Modif :
'//
'// Objectif : Détermine en 'clair' le type de la procédure.
'//
'// ENTREE <-
'// sLig : Ligne de déclaration de la procédure.
'// lngTypeProc : Type numérique de la procédure.
'// SORTIE ->
'// Le type en 'clair' de la procédure.
'//----o----o----o----o----o----o----o----o----o----o----o----o----o----o--\\
On Local Error GoTo ERR_ExtType
Const ERR_proc As String = "fn_ExtractTypeProc"
Const T_pge As String = "Property Get"
Const T_ple As String = "Property Let"
Const T_pse As String = "Property Set"
Const T_psu As String = " Sub "
Const T_pfu As String = " Function "
Const C_esp As String = " "
Dim sType As String

Select Case lngTypeProc
Case vbext_pk_Get
sType = T_pge
Case vbext_pk_Let
sType = T_ple
Case vbext_pk_Proc
'// Insère un espace au cas ou 'Sub' ou
'// 'Function' est le 1er mot de la ligne.
If InStr(1, C_esp & sLig, T_psu, vbTextCompare) Then
sType = T_psu
Else
If InStr(1, C_esp & sLig, T_pfu, vbTextCompare) Then
sType = T_pfu
End If
End If
Case vbext_pk_Set
sType = T_pse
End Select

fn_ExtractTypeProc = Trim(sType)
SORTIE_ExtType:
Exit Function
ERR_ExtType:
MsgBox Err.Number & vbCrLf & Err.Description, vbCritical, _
ERR_mdl & " " & ERR_proc
Resume SORTIE_ExtType
End Function

Public Function fn_ObtenirIDVbComp(sVal As String) As Integer
'// 27/08/2001 14:02:24
'//----------------------------------------------
'// Obtenir l'ID du composant VB ayant pour nom sVal.
'// Retourne 0 si pas de module.
'//----------------------------------------------
Dim vbc As VBComponent
Dim iID As Integer
iID = 1
For Each vbc In VBE.VBProjects(msProjet).VBComponents
If vbc.Name = sVal Then
fn_ObtenirIDVbComp = iID
Exit For
End If
iID = iID + 1
Next vbc
End Function

Private Function fn_ExtractLigneEntiere(lngLig As Long) As String
'//----o----o----o---Procedure header sample---o----o----o----o----o----o--\\
'//
'// Procedure : fn_ExtractLigneEntiere
'// Auteur : Laurent Moilneu
'// Date : 09/08/2001 09:56:13
'// Modif :
'//
'// Objectif : Extraire la ligne entière, même si elle fini par '_'.
'//
'// ENTREE <-
'// lngLig : N° de la ligne en cours.
'//
'// SORTIE ->
'// La ligne formatée.
'//----o----o----o----o----o----o----o----o----o----o----o----o----o----o--\\
On Local Error GoTo ERR_ExtLig
Const ERR_proc As String = "fn_ExtractLigneEntiere"
Dim sTMp As String
Dim sCar As String
Dim lngLigCour As Long

sCar = C_cl
lngLigCour = lngLig

Do Until sCar <> C_cl
sTMp = sTMp & LTrim(moCdMo.Lines(lngLigCour, 1))
sCar = Right(sTMp, 1)
If (sCar = C_cl) Then
If Right(sTMp, 3) <> "& _" Then
sTMp = Left(sTMp, Len(sTMp) - 1)
End If
End If
lngLigCour = lngLigCour + 1
Loop

'// Retourne la ligne.
fn_ExtractLigneEntiere = sTMp

SORTIE_ExtLig:
Exit Function
ERR_ExtLig:
MsgBox Err.Number & vbCrLf & Err.Description, vbCritical, _
ERR_mdl & " " & ERR_proc
Resume SORTIE_ExtLig
End Function


Haut du document Trucs et Astuces MS-Access 

===========================
'Déclaration
    Public DocExcel As Object   

    'on dit que l'objet est de type feuille excel et ouvre Excel
    Set DocExcel = CreateObject("Excel.Application")
    'mettre à True pour l'afficher à l'écran , mettre à False pour pas qu'Excel reste invisible
    If AfficherExcel = True Then
        DocExcel.Visible = True
    Else
        DocExcel.Visible = False
    End If
    
    'supprime l'affichage des messages d'erreurs ou de confirmation de suppression, ...
    DocExcel.DisplayAlerts = False
    
    'ajoute un nouveau classeur
    If NouveauFichier Then
        DocExcel.Workbooks.Add
        'selectionne la feuille du classeur
        DocExcel.Sheets("Feuil2").Select
        'on supprime cette feuille
        DocExcel.ActiveWindow.SelectedSheets.Delete
        'on fait pareil avec la feuille 3
        DocExcel.Sheets("Feuil3").Select
        DocExcel.ActiveWindow.SelectedSheets.Delete
        'on selectionne la feuille 1 (la seule qui reste)
        DocExcel.Sheets("Feuil1").Select
        'on change le nom de celle ci
        DocExcel.Sheets("Feuil1").Name = "Mon Document Excel"
    Else
        'on ouvre un fichier existant de nom NomFichier
        DocExcel.Workbooks.Open FileName:=NomFichier, Editable:=True
    End If
    
    
    'on change la largeur de la colonne
    DocExcel.Columns("A:A").ColumnWidth = 20
    
    
    'on met selectionne la cellule A1
    DocExcel.Range("A1").Select
    test = ParametreExcel(DocExcel, "MS Sérif", TAILLEPOLICE09, False, False, 0, False)
    'on met la date et l'heure
    DocExcel.ActiveCell.FormulaR1C1 = "Fait le : " & Date & " à " & Time
    
    'du texte
    DocExcel.Range("A2").Select
    test = ParametreExcel(DocExcel, "MS Sérif", TAILLEPOLICE11, False, False, 0, False)
    DocExcel.ActiveCell.FormulaR1C1 = "Par un petit programme Vb"
    
    
    'une fusion de cellule
    DocExcel.Range("A5:D5").Select
    test = ParametreExcel(DocExcel, "MS Sérif", TAILLEPOLICE14, False, False, 0, True)
    DocExcel.ActiveCell.FormulaR1C1 = "Fusion des Cellules"
    
    
    'on change la police
    DocExcel.Range("A6:G6").Select
    test = ParametreExcel(DocExcel, "MS Sérif", TAILLEPOLICE09, True, True, 4, True)
    DocExcel.ActiveCell.FormulaR1C1 = "On change la police et on met en gras, en italic et on
aligne à droite"
    
'une opération
    DocExcel.Range("B8").Select
    test = ParametreExcel(DocExcel, "MS Sérif", TAILLEPOLICE11, False, False, 0, False)
    DocExcel.ActiveCell.FormulaR1C1 = 12
    DocExcel.Range("B9").Select
    test = ParametreExcel(DocExcel, "MS Sérif", TAILLEPOLICE11, False, False, 0, False)
    DocExcel.ActiveCell.FormulaR1C1 = 56
    DocExcel.Range("A10").Select
    test = ParametreExcel(DocExcel, "MS Sérif", TAILLEPOLICE11, False, False, 0, False)
    DocExcel.ActiveCell.FormulaR1C1 = "Somme ="
    DocExcel.Range("B10").Select
    test = ParametreExcel(DocExcel, "MS Sérif", TAILLEPOLICE11, True, False, 0, False)
    DocExcel.ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
    
    'on sauvegarde la feuille sous le nom contenu dans NomFichier
    DocExcel.ActiveWorkbook.SaveAs FileName:=NomFichier, _
        FileFormat:=17, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
    
    
    'on quitte excel
    DocExcel.Application.Quit


'' Maintenant, la fonction ParametreExcel
Public Function ParametreExcel(MyObject As Object, Police As String, TaillePolice As Integer, Gras
As Boolean, Italique As Boolean, AlignementH As Integer, Fusion As Boolean) As Boolean
        'les différents paramètres des cellules, il n'y sont pas tous
        With MyObject.Selection.Font
            .Name = Police
            .Size = TaillePolice
            .Strikethrough = False
            .subscript = False
            .OutlineFont = False
            .shadow = False
            .colorIndex = xlAutomatic
            .Italic = Italique
            .Bold = Gras
        End With
        With MyObject.Selection
            .WrapText = False
            .Orientation = 0
            .Addindent = False
            .ShrinkToFit = False
            .MergeCells = Fusion    'True = on fusionne les cellules
        End With
        
        If AlignementH <> 0 Then
            With MyObject.Selection
                .HorizontalAlignment = AlignementH
            End With
        End If
        
        ParametreExcel = True
End Function    



 Explication finale :
--------------------------------------------------------------------------------
 
D'abord, cliquer sur Creer le fichier , puis quand on clique sur Ouvrir fichier existant, ça va
modifier le premier fichier (la date et l'heure).
Si on appuie sur Ouvrir Excel, Excel apparait et on voit le texte que se met en place tout seul. 

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