Quelques exemples d'utilisation d'Access2000

Plic-ploc

Cet article se complète au fur et à mesure, au gré des interventions sur les forums de DVP.

Article lu   fois.

L'auteur

Profil ProSite personnel

Liens sociaux

Viadeo Twitter Facebook Share on Google+   

I. Avant-propos

Voici quelques compléments d'explication qui concernent des réponses que j'ai fournies sur le forum Access.

Le code proposé dans cet article contient des API, c'est-à-dire des fonctions externes déclarées avec l'instruction Declare Function ou Declare Sub.

Depuis Office 2010, Microsoft propose une version 64 bits.

Si vous exécutez un fichier contenant ce type de déclaration avec Office 2010 64 bits, ce code ne compile plus et vous aurez ce message

Image non disponible

Une réécriture de ces instructions est nécessaire.

Vous trouverez la documentation nécessaire dans ce tutoriel : http://arkham46.developpez.com/articles/office/vba64bits/

II. Un formulaire continu avec des images avec Access 2000

Si vous disposez d'une version Access 2007 ou encore plus récente, voyez plutôt le tutoriel « Intégration d'images dans les Formulaires Continus » de Dolphy35.

Dans sa contribution qui se trouve ici, Arkham46 nous propose :

  • le code pour créer une table contenant les adresses des images logées dans un répertoire ;
  • le code pour afficher ces images dans un formulaire continu.

C'est cette deuxième proposition que nous exploitons ici.

II-A. Exemple

Image non disponible

II-B. Comment faire

D'abord copier ce code dans un module :

 
Sélectionnez
Option Compare Database
            
            
'Attribute VB_Name = "ModImageOLE"
Option Explicit
'***************************************************************************************
'*              MODULE POUR AFFICHAGE D'IMAGES DANS UN CADRE OLE
'***************************************************************************************
            
'***************************************************************************************
' Auteur : Thierry GASPERMENT (Arkham46)
'
' Le code est libre pour toute utilisation
'***************************************************************************************
' v1.2 (22/06/11)
'***************************************************************************************
' Documentation OLE
' http://msdn.microsoft.com/en-us/library/dd942053(v=PROT.10).aspx
' http://support.microsoft.com/kb/147727/fr
'***************************************************************************************
            
' Definition des variables non typees en long pour 32 bits ou longptr pour 64 bits
' Les elements des types doivent etre types obligatoirement
#If VBA7 Then
DefLngPtr A - Z
Const PtrNull As LongPtr = 0
#Else
DefLng A-Z
Const PtrNull As Long = 0
#End If
            
' API
#If VBA7 Then
Private Declare PtrSafe Function OleTranslateColor Lib "oleaut32.dll" _
                                           (ByVal OLE_COLOR As Long, ByVal hPalette As Long, pccolorref As Long) As Long
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function SetStretchBltMode Lib "gdi32" (ByVal hdc As LongPtr, ByVal nStretchMode As Long) As Long
Private Declare PtrSafe Function StretchBlt Lib "gdi32" (ByVal hdc As LongPtr, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
Private Declare PtrSafe Function GetObjectBmp Lib "gdi32" Alias "GetObjectA" (ByVal hObject As LongPtr, ByVal nCount As Long, lpObject As Any) As Long
Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hdc As LongPtr) As Long
Private Declare PtrSafe Function CreateDIBSection Lib "gdi32" (ByVal hdc As LongPtr, pBitmapInfo As BitmapInfo, ByVal un As Long, lplpVoid As LongPtr, ByVal handle As LongPtr, ByVal dw As Long) As LongPtr
Private Declare PtrSafe Function GetDC Lib "USER32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function apiGetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As LongPtr, ByVal nCount As Long, lpObject As Any) As Long
Private Declare PtrSafe Function ReleaseDC Lib "USER32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
Private Declare PtrSafe Sub RtlMoveMemory Lib "kernel32" (Destination As Any, Source As Any, ByVal length As LongPtr)
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function FillRect Lib "USER32" (ByVal hdc As LongPtr, lpRect As Rect, ByVal hBrush As LongPtr) As Long
Private Declare PtrSafe Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr
Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
Private Declare PtrSafe Function GlobalFree Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function CreateStreamOnHGlobal Lib "ole32.dll" (ByRef hGlobal As Any, ByVal fDeleteOnRelease As Long, _
                                                                ByRef ppstm As Any) As Long
Private Declare PtrSafe Function OleLoadPicture Lib "oleaut32" _
            (lpstream As Any, ByVal lSize As Long, ByVal fRunmode As Long, _
            riid As GUID, lplpvObj As Any) As Long
#Else
Private Declare Function OleTranslateColor Lib "olepro32.dll" _
                                           (ByVal OLE_COLOR As Long, ByVal hPalette As Long, pccolorref As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal Hdc As Long, ByVal hObject As Long) As Long
Private Declare Function GetObjectBmp Lib "gdi32" Alias "GetObjectA" _
                                      (ByVal hObject As Long, ByVal nCount As Long, lpObject As bitmap) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal Hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal Hdc As Long) As Long
Private Declare Function SetStretchBltMode Lib "gdi32" (ByVal Hdc As Long, ByVal nStretchMode As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" _
                                    (ByVal Hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, _
                                     ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, _
                                     ByVal ySrc As Long, ByVal nSrcWidth As Long, _
                                     ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32" _
                                          (ByVal Hdc As Long, pBitmapInfo As BitmapInfo, ByVal un As Long, _
                                           lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private Declare Function GetDC Lib "User32" (ByVal hwnd As Long) As Long
Private Declare Function apiGetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function ReleaseDC Lib "User32" (ByVal hwnd As Long, ByVal Hdc As Long) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32" (Destination As Any, Source As Any, ByVal length As Long)
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal Hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function FillRect Lib "User32" (ByVal Hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function CreateStreamOnHGlobal Lib "ole32.dll" (ByRef hGlobal As Any, ByVal fDeleteOnRelease As Long, _
                                                                ByRef ppstm As Any) As Long
Private Declare Function OleLoadPicture Lib "olepro32" _
            (lpstream As Any, ByVal lsize As Long, ByVal fRunmode As Long, _
            riid As GUID, lplpvObj As Any) As Long
#End If
' CONSTANTES
Private Const LOGPIXELSY = 90
Private Const LOGPIXELSX = 88
Private Const HIMETRIC_INCH = 2540          ' Pour conversion Pouce<->Himetric
Private Const OT_STATIC = 3
Private Const SRCCOPY = &HCC0020
Private Const COLORONCOLOR = 3              ' Mode pour StretchBlt
Private Const HALFTONE = 4                  ' Mode pour StretchBlt avec antialiasing
Private Const DIB_RGB_COLORS As Long = &H0
Private Const BI_RGB As Long = &H0
Private Const GMEM_MOVEABLE = &H2&
' STRUCTURES
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Type bitmap
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
#If VBA7 Then
    bmBits As LongPtr
#Else
    bmBits As Long
#End If
End Type
Private Type BitmapInfoHeader
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type
Private Type BitmapInfo
    bmiHeader As BitmapInfoHeader
    bmiColors(0 To 255) As Long
End Type
Private Type DIBSECTION
    dsBm As bitmap
    dsBmih As BitmapInfoHeader
    dsBitfields(2) As Long
#If VBA7 Then
    dshSection As LongPtr
#Else
    dshSection As Long
#End If
    dsOffset As Long
End Type
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
            
' Fonction publique à appeler en source d'un contrôle OLE
Public Function ImageBinaryToOLE(pData As Variant, Optional pCtrlResize As Access.Control, Optional pCenter As Boolean, Optional pRepaintForm As Boolean) As Variant
Dim lsize As Long
Dim lhMem
Dim lPtr
Dim loStream As Long
Dim PicGUID As GUID
Dim lImg As Object
Dim lData() As Byte
On Error GoTo Gestion_Erreurs
If Not IsArray(pData) Then
    ReDim lData(1 To LenB(pData))
    RtlMoveMemory lData(1), ByVal StrPtr(pData), LenB(pData)
End If
lsize = (UBound(lData) - LBound(lData)) + 1
If lsize = 0 Then
  Exit Function
End If
lhMem = GlobalAlloc(GMEM_MOVEABLE, lsize)
    If lhMem Then
        lPtr = GlobalLock(lhMem)
        If lPtr Then
            RtlMoveMemory ByVal lPtr, lData(LBound(lData)), lsize
            GlobalUnlock lhMem
            ' Transformation du tableau en flux (stream)
            If CreateStreamOnHGlobal(ByVal lhMem, 1, loStream) = 0 Then
                With PicGUID ' IDispatch = Object
                    .Data1 = &H20400
                    .Data4(0) = &HC0
                    .Data4(7) = &H46
                End With
                OleLoadPicture ByVal loStream, lsize, 0, PicGUID, lImg
                If Not lImg Is Nothing Then
                    ImageBinaryToOLE = PrivImageToOLE(lImg, pCtrlResize, pCenter, pRepaintForm)
                End If
                Set lImg = Nothing
            End If
            'Set loStream = Nothing
        End If
        GlobalFree lhMem
    End If
Exit Function
Gestion_Erreurs:
Set lImg = Nothing
If lhMem <> 0 Then GlobalFree lhMem
End Function
            
' Fonction publique à appeler en source d'un contrôle OLE
Public Function ImageToOLE(ByVal pFile As String, Optional pCtrlResize As Access.Control, Optional pCenter As Boolean, Optional pRepaintForm As Boolean) As Variant
Dim lImg As Object
On Error GoTo Gestion_Erreurs
' Chargement de l'image complete
Set lImg = LoadPicture(pFile)
ImageToOLE = PrivImageToOLE(lImg, pCtrlResize, pCenter, pRepaintForm)
Gestion_Erreurs:
Set lImg = Nothing
End Function
            
Private Function PrivImageToOLE(pImg As Object, Optional pCtrlResize As Access.Control, Optional pCenter As Boolean, Optional pRepaintForm As Boolean) As Variant
Dim lData() As Byte
Dim lsize As Long
Dim lOldImg
Dim lloaddc, lLoadhBmp As bitmap
Dim lhdc, lhdcref
Dim lDIBPTR, lhDib, lhOldDib
Dim lWidth As Long, lHeight As Long
Dim lCtrlWidth As Long, lCtrlHeight As Long
Dim lBI As BitmapInfo
Dim lParentForm As Object
Dim lDecalageX As Long, lDecalageY As Long
Dim lRect As RECT, lBrush
Dim lBrushColor As Long
On Error GoTo Gestion_Erreurs
#If Win64 Then
' Lecture des donnees bitmap de l'image source
Call GetObjectBmp(pImg.handle, LenB(lLoadhBmp), lLoadhBmp)
#Else
Call GetObjectBmp(pImg.handle, Len(lLoadhBmp), lLoadhBmp)
#End If
' DC de référence
lhdcref = GetDC(0)
' Redimensionnement suivant taille contrôle
If Not pCtrlResize Is Nothing Then
    lCtrlWidth = CLng(pCtrlResize.Width / (1440 / GetDeviceCaps(lhdcref, LOGPIXELSX)))
    lCtrlHeight = CLng(pCtrlResize.Height / (1440 / GetDeviceCaps(lhdcref, LOGPIXELSY)))
    lWidth = lCtrlWidth
    lHeight = lCtrlHeight
    If lWidth < lLoadhBmp.bmWidth Or lHeight < lLoadhBmp.bmHeight Then
        If ((lLoadhBmp.bmWidth - lWidth)) / lLoadhBmp.bmWidth * lLoadhBmp.bmHeight < (lLoadhBmp.bmHeight - lHeight) Then
            lWidth = lWidth - (lWidth - lLoadhBmp.bmWidth * (lHeight) / lLoadhBmp.bmHeight)
            lHeight = lWidth / lLoadhBmp.bmWidth * lLoadhBmp.bmHeight
        Else
            lHeight = lHeight - (lHeight - lLoadhBmp.bmHeight * (lWidth) / lLoadhBmp.bmWidth)
            lWidth = lHeight / lLoadhBmp.bmHeight * lLoadhBmp.bmWidth
        End If
    Else
        lWidth = lLoadhBmp.bmWidth
        lHeight = lLoadhBmp.bmHeight
    End If
    If pCenter Then
        lDecalageX = (lCtrlWidth - lWidth) / 2
        lDecalageY = (lCtrlHeight - lHeight) / 2
    Else
        lCtrlWidth = lWidth
        lCtrlHeight = lHeight
    End If
Else
    lWidth = lLoadhBmp.bmWidth
    lHeight = lLoadhBmp.bmHeight
    lCtrlWidth = lWidth
    lCtrlHeight = lHeight
End If
' DC pour l'image source
lloaddc = CreateCompatibleDC(lhdcref)
lOldImg = SelectObject(lloaddc, pImg)
' DIB section et DC de l'image cible (24 bits)
With lBI.bmiHeader
    .biSize = 40
    .biBitCount = 24
    .biHeight = lCtrlHeight
    .biWidth = lCtrlWidth
    .biPlanes = 1
    .biCompression = BI_RGB
End With
lhdc = CreateCompatibleDC(lhdcref)
lhDib = CreateDIBSection(lhdc, lBI, DIB_RGB_COLORS, lDIBPTR, 0, 0)
lhOldDib = SelectObject(lhdc, lhDib)
If pCenter Then
    lRect.Right = lCtrlWidth
    lRect.Bottom = lCtrlHeight
    lBrushColor = vbWhite
    If Not pCtrlResize Is Nothing Then
        If pCtrlResize.BackStyle = 0 Then
            On Error Resume Next
            lBrushColor = pCtrlResize.Parent.Section(pCtrlResize.Section).BackColor
            On Error GoTo Gestion_Erreurs
        Else
            lBrushColor = pCtrlResize.BackColor
        End If
    End If
    lBrush = CreateSolidBrush(GetColor(lBrushColor))
    FillRect lhdc, lRect, lBrush
    DeleteObject lBrush
End If
' Copie de l'image source vers cible
SetStretchBltMode lhdc, HALFTONE
StretchBlt lhdc, lDecalageX, lDecalageY, lWidth, lHeight, lloaddc, 0, 0, lLoadhBmp.bmWidth, lLoadhBmp.bmHeight, SRCCOPY
' Lecture des donnees bitmap de l'image cible
#If Win64 Then
Call GetObjectBmp(lhDib, LenB(lLoadhBmp), lLoadhBmp)
#Else
Call GetObjectBmp(lhDib, Len(lLoadhBmp), lLoadhBmp)
#End If
lsize = lLoadhBmp.bmWidthBytes * lLoadhBmp.bmHeight
' Structure OLE
ReDim lData(1 To 95)
AddInt lData, &H1C15&, 1 ' Signature
AddInt lData, 27, 3 ' HeaderSize = len(OBJECTHEADER) + ClassLen + NameLen
AddLong lData, OT_STATIC, 5 ' ObjectType
AddInt lData, 6, 9 ' NameLen
AddInt lData, 1, 11 ' ClassLen
AddInt lData, 20, 13 ' NameOffset
AddInt lData, 26, 15 ' ClassOffset
AddInt lData, -1, 17 ' Width
AddInt lData, -1, 19 ' Height
lData(21) = Asc("I") ' Name
lData(22) = Asc("m")
lData(23) = Asc("a")
lData(24) = Asc("g")
lData(25) = Asc("e")
lData(26) = 0
lData(27) = 0 ' Class
AddLong lData, 1281, 28 ' OLEVersion : 1281 = 1.5
AddLong lData, 3, 32 ' FormatID
AddLong lData, 4, 36 ' PresClassLen
lData(40) = Asc("D") ' PresClass
lData(41) = Asc("I")
lData(42) = Asc("B")
lData(43) = 0
AddLong lData, CLng(lLoadhBmp.bmWidth * (HIMETRIC_INCH / GetDeviceCaps(lhdc, LOGPIXELSX))), 44 ' WidthHiMetric
AddLong lData, -CLng(lLoadhBmp.bmHeight * (HIMETRIC_INCH / GetDeviceCaps(lhdc, LOGPIXELSY))), 48 ' HeightHimetric
AddLong lData, 40 + lsize, 52 ' PresentationDataSize
AddLong lData, 40, 56 ' biSize
AddLong lData, lLoadhBmp.bmWidth, 60   ' biWidth
AddLong lData, lLoadhBmp.bmHeight, 64  ' biHeight
AddInt lData, 1, 68 ' biPlanes
AddInt lData, lLoadhBmp.bmBitsPixel, 70    ' biBitCount
AddLong lData, 0, 72 ' biCompression
AddLong lData, lsize, 76 ' biSizeImage
AddLong lData, 3780, 80 ' biXPelsPerMeter
AddLong lData, 3780, 84 ' biYPelsPerMeter
AddLong lData, 0, 88  ' biClrUsed
AddLong lData, 0, 92  ' biClrImportant
' Redim pour ajout des pixels
ReDim Preserve lData(1 To 95 + lsize + 4) ' + 4 pour le checksum (non calculé ici)
' Copie des données images (=pixels)
If lLoadhBmp.bmBits <> 0 Then
    RtlMoveMemory lData(96), ByVal lLoadhBmp.bmBits, lsize
End If
' Retour des données
PrivImageToOLE = lData
If Not pCtrlResize Is Nothing And pRepaintForm Then
    Set lParentForm = pCtrlResize.Parent
    Do While Not TypeOf lParentForm Is Access.Form
        Set lParentForm = lParentForm.Parent
    Loop
    lParentForm.Repaint
End If
' Destruction des objets
Gestion_Erreurs:
    ReleaseDC 0, lhdcref
    DeleteObject SelectObject(lhdc, lhOldDib)
    DeleteDC lhdc
    SelectObject lloaddc, lOldImg
    DeleteDC lloaddc
End Function
Private Sub AddLong(pArray() As Byte, pLong As Long, pPos As Long)
RtlMoveMemory pArray(pPos), pLong, 4
End Sub
Private Sub AddInt(pArray() As Byte, pInt As Integer, pPos As Long)
RtlMoveMemory pArray(pPos), pInt, 2
End Sub
Private Function GetColor(ByVal pColor As Long) As Long
    If pColor < 0 Then
        Call OleTranslateColor(pColor, 0, pColor)
    End If
    GetColor = pColor
End Function

II-C. Comment s'y prendre

Image non disponible

Image non disponible Insérez un « Cadre d'objet dépendant » dans le formulaire et le nommer par exemple OleImg

Image non disponible Pour la propriété « Source contrôle », procédez, par exemple, comme ceci :

  • logez les images dans un dossier appelé « Images » situé dans le même répertoire que celui de la base de données ;
    le nom de l'image étant composé du numéro d'enregistrement (ici la colonne « idVinPK ») et l'extension « .jpg ».

    Image non disponible
  • la propriété « Source contrôle » peut se construire en suivant ce raisonnement :
Image non disponible

II-D. Procédez par analogie pour un état

Voir « EtatImages » dans la db d'exemples.

II-E. Téléchargement

La db exemple se trouve ici.

N.B. L'archive contient le fichier PlicPlocFormContinuImages.mdb et un dossier Images que vous devez loger dans un même répertoire.

Image non disponible

III. Compléter les postes d'une facture, d'un bon de commande

Image non disponible

III-A. L'architecture

Le formulaire frmFacturation inclut :

  • un sous-formulaire fils : sfFacItems ;
  • un sous-formulaire indépendant : sfFacItems.

Pour la technique père/fils, voyez Comment classer les données dans des tables liées et construire un formulaire père/fils.
Pour l'ajustement automatique de la dimension voyez Tenir une comptabilité avec Access /IV. Une routine pour dimensionner le sous-formulaire d'après le nombre de ses enregistrements.

Remarque

Dans cet exemple, les articles proposés à la vente sont présentés dans un sous-formulaire en continu. Cela offre plus de possibilités qu'une simple zone de liste modifiable :

  • on peut afficher une photo de l'article ;
  • on peut prévoir des critères de sélection.

III-B. Comment ça marche

Un double-clic sur un contrôle du sous-formulaire sfFacArticles déclenche l'exécution de cette routine

 
Sélectionnez
1.
2.
3.
4.
5.
6.
7.
Public Sub Ajout()
DoCmd.SetWarnings False
DoCmd.OpenQuery "MaJtFacItems"
DoCmd.SetWarnings True
Me.Parent.ctnrSfFacItems.Form.Requery
Me.Parent.Form_Current
End Sub

Ligne 3 : on exécute cette requête

Image non disponible

On ajoute donc un enregistrement dans la table tFacItems pour la facture en cours de lecture.

Ligne 5 : on actualise le sous-formulaire sfFacItems pour qu'il affiche cet enregistrement supplémentaire.

Ligne 6 : on déclenche l'événement « Sur activation » du formulaire principal, pour provoquer le redimensionnement de sfFacItems.

L'utilisateur n'a plus qu'à compléter la quantité à facturer.

III-C. Téléchargement

La db exemple se trouve ici.

N.B. L'archive contient le fichier PlicPlocFacturation.mdb et un dossier Images que vous devez loger dans un même répertoire.

Image non disponible

IV. Déterminer les jours ouvrés

IV-A. Une manière d'obtenir les jours généralement ouvrés

Quatre tables…

Image non disponible

… et une requête…

Image non disponible

… qui (re)crée une table des jours ouvrés 

Image non disponible

Ceci permet d'adapter plus facilement aux us et coutumes de l'entreprise (jours de fermeture, fête nationale, lundi de Pentecôte (oui ou non), bank holiday, jours de remplacement, fêtes locales…)

IV-B. Expliquons la démarche pour construire la requête rJoursOuvres

IV-B-1. Étape 1

Image non disponible

Comme les tables ne sont pas liées, cette requête va ramener toutes les combinaisons possibles entre les 31 valeurs de tJours, les 12 valeurs de tMois et l'enregistrement de tAnnees soit

31 x 12 x 1 = 372 lignes.

Image non disponible

À remarquer que, pour certaines combinaisons, la fonction CDate() va donner une erreur.

Sept fois : quand elle essaiera de convertir en date 29/2/14, 30/2/14, 31/2/14, 31/4/14, 31/6/14, 31/9/14 et 31/11/14.

IV-B-2. Étape 2

Ajoutons une colonne à notre requête pour exprimer qui nous voulons seulement les enregistrements qui constituent une date.

Image non disponible

ce qui donne

Image non disponible

IV-B-3. Étape 3

Dans la plupart des cas, l'entreprise est fermée les week-ends, donc les samedis et dimanches doivent être éliminés, ajoutons une nouvelle colonne à la requête pour éliminer ces deux jours 

Image non disponible

Cette fois, la requête ramène 261 lignes :

Image non disponible

IV-B-4. Étape 4

Il reste à exprimer que nous voulons éliminer les jours fériés.

On construit d'abord une requête qui liste les jours fériés

Image non disponible

et on récupère son SQL

 
Sélectionnez
SELECT dateFeriee FROM tJoursFeries;

et on s'en sert pour exprimer dans la 1re colonne que ces combinaisons doivent être rejetées

Image non disponible

Finalement, la requête ramène les 252 jours ouvrés

Image non disponible

Puisqu'il y a 10 jours fériés, on s'attendait à 261 - 10 soit 251 jours.

La Toussaint tombait un samedi en 2014 !

IV-B-5. Étape 5

Il ne reste plus qu'à transformer cette requête Sélection en requête Création de table et on a atteint notre but.

IV-C. Une fonction pour trouver le dernier jour ouvrable du mois en cours

 
Sélectionnez
Public Function DerOuvre(UneDate As Date) As Date
'Quand se termine le mois d'une date donnée ?
 Dim Lendemain As Date
   'on construit la date du lendemain (en l'occurrence le 1er du mois en cours)
   Lendemain = DateSerial(Year(UneDate), Month(UneDate) + 1, 1)
   DerOuvre = DMax("JoursOuvres", "tJoursOuvres", "JoursOuvres<#" & Format(Lendemain, "mm/dd/yyyy") & "#")
End Function

Exemples d'utilisation :

Pour accéder à la fenêtre d'exécution, enfoncez <CTRL + G >.

Image non disponible

La date doit être présentée sous la forme anglo-saxonne (mois/jour/année) et encadrée de croisillons.

Image non disponible

Pas de croisillon si le paramètre est une fonction.

Dans un formulaire :

Image non disponible

Ne pas reformater la date !

IV-D. Une fonction pour trouver le nombre de jours ouvrables dans un intervalle de temps

 
Sélectionnez
Public Function NbreJOuvDeA(DateDebut As Date, DateFin As Date) As Long
 'Dates sous la forme anglo-saxonne
 'On compte les 1er et dernier jours ouvrables inclus dans la période
 '   ? NbreJOuvDeA(#4/17/14#,#4/23/14#)  donne 4 (17,18,22 et 23 sont comptés)
 NbreJOuvDeA = DCount("*", "tJoursOuvres", "JoursOuvres>=#" _
                                             & Format(DateDebut, "mm/dd/yy") _
                                         & "# And JoursOuvres <=#" _
                                             & Format(DateFin, "mm/dd/yy") & "#")
End Function

IV-D-1. Un exemple d'application

En réponse à cette demande.

Image non disponible
 
Sélectionnez
SELECT tCommandes.tCommandes, tCommandes.DateDeb, Format([DateDeb],"dd/mm/yy") AS LeJour, Now()-[Datedeb] AS DureeTotale, [Dureetotale]-NbreJOuvDeA([Lejour],Date())+1 AS DiffJO, [DiffJO]>15/24 AS Test
FROM tCommandes;
Image non disponible

IV-E. Une fonction qui calcule une date ouvrable future (ou passée) connaissant une date de départ et un nombre de jours ouvrables

 
Sélectionnez
Public Function Echeance(DateDebut As Date, NbreJrs As Integer) As Date
 'Renvoie la date ouvrable qui vient après le nombre de jours (qui peut être négatif)
 'DateDebut sous la forme anglo-saxonne
 'Si cette DateDebut n'existe pas dans la table, la fonction renvoie 00:00:00
  
  Dim rst As Recordset
  Set rst = CurrentDb.OpenRecordset("SELECT JoursOuvres FROM tJoursOuvres ORDER BY JoursOuvres;")
  Do While Not rst.EOF
    If rst("JoursOuvres") = DateDebut Then
        rst.Move NbreJrs
        Echeance = rst("JoursOuvres")
        Exit Function
      Else
        rst.MoveNext
    End If
  Loop
End Function
Image non disponible

IV-E-1. Un exemple d'utilisation

Pour répondre à cette question sur le forum.

Connaissant le 1er jour ouvrable d'une activité et sachant qu'elle demandera x jours ouvrables, à quelle date sera-t-elle terminée ?

La fonction Echeance() renvoie la date ouvrable qui vient après le nombre de jours ouvrables indiqué.

Dans la question posée, le jour de départ compte dans le délai. Il faut donc défalquer 1 jour dans le paramètre « Nbrejrs » passé à la fonction

Image non disponible

IV-F. Téléchargement

V. Une liste déroulante qui rétrécit au fur et à mesure que des items sont choisis

Imaginez que vous deviez constituer une équipe de foot, vous avez une quinzaine de joueurs et des modèles de tactique :

Image non disponible

Un joueur ne pourra occuper qu'une seule place.

Image non disponible

En d'autres mots, lorsqu'un joueur de la liste a été choisi, il doit disparaître de la liste des choix offerts dans les autres cases.

Il faut envisager que l'on peut revenir en arrière pour corriger un choix précédent.

V-A. Au départ

Les propriétés des zones de liste modifiables sont telles :

Image non disponible

V-B. L'idée

Elle consiste à construire de manière dynamique, pour chaque zone de liste, une requête qui ramène tous les items encore disponibles compte tenu des choix (éventuellement) opérés dans les autres zones de liste. Donc tous les items, sauf ceux qui sont pris par d'autres.

À remarquer que le choix opéré dans une zone de liste quelconque nécessite la réactualisation des choix possibles pour toutes les autres cboJoueurn.

V-C. Comment s'y prendre

Ce qu'il faut construire, c'est une requête comme celle-ci :

Image non disponible

V-D. L'algorithme

Se résume donc à construire le SQL d'une requête dont une partie est fixe, seule l'écriture de

Pas In(IdPris1, IdPris2, …) doit être modulé pour chaque cboJoueurn.

On ne peut pas écrire un critère comme ceci Pas In() pour exprimer qu'il ne faut rien exclure (quand aucun choix n'a encore été opéré).

Qu'à cela ne tienne, on écrira Pas In(0,) pour exprimer qu'on n'exclut rien : Access acceptera cette valeur, puisque elle est numérique, et comme tJoueursPK est du type NuméroAuto il ne sera jamais inférieur à 1. Donc, indiquer Pas In(0,) ne mange pas de pain !

On va donc construire l'intérieur de la parenthèse en commençant d'office par 0, et on explorera le contenu de chaque zone de liste pour compléter en séparant avec des virgules. S'il s'avère que le contenu est de valeur Null, on indiquera également 0,

Par exemple ceci : Not In (0,9,3,0,0,0,0,0,0,0,0,0,) si Romelu Lukaku (tJoueursPK 9) et Koen Casteels (tJoueursPK 3) ont déjà été affectés à un autre poste.

Image non disponible
 
Sélectionnez
SELECT tJoueursPK,  NomJoueur FROM tJoueurs 
WHERE tJoueursPK Not In (0,9,3,0,0,0,0,0,0,0,0,0,) 
ORDER BY NomJoueur;

qui ramène :

Image non disponible

Pour que le processus soit aussi général que possible, nous allons procéder en deux temps :

1° créer une chaine In (0,et tous ceux qui sont choisis dans l'ensemble des cbo) ;

2° pour chaque cbo en particulier, remplacer dans cette chaine le ,de sa propre valeur, par ,0,

Pour être concret à supposer que Romelu Lukaku (tJoueursPK 9), Koen Casteels (tJoueursPK 3) et Eden Hazard (tJoueursPK 7) aient été choisis dans respectivement dans les trois premiers postes, nous aurons dans un premier temps pour toutes les listes

WHERE tJoueursPK Not In (0,9,3,7,0,0,0,0,0,0,0,0,)

et dans un deuxième temps :

- le premier poste deviendra : WHERE tJoueursPK Not In (0,0,3,7,0,0,0,0,0,0,0,0,) ;

- le deuxième : WHERE tJoueursPK Not In (0,9,0,7,0,0,0,0,0,0,0,0,) ;

- le troisième : WHERE tJoueursPK Not In (0,9,3,0,0,0,0,0,0,0,0,0,) ;

- tous les autres garderont : WHERE tJoueursPK Not In (0,9,3,7,0,0,0,0,0,0,0,0,).

V-E. Le code de la routine Sub MajListeJoueur()

Cette routine est appelée après la mise à jour de n'importe quelle zone de liste cboJoueurn.

 
Sélectionnez
Public Sub MajListeJoueur()
  Dim i As Integer
  Dim ctl As Control
  Dim sExclus As String
  Dim sSql As String
  'Construire la liste des exclus : tous ceux qui sont affectés
  sExclus = "0,"    'Ça ne mange pas de pain ! (aucun n'aura cette valeur)
  For i = 1 To 11
    sExclus = sExclus & Nz(Me("cboJoueur" & i), 0) & ","
  Next i
  'Reconstruire le SQL des listes : exclure le contenu de sExclus sauf sa propre valeur
  For i = 1 To 11
    sSql = "SELECT tJoueursPK,  NomJoueur FROM tJoueurs WHERE tJoueursPK " _
                   & "Not In (" & Replace(sExclus, "," & Nz(Me("cboJoueur" & i), 0) & ",", ",0,") & ") " _
                   & "ORDER BY NomJoueur;"
    Me("cboJoueur" & i).RowSource = sSql
  Next i
End Sub
Image non disponible

Par exemple, dans le 1er poste (celui de Romelu Lukaku, tJoueursPK 9) la partie bleue vaudra ,9, que l'on remplacera par ,0,

Pour le 4e poste (qui n'est pas encore attribué) la partie bleue vaudra ,0, puisque la valeur de cboJoueur4 est encore Null : Nz() renverra 0. sExlus gardera sa valeur intacte puisque un ,0, sera remplacé par ,0, !

V-F. Téléchargement

La db exemple se trouve ici.

N.B. L'archive contient le fichier PlicPlocListeQuiRetrecit.mdb et un dossier Images que vous devez loger dans un même répertoire.

Image non disponible

VI. Envoyer un état par mail avec Access2000 et PDFCreator en un clic

VI-A. Le point de départ

Imaginons que l'on soit arrivé à ce stade dans l'élaboration de l'état

Image non disponible

VI-B. Un peu de code

VI-B-1. Les références utiles

Image non disponible

VI-B-2. Quelques API

Probablement récupérées sur Internet.

Je ne vous en dirai rien, sinon que, si elles sont logées telles quelles dans un module (que j'ai appelé « mAPI »), je sais que le reste du code ira bien. C'est comme le carburateur de ma voiture : j'ignore comment il fonctionne, cela ne m'empêche pas de conduire ma voiture !

 
Sélectionnez
Option Compare Database
Option Explicit
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Declare Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Integer) As Integer
Private Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, _
   lpdwprocessid As Long) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, _
   ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, _
   ByVal nIndex As Long) As Long
Private Const WM_CLOSE = &H10
Private Const GWL_STYLE = (-16)
Private Const WS_SYSMENU = &H80000

Private Function CloseWindow(ByVal hwnd As Long, ByVal hInstance As Long) As Long
Dim idproc As Long
idproc = 0
' Reçoit dans idproc l'id du processus lié à cette fenêtre
GetWindowThreadProcessId hwnd, idproc
If (idproc = hInstance) And ((GetWindowLong(hwnd, GWL_STYLE) And WS_SYSMENU) = WS_SYSMENU) Then
     PostMessage hwnd, WM_CLOSE, 0, 0
End If

' Obligatoire pour qu'EnumWindows continue l'énumération
CloseWindow = True
End Function
Public Sub KillApp(hInstance As Long)
  EnumWindows AddressOf CloseWindow, hInstance
End Sub

'Renvoie l'imprimante par défaut
Public Function ImprimanteParDefaut() As String
 Dim ASpliter() As String
 Dim def As String, di As Long
 Dim Tampon As String
    def = String(128, 0)
    di = GetProfileString("WINDOWS", "DEVICE", "", def, 127)
    If di Then Tampon = Left$(def, di - 1)
 ASpliter = Split(Tampon, ",")
ImprimanteParDefaut = ASpliter(0)
End Function

VI-B-3. Le code associé au clic du bouton « Envoyer État »

Les commentaires insérés dans le code doivent permettre à un débutant de comprendre le cheminement.

Image non disponible N'oubliez pas la touche !

Pour obtenir de l'info sur une instruction, placez le curseur de la souris à l'intérieur d'un mot-clé et enfoncez la touche F1, l'aide Access s'ouvre à la bonne page.

Dans mes paramètres de PDFCreator, j'ai choisi l'enregistrement automatique dans le répertoire C:\PDF\

Menu Imprimante > Options > Enregistrement automatique

Image non disponible

 
Sélectionnez
Option Compare Database
Option Explicit

Private Sub btEnvoi_Click()
  
  Dim wsn As Object
  Dim oFSO As Scripting.FileSystemObject
  Dim oFld As Folder
  Dim oFl As File
  Dim sImprDefaut As String
  Dim ret As Integer
  Dim objOutlook As Outlook.Application
  Dim MonMessage As Object

  'S'assurer que le dossier qui contient les PDF est vide
  'Note : Dans les paramètres de PDFCreator C:\PDF\
                   'est le répertoire prévu pour l'enregistrement automatique
  Set oFSO = New Scripting.FileSystemObject
  Set oFSO = New Scripting.FileSystemObject
  Set oFld = oFSO.GetFolder("c:\pdf")
  For Each oFl In oFld.Files
     oFl.Delete
  Next

  'Mémoriser l'imprimante par défaut
  sImprDefaut = ImprimanteParDefaut()
  
  'PDFCreator comme imprimante
  Set wsn = CreateObject("WScript.Network")
  wsn.SetDefaultPrinter "PDFCreator"
  
  'Imprimer l'état en PDF
  DoCmd.OpenReport "Etat"
  
  'Rétablir l'imprimante par défaut
  wsn.SetDefaultPrinter sImprDefaut
  Set wsn = Nothing
  'Attendre que le fichier se crée
  Sleep (2000)
 'Renommer le fichier PDF
  For Each oFl In oFld.Files
    oFl.Name = Me.txtNomEtat & ".pdf"
  Next
  'Envoyer le mail
  
  'ouvrir OutLook  'Modifier éventuellement le chemin et adapter (ou supprimer) le "profile"
  ret = Shell("C:\Program Files (x86)\Microsoft Office\Office14\OUTLOOK.EXE /profile &claude", vbHide)
  
  'Assigner l'objet Outlook
  Set objOutlook = New Outlook.Application
  
  'Composer le message
  Set MonMessage = objOutlook.createitem(0) 'ouvrir une structure de message
  MonMessage.To = Me.txtDestinataire
  MonMessage.Subject = Me.txtObjetDuMail
  MonMessage.Body = Me.txtContenuMail
  MonMessage.Attachments.Add "c:\pdf\" & Me.txtNomEtat & ".pdf"
  MonMessage.send
  
  'Fermer Outlook et libérer la mémoire
  Sleep 2000
  Set objOutlook = Nothing
  Set oFSO = New Scripting.FileSystemObject
  Set oFSO = New Scripting.FileSystemObject
  Set oFld = oFSO.GetFolder("c:\pdf")
  KillApp (ret)
 
End Sub

VI-C. Téléchargement

VII. Quelques exercices avec des dates

VII-A. Bon à savoir avant de commencer

VII-A-1. Access stocke la date et l'heure sous la forme d'un nombre décimal

La partie entière est le quantième jour depuis le 30/12/1899.

La partie décimale indique la fraction de ce jour écoulée depuis le matin, 0 heure.

Image non disponible

VII-A-2. Access réagit parfois de manière déconcertante

Dans les pays francophones, le format d'une date est généralement jj/mm/aa.
Dans les pays anglophones c'est mm/jj/aa.
Et par exemple au Japon aa/mm/jj ou plutôt : aa年mm月jj日.
Dans Access, cela dépend du contexte, parfois il attend #jj/mm/aa# par exemple dans la fonction VraiFaux(), parfois il attend #mm/jj/aa#, comme dans MaxDom().

L'interprétation par Access est parfois déroutante :

Valeur Interprétation
#01/07/10# « 7 janvier 2010 »
#02/07/10# « 7 février 2010 »
#03/07/10# « 7 mars 2010 »
[...]  
#12/07/10# « 7 décembre 2010 »
#13/07/10# « 10 juillet 2013 »
#14/07/10# « 10 juillet 2014 »
#2012/7/20# « 20 juillet 2012 »
#20/7/2012# « 20 juillet 2012 »

VII-A-3. Pour (presque) tout savoir

Voyez le tutoriel de Maxence HUBICHE : Les Fonctions Date/Heure.

VII-B. Calculer une date anniversaire et exprimer la durée restant à courir en années, mois, jours

Imaginons une table qui contiendrait une liste d'appareils avec la date d'achat et la durée de garantie exprimée en mois

Image non disponible

Nous voudrions un formulaire qui nous renseigne pour chaque matériel la durée de la garantie restant à courir :

Image non disponible

Voici la fonction ResteAcourir :

 
Sélectionnez
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
Public Function ResteACourir(DateAchat As Date, DureeEnMois As Integer) As String
  Dim Echeance As Date
  Dim NbreJrsRestant As Integer
  Dim NbreAnnees As Integer
  Dim NbreMois As Integer
  Dim NbreJours As Integer
  Dim JusteAvant As Date
  'Calcul de l'échéance
  Echeance = DateSerial(Year(DateAchat), Month(DateAchat) + DureeEnMois, Day(DateAchat))
  'Traiter les dépassements de cycle
  If Day(Echeance) > Day(DateAchat) Then Echeance = Echeance - Day(Echeance)
  'Nbre de jours restant à courir
  NbreJrsRestant = Echeance - Date
  'Garantie caduque
  If NbreJrsRestant <= 0 Then
     ResteACourir = "La garantie est caduque."
     Exit Function
  End If
  'Cas banal
  ResteACourir = NbreJrsToAnMoisJrs(NbreJrsRestant)
End Function

Commentaires sur le code

4-9 : définition de variables.

11-13 : on se sert de la fonction DateSerial() pour calculer l'échéance, on ajoute le nombre de mois de garantie au mois de la date d'achat.

Cela donne par exemple pour 3 mois de garantie :

11/05/13 => 11/08/13

11/12/13 => 11/15/13 qu'Access traduit en 11/03/14

30/11/13 => 30/14/13 => 30/02/14 => 02/03/14

Dans ce dernier exemple, le jour (30) n'est pas conservé (02). Si on constate le cas, pour corriger cette anomalie, on recule au dernier jour ouvrable du mois précédent (en l'occurrence, on retire 02 jours du résultat obtenu :

 
Sélectionnez
If Day(Echeance) > Day(DateAchat) Then Echeance = Echeance - Day(Echeance)

15-18 : s'il s'avère que le nombre de jours est négatif, c'est que la garantie est devenue caduque.

20 : pour le cas banal, on fait appel à la fonction NbreJrsToAnMoisJrs :

 
Sélectionnez
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
Public Function NbreJrsToAnMoisJrs(NbreJrs As Integer) As String
  Dim Ventil() As String
  Dim DateFictive As Date
  'Cas particulier
  If NbreJrs = 0 Then NbreJrsToAnMoisJrs = "Zéro année, mois et jour.": Exit Function
  If NbreJrs < 0 Then NbreJrs = NbreJrs * -1
  'Cas banal
  DateFictive = DateSerial(Year(#12/31/1999# + NbreJrs), _
                            Month(#12/31/1999# + NbreJrs), _
                            Day(#12/31/1999# + NbreJrs))
  Ventil = Split(DateFictive, "/")
  NbreJrsToAnMoisJrs = Int(Ventil(2)) & " année(s), " _
                      & Ventil(1) - 1 & " mois et " _
                      & Ventil(0) & " jour(s)."
End Function

Cette fonction transforme un nombre de jours en unités année, mois, jours.

Image non disponible

Explication du code

L'idée consiste à construire une date fictive et d'en récupérer les composantes année, mois et jour.

2 : on définit une variable de type tableau (pour utiliser la fonction Split()

5 : on traite le cas particulier d'une durée égale à zéro jour.

6 : si le nombre de jours est négatif, on inverse le signe.

8-10 : on crée une date fictive en ajoutant le nombre de jours au 31/12/1999.
Par exemple, si le nombre de jours égale 1000, nous obtenons

Image non disponible

de là, on peut déduire que la durée est

Image non disponible

11 : on répartit les morceaux. Nous aurions donc :
dans la 1re colonne du tableau Ventil(0) « 26 »
dans la 2e Ventil(1) « 09 »
dans la 3e Ventil(2) « 02 ».

N.B. On formate la date sous jour/mois/année en 2 positions, pour le cas où l'utilisateur aurait choisi jj/mm/aaaa dans ses préférences de date courte :

Image non disponible

12-14 : on compose le texte de la réponse.
Int(Ventil(2)) pour afficher « 2 » et non « 02 »
Ventil(1) -1 pour afficher le nombre de mois complet.

La db exemple se trouve ici.

VIII. Ouvrir un formulaire à l'enregistrement qui était actif lors de la fermeture précédente

VIII-A. L'idée

À la fermeture du formulaire, mémoriser dans une table, le numéro d'enregistrement alors actif.

À l'ouverture du formulaire, rechercher dans la table ce numéro et afficher cet enregistrement.

VIII-B. La table pour mémoriser

Image non disponible

VIII-C. Le code dans le module du formulaire

 
Sélectionnez
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
Option Compare Database
Option Explicit
Dim lDernierConsulte As Long

Private Sub Form_Current()
  lDernierConsulte = Me.CurrentRecord
End Sub

Private Sub Form_Close()
  DoCmd.SetWarnings False 'supprimer temporairement les messages
  'Ce formulaire est-il déjà dans la table ? si oui mettre à jour
  If DCount("*", "DerniersConsultes", "NomDuFormulaire = """ _
                                     & Me.Name & """") = 1 Then
      DoCmd.RunSQL ("UPDATE DerniersConsultes " _
               & "SET DernierConsulte = " & lDernierConsulte & " " _
               & "WHERE NomDuFormulaire =""" & Me.Name & """;")
    Else ' si non il faut ajouter un item dans la table
      DoCmd.RunSQL ("INSERT INTO DerniersConsultes ( NomDuFormulaire, DernierConsulte ) " _
          & "SELECT """ & Me.Name & """ AS Expr1, " _
          & lDernierConsulte & " AS Expr2;")
      DoCmd.SetWarnings True
    End If
End Sub

Private Sub Form_Open(Cancel As Integer)
 'si déjà dans la table --> ouvrir au dernier, si non ne rien faire
 If DCount("*", "DerniersConsultes", "NomDuFormulaire = """ _
                                     & Me.Name & """") = 1 Then
    DoCmd.GoToRecord acDataForm, Me.Name, acGoTo, _
        DLookup("DernierConsulte", "DerniersConsultes", "NomDuFormulaire= """ & Me.Name & """")
End If
End Sub

Explication du code

3 à 7 :
nous devons mémoriser le numéro du dernier enregistrement traité par le formulaire.
Ce numéro s'obtient avec la propriété Me.CurrentRecord.
Le problème : lors de l'événement de fermeture du formulaire (« Private Sub Form_Close() »), Me.CurrentRecord est mis à zéro par Access, c'est donc trop tard pour le mémoriser !
Il faut un peu ruser : nous définissons une variable « lDernierConsulte » en tête de module (instruction 3). Elle sera visible dans le périmètre du formulaire tant que celui-ci sera ouvert (donc encore disponible au moment du Form_Close.
À chaque lecture d'un enregistrement (instructions 5-6), nous mémorisons le numéro d'enregistrement dans la variable « lDernierConsulte ».
À la fermeture, la variable contiendra donc le N° du dernier enregistrement lu.

9 à 22 :
en 12, nous demandons si le nom du formulaire est déjà mémorisé dans la table. Mis à part la première fois, la réponse sera « Oui » et en 14 à 16, nous exécutons une requête de type « Mise à jour » pour rafraîchir la colonne « DernierConsulte ».
Si c'est la première fois, en 18-20, on exécute une requête de type « Ajout » pour créer la ligne.

25 à 32 :

On demande si la ligne existe (27-28).
Si « Oui », on se positionne sur l'enregistrement (29-30).

Si « Non », on laisse Access ouvrir le formulaire « naturellement », c'est-à-dire sur le premier enregistrement de sa source.

VIII-D. Téléchargement

IX. Compléments Q/R d1453940 (Outils pour gérer des contrats)

La discussion est ici.

IX-A. Construction de la requête rPaiementsEnSouffrance

Image non disponible

Le formulaire fPaiementsEnSouffrance est un formulaire de recherche multicritère basé sur la technique décrite dans ce tutoriel : Formulaire de recherche sur la base d'une requête.

Sa source doit être une requête dont les colonnes contiennent toutes celles nécessaires à l'affichage des résultats et celles qui se réfèrent aux contrôles nommés « Filtrexxx » du formulaire. Elle aura cet aspect.

Image non disponible

Nous voulons afficher les enregistrements qui concernent les contrats dont la prime n'est pas encore complètement payée. C'est-à-dire, les enregistrements où [Prime] > à la somme des paiements à la date spécifiée dans FiltrePaiementDate

Image non disponible

Nous allons donc construire dans la requête, une colonne « Paiements » dont voici le zoom du code :

Image non disponible

IX-A-1. Construction de la colonne « Paiements »

Construisons pas à pas.

On part de la fonction de domaine SomDom()

Image non disponible

La syntaxe

 
Sélectionnez
SomDom("PaiementMt";"tPaiements")

Nous donnerait la somme de toutes les valeurs mentionnées dans la colonne « PaiementMt » de la table « tPaiements ». Nous allons construire un critère pour limiter l'addition aux enregistrements qui concernent

- le contrat mentionné ;

- dont le paiement est intervenu au plus tard à la date mentionnée.

Image non disponible

On s'accroche ! Image non disponible

Image non disponible

Voilà pour la première condition du critère.

Image non disponible

Nous devons exprimer une seconde condition, celle relative à la période.

L'opérateur « And » reliera ces deux conditions.

Traduisons en code Image non disponible

Dans une première approche, cela devrait ressembler à

Image non disponible

Mais, comme on est de ce côté-ci d'Access, les dates doivent être au format anglo-saxon, on écrira donc :

Image non disponible

On va encore en remettre une couche : si dans le formulaire, le contrôle « FiltrePaiementDate » a la valeur Null, cela sous-entend qu'il faut tenir compte des paiements jusqu'à aujourd'hui.

En fait, la 2e condition devrait être :

Image non disponible

En d'autres mots,

  • si « FiltrePaiementDate » n'est pas Null, il faut :
Image non disponible
  • si « FiltrePaiementDate » est Null, il faut :
Image non disponible

Pour exprimer ce choix, la fonction « IIf() » en version anglaise ou VraiFaux() en version française fera l'affaire.

Image non disponible

Construisons chaque partie :

Image non disponible
Image non disponible
Image non disponible

Vous suivez toujours ? Image non disponible

On est presque à la fin ! Le code construit à ce stade :

Image non disponible

Ce qui ramène :

Image non disponible

La colonne « Paiements » est Null, là où il n'y a pas encore eu de paiement pour le contrat.

Nous allons utiliser la fonction Nz() pour transformer en zéro la valeur Null éventuelle.

Comme ceci :

Image non disponible

Ce qui donne, cette fois :

Image non disponible

Presque ! Reste une bricole : la colonne « Paiements » est de type Texte (les montants sont cadrés à gauche). Un p'tit coup de Cdbl() et c'est OK :

Image non disponible
Image non disponible

De vous à moi, quand on a un peu l'habitude, cela va beaucoup plus vite pour le faire que pour l'expliquer !

IX-A-2. Limiter les enregistrements aux contrats qui ont des retards de paiement

Ce sont ceux dont la colonne « Prime » est supérieure à « Paiements ».

Voici comment l'exprimer

Image non disponible

IX-A-3. Autres colonnes

Elles ne sont pas de difficulté particulière.

IX-A-4. Le SQL final

 
Sélectionnez
SELECT tContrats.tContratsPK, tBureaux.Bureau, Format([DateDebut],"yyyy-mm") AS Periode, tContrats.DateDebut, tContrats.DureeMois, tContrats.Echeance, tContrats.Prime, CDbl(nz(DSum("PaiementMt","tPaiements","tContratsFK=" & [tContratsPk] & " and PaiementDate <= #" & IIf(Not IsNull([Forms]![fPaiementsEnSouffrance]![FiltrePaiementDate]),Format([Forms]![fPaiementsEnSouffrance]![FiltrePaiementDate],"mm/dd/yy"),Date()) & "#"),0)) AS Paiements, [clientNom] & " " & [ClientPrenom] AS Client, tGenres.Genre
FROM tGenres INNER JOIN (tClients INNER JOIN (tBureaux INNER JOIN tContrats ON tBureaux.tBureauxPK = tContrats.tBureauxFK) ON tClients.tClientsPK = tContrats.tClientsFK) ON tGenres.tGenresPK = tContrats.tGenresFK
WHERE (((tBureaux.Bureau) Like "*" & [Formulaires]![fPaiementsEnSouffrance]![FiltreBureau] & "*") AND ((tContrats.DateDebut)>=IIf(IsNull([Formulaires]![fPaiementsEnSouffrance]![FiltrePeriodeDu]),DMin("DateDebut","tContrats"),Format([Formulaires]![fPaiementsEnSouffrance]![FiltrePeriodeDu],"mm/dd/yy")) And (tContrats.DateDebut)<=IIf(IsNull([Formulaires]![fPaiementsEnSouffrance]![FiltrePeriodeAu]),DMax("DateDebut","tContrats"),Format([Formulaires]![fPaiementsEnSouffrance]![FiltrePeriodeAu],"mm/dd/yy"))) AND (([clientNom] & " " & [ClientPrenom]) Like "*" & [Formulaires]![fPaiementsEnSouffrance]![FiltreClient] & "*") AND ((tGenres.Genre) Like "*" & [Formulaires]![fPaiementsEnSouffrance]![FiltreGenre] & "*") AND (([Prime]>nz(DSum("PaiementMt","tPaiements","tContratsFK=" & [tContratsPk] & " and PaiementDate <= #" & IIf(Not IsNull([Forms]![fPaiementsEnSouffrance]![FiltrePaiementDate]),Format([Forms]![fPaiementsEnSouffrance]![FiltrePaiementDate],"mm/dd/yy"),Date()) & "#"),0))=True));

IX-A-5. Téléchargement

X. Modifier temporairement la date système

Ceci en relation avec cette Q/R sur le forum.

Dans un module, copiez ce code tel quel :

 
Sélectionnez
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
Option Compare Database
Option Explicit
 Global tOrigine As Double
 Global tChange As Double

Sub Changer()
  On Error GoTo GestionErreur
  Dim sNewSysDate As String
  Dim Ventil() As String
  
  If tOrigine <> 0 Then Call Restaurer
  sNewSysDate = InputBox("Introduisez la date et heure souhaitées " & vbLf _
                 & "sous la forme : jj/mm/aa hh:mm:ss", , Now)
  Ventil = Split(sNewSysDate, " ")
  If Not IsDate(Ventil(0)) Or Not IsDate(Ventil(1)) Then Call Changer
  tOrigine = Now
  Date = Ventil(0)
  Time = Ventil(1)
  tChange = Now
  Exit Sub
GestionErreur:
  Select Case Err.Number
    Case 9 'date et/ou heure incorrectes ou Null
      Call Changer
    Case Else
      MsgBox "Erreur dans Changer " & Err.Number & " " & Err.Description & " !"
  End Select
End Sub

Public Sub Restaurer()
  Dim tDuree As Double
  tDuree = Now - tChange
  Date = CDate(Fix(tOrigine + tDuree))
  Time = CDate(tOrigine + tDuree - Fix(tOrigine + tDuree))
  tOrigine = 0
  tChange = 0
End Sub

Pour modifier temporairement la date système, lancez l'instruction :

 
Sélectionnez
Call Changer

Il vient la fenêtre :

Image non disponible

La date et l'heure affichées sont celles actuellement dans votre machine.

Saisissez date et heure voulues et <ENTER>, si votre syntaxe respecte le format, les date/heure système sont modifiées. Sinon, l'invite se réaffiche et vous devez recommencer la saisie.

Quand vous souhaitez rétablir les date/heure système originales, lancez la commande

 
Sélectionnez
Call Restaurer

X-A. Explication du code

X-A-1. L'idée

- lors de la demande de changement, on mémorise l'instant juste avant le changement (anciennes date/heure), l'instant du changement (nouvelles date/heure) ;

- lors de la demande de restauration, on calcule le temps qui s'est écoulé depuis le changement, on l'ajoute à la valeur de l'instant avant changement et on rétablit ainsi l'horloge comme si rien ne s'était passé.

X-A-2. Les instructions

3 - 4 : on définit deux variables globales (elles seront donc visibles tant que la base sera ouverte)
tOrigine pour mémoriser l'instant juste avant le changement (anciennes date/heure) ;

tChange pour mémoriser l'instant juste après le changement (nouvelles date/heure) ;

Access stocke la date et l'heure sous la forme d'un nombre décimal.
La partie entière est le quantième jour depuis le 30/12/1899.
La partie décimale indique la fraction de ce jour écoulée depuis le matin, 0 heure.

6-28 : routine Changer()

9 : la variable Ventil est un tableau qui servira de réceptacle quand nous utiliserons la fonction Split().

11 : l'utilisateur pourrait lancer la commande Changer à plusieurs reprises dans une même session.
Le fait que la variable tOrigine ne soit plus à zéro (sa valeur initiale) permet de détecter cette situation.

Dans ce cas, avant de poursuivre, le programme appelle la routine Restaurer qui rétablira l'heure ancienne actualisée (description plus bas du mécanisme de cette routine).

12-13 : l'utilisateur est invité à compléter une boîte de dialogue avec la date et l'heure désirées comme nouvelles date/heure système.

14 : on utilise la fonction Split pour scinder le bloc en ses deux morceaux séparés par le caractère « espace » :fleche: Ventil(0) contient la date, Ventil(1) contient l'heure.

15 : on vérifie que ces deux morceaux ont effectivement une structure de type Date et si Non, on appelle la fonction elle-même, ce qui revient à réafficher une nouvelle invite.

16 : on mémorise l'instant dans tOrigine. À ce stade, Now() est encore exprimé en date/heure « anciennes ».

17-18 : on ajuste les date/heure système.

19 : on mémorise l'instant, maintenant exprimé en nouvelles date/heure dans tChange.

21-27 : si l'utilisateur a introduit une valeur Null dans l'invite, une erreur N° 9 est levée à l'instruction 14

Image non disponible

si cette erreur survient, on appelle la fonction elle-même, ce qui revient à réafficher une nouvelle invite.

30-37 routine Restaurer()

32 : on mémorise dans tDuree le temps qui s'est écoulé depuis qu'on a changé les date/heure système.

33-34 : tOrigine + tDuree correspond donc à la valeur qu'aurait eu Now() si on n'avait pas modifié les date/heure système. On affecte à Date la partie entière de cette somme et à Time la partie décimale.

Les date/heure anciennes sont à nouveau d'actualité.

X-B. Téléchargement

Une BdD avec un exemple se trouve ici.

XI. Décomposer un stock selon les dates de réception (Fifo)

Voir la question de tomtalf :

(En m'inspirant de la proposition de Vodiem.

Soit une table Historique dans laquelle sont enregistrées les entrées en magasin

Image non disponible

et une table Inventaire, qui donne l'état du stock actuel

Image non disponible

on voudrait ventiler la quantité en stock par fournisseur

Image non disponible

XI-A. Étapes du raisonnement

XI-A-1. Limiter la recherche aux produits en stock

Image non disponible
Image non disponible

XI-A-2. Ajouter une colonne avec le « cumul à rebours »

C'est-à-dire cumuler les quantités

- par produit,

- par ordre chronologique inverse 

Image non disponible
 
Sélectionnez
Cumul inversé: SomDom("Quantité";"historique";"[Produit]='" & [historique].[Produit] & "' AND [Date de réception]>= #" & Format([historique].[Date de réception];"mm/dd/yyyy") & "#")

Remarquez la syntaxe pour se référer à la date :

Image non disponible

Je dois avouer que je ne comprends pas toujours quand il est nécessaire de spécifier un format américain : c'est en testant le résultat que je réagis… à tâtons !

On obtient ceci 

Image non disponible

XI-A-3. Déterminer « ce qui reste à trouver » si on prend la ligne

En d'autres mots : si on retire la quantité encore en stock, que manque-t-il encore si on prend cette ligne ?

Image non disponible

il vient

Image non disponible

XI-A-4. Déterminer la partie encore en stock

Que constate-t-on à l'examen de R03 ?

Si le « Reste à trouver » est >= zéro, la quantité de cette ligne est à considérer.

Si le « Reste à trouver » est <0, il faut prendre, dans cette livraison, la quantité qui constitue le complément positif aux livraisons déjà considérées.

Pour le produit A : 50 (quantité en stock) - 0 (il n'y a pas d'achat plus récent).

Pour le produit B 31/03/14 : 100 (quantité en stock) - 30 (31/07/14) - 60 (31/05/14) =10.

Pour le produit B 01/01/14 : 100 (quantité en stock) - 30 (31/07/14) - 60 (31/05/14) - 10 (31/03/14) = 0.

Ajoutons une colonne pour calculer le complément (positif ou négatif) et retenons le positif ou zéro comme résultat final

Image non disponible
 
Sélectionnez
Complément: VraiFaux([Reste à Trouver]>=0;[Historique].[Quantité];[Inventaire].[Quantité]-nz(SomDom("Quantité";"historique";"[Produit]='" & [historique].[Produit] & "' AND [Date de réception]> #" & Format([historique].[Date de réception];"mm/dd/yyyy") & "#");0))

Qui ramène ceci :

Image non disponible

XI-A-5. Enfin

Cette requête est trop complexe pour permettre d'ajouter une clause Where pour ne ramener que les lignes ayant la colonne « Encore en stock » positive.

Nous obtiendrons le résultat comme ceci

Image non disponible
Image non disponible

XI-B. En conclusion, deux requêtes enregistrées sont nécessaires pour atteindre le résultat 

XI-B-1. rEnStockCalculs : pour préparer les données

 
Sélectionnez
SELECT historique.Produit, historique.Fournisseur, historique.[Date de réception], historique.Quantité, DSum("Quantité","historique","[Produit]='" & [historique].[Produit] & "' AND [Date de réception]>= #" & Format([historique].[Date de réception],"mm/dd/yyyy") & "#") AS [Cumul inversé], [Inventaire].[Quantité]-[Cumul inversé] AS [Reste à trouver], IIf([Reste à Trouver]>=0,[Historique].[Quantité],[Inventaire].[Quantité]-nz(DSum("Quantité","historique","[Produit]='" & [historique].[Produit] & "' AND [Date de réception]> #" & Format([historique].[Date de réception],"mm/dd/yyyy") & "#"),0)) AS Complément
FROM historique INNER JOIN inventaire ON historique.Produit = inventaire.Produit
ORDER BY historique.Produit, historique.[Date de réception] DESC;

XI-B-2. rEnStockVentil : pour afficher le résultat

 
Sélectionnez
SELECT rEnStockCalculs.Produit, rEnStockCalculs.Fournisseur, rEnStockCalculs.Complément AS [Encore en stock]
FROM rEnStockCalculs
WHERE (((rEnStockCalculs.Complément)>0));

XI-C. Téléchargement

Vous avez aimé ce tutoriel ? Alors partagez-le en cliquant sur les boutons suivants : Viadeo Twitter Facebook Share on Google+   

  

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