Quelques exemples d'utilisation d'Access2000

Plic-ploc

Claude Leloup

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

- Titre : Quelques exemples d'utilisation d'Access2000

- Auteur : Claude Leloup

- Parution : 25 mai 2013

- Mise à jour : 20 janvier 2018

- Public visé :

- Licence : 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.

Sommaire

- I. Avant-propos

- II. Un formulaire continu avec des images avec Access 2000

- II-A. Exemple

- II-B. Comment faire

- II-C. Comment s'y prendre

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

- II-E. Téléchargement

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

- III-A. L'architecture

- III-B. Comment ça marche

- III-C. Téléchargement

- IV. Déterminer les jours ouvrés

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

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

- IV-B-1. Étape 1

- IV-B-2. Étape 2

- IV-B-3. Étape 3

- IV-B-4. Étape 4

- IV-B-5. Étape 5

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

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

- IV-D-1. Un exemple d'application

- 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

- IV-E-1. Un exemple d'utilisation

- IV-F. Téléchargement

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

- V-A. Au départ

- V-B. L'idée

- V-C. Comment s'y prendre

- V-D. L'algorithme

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

- V-F. Téléchargement

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

- VI-A. Le point de départ

- VI-B. Un peu de code

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

- VI-B-2. Quelques API

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

- 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

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

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

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

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

- VIII-A. L'idée

- VIII-B. La table pour mémoriser

- VIII-C. Le code dans le module du formulaire

- VIII-D. Téléchargement

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

- IX-A. Construction de la requête rPaiementsEnSouffrance

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

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

- IX-A-3. Autres colonnes

- IX-A-4. Le SQL final

- IX-A-5. Téléchargement

- X. Modifier temporairement la date système

- X-A. Explication du code

- X-A-1. L'idée

- X-A-2. Les instructions

- X-B. Téléchargement

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

- XI-A. Étapes du raisonnement

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

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

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

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

- XI-A-5. Enfin

- 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

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

- XI-C. Téléchargement

- XII. Importer depuis Excel pour rafraîchir une table Access

- XII-A. Le contexte

- XII-B. Ce qu'on souhaite

- XII-C. L'idée

- XII-D. Première étape : créer la table tampon

- XII-D-1. On importe le fichier Excel dans la db

- XII-D-2. Examinons le résultat

- XII-E. Procédure en régime de croisière

- XII-E-1. D'abord vidanger la table Tampon

- XII-E-2. Importer le fichier Excel

- XII-E-3. Ajouter les nouveaux

- XII-E-4. Rafraîchir les données

- XII-E-5. Résultat

- XII-F. Et en un clic

- XII-G. Téléchargement

- XIII. Une routine pour vider toutes les tables de la base de données

- XIII-A. Le code

- XIII-B. Explication du code

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

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

II-B - Comment faire

D'abord copier ce code dans un module :

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

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

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 ».

- la propriété « Source contrôle » peut se construire en suivant ce raisonnement :

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.

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

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

1. Public Sub Ajout()

2. DoCmd.SetWarnings False

3. DoCmd.OpenQuery "MaJtFacItems"

4. DoCmd.SetWarnings True

5. Me.Parent.ctnrSfFacItems.Form.Requery

6. Me.Parent.Form_Current

7. End Sub

Ligne 3 : on exécute cette requête

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.

IV - Déterminer les jours ouvrés

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

Quatre tables…

… et une requête…

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

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

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.

À 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.

ce qui donne

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

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

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

et on récupère son SQL

SELECT dateFeriee FROM tJoursFeries;

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

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

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

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 >.

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

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

Dans un formulaire :

Ne pas reformater la date !

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

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.

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;

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

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

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

IV-F - Téléchargement

La db exemple se trouve ici.

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 :

Un joueur ne pourra occuper qu'une seule place.

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 :

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 :

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(IdPris_1, IdPris_2, …) 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.

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 :

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.

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

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.

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

VI-B - Un peu de code

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

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 !

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.

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

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

La db exemple se trouve ici.

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.

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

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

Voici la fonction ResteAcourir :

1. Public Function ResteACourir(DateAchat As Date, DureeEnMois As Integer) As String

2. Dim Echeance As Date

3. Dim NbreJrsRestant As Integer

4. Dim NbreAnnees As Integer

5. Dim NbreMois As Integer

6. Dim NbreJours As Integer

7. Dim JusteAvant As Date

8. 'Calcul de l'échéance

9. Echeance = DateSerial(Year(DateAchat), Month(DateAchat) + DureeEnMois, Day(DateAchat))

10. 'Traiter les dépassements de cycle

11. If Day(Echeance) > Day(DateAchat) Then Echeance = Echeance - Day(Echeance)

12. 'Nbre de jours restant à courir

13. NbreJrsRestant = Echeance - Date

14. 'Garantie caduque

15. If NbreJrsRestant <= 0 Then

16. ResteACourir = "La garantie est caduque."

17. Exit Function

18. End If

19. 'Cas banal

20. ResteACourir = NbreJrsToAnMoisJrs(NbreJrsRestant)

21. 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 :

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 :

1. Public Function NbreJrsToAnMoisJrs(NbreJrs As Integer) As String

2. Dim Ventil() As String

3. Dim DateFictive As Date

4. 'Cas particulier

5. If NbreJrs = 0 Then NbreJrsToAnMoisJrs = "Zéro année, mois et jour.": Exit Function

6. If NbreJrs < 0 Then NbreJrs = NbreJrs * -1

7. 'Cas banal

8. DateFictive = DateSerial(Year(#12/31/1999# + NbreJrs), _

9. Month(#12/31/1999# + NbreJrs), _

10. Day(#12/31/1999# + NbreJrs))

11. Ventil = Split(DateFictive, "/")

12. NbreJrsToAnMoisJrs = Int(Ventil(2)) & " année(s), " _

13. & Ventil(1) - 1 & " mois et " _

14. & Ventil(0) & " jour(s)."

15. End Function

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

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

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

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 :

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

VIII-C - Le code dans le module du formulaire

1. Option Compare Database

2. Option Explicit

3. Dim lDernierConsulte As Long

5. Private Sub Form_Current()

6. lDernierConsulte = Me.CurrentRecord

7. End Sub

9. Private Sub Form_Close()

10. DoCmd.SetWarnings False 'supprimer temporairement les messages

11. 'Ce formulaire est-il déjà dans la table ? si oui mettre à jour

12. If DCount("*", "DerniersConsultes", "NomDuFormulaire = """ _

13. & Me.Name & """") = 1 Then

14. DoCmd.RunSQL ("UPDATE DerniersConsultes " _

15. & "SET DernierConsulte = " & lDernierConsulte & " " _

16. & "WHERE NomDuFormulaire =""" & Me.Name & """;")

17. Else ' si non il faut ajouter un item dans la table

18. DoCmd.RunSQL ("INSERT INTO DerniersConsultes ( NomDuFormulaire, DernierConsulte ) " _

19. & "SELECT """ & Me.Name & """ AS Expr1, " _

20. & lDernierConsulte & " AS Expr2;")

21. DoCmd.SetWarnings True

22. End If

23. End Sub

25. Private Sub Form_Open(Cancel As Integer)

26. 'si déjà dans la table --> ouvrir au dernier, si non ne rien faire

27. If DCount("*", "DerniersConsultes", "NomDuFormulaire = """ _

28. & Me.Name & """") = 1 Then

29. DoCmd.GoToRecord acDataForm, Me.Name, acGoTo, _

30. DLookup("DernierConsulte", "DerniersConsultes", "NomDuFormulaire= """ & Me.Name & """")

31. End If

32. 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

La db exemple se trouve ici.

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

La discussion est ici.

IX-A - Construction de la requête rPaiementsEnSouffrance

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.

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

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

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

Construisons pas à pas.

On part de la fonction de domaine SomDom()

La syntaxe

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.

On s'accroche !

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

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

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

Traduisons en code

Dans une première approche, cela devrait ressembler à

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

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 :

En d'autres mots,

- si « FiltrePaiementDate » n'est pas Null, il faut :

- si « FiltrePaiementDate » est Null, il faut :

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

Construisons chaque partie :

Vous suivez toujours ?

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

Ce qui ramène :

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 :

Ce qui donne, cette fois :

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 :

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

IX-A-3 - Autres colonnes

Elles ne sont pas de difficulté particulière.

IX-A-4 - Le SQL final

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

La BdD se trouve ici.

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 :

1. Option Compare Database

2. Option Explicit

3. Global tOrigine As Double

4. Global tChange As Double

6. Sub Changer()

7. On Error GoTo GestionErreur

8. Dim sNewSysDate As String

9. Dim Ventil() As String

11. If tOrigine <> 0 Then Call Restaurer

12. sNewSysDate = InputBox("Introduisez la date et heure souhaitées " & vbLf _

13. & "sous la forme : jj/mm/aa hh:mm:ss", , Now)

14. Ventil = Split(sNewSysDate, " ")

15. If Not IsDate(Ventil(0)) Or Not IsDate(Ventil(1)) Then Call Changer

16. tOrigine = Now

17. Date = Ventil(0)

18. Time = Ventil(1)

19. tChange = Now

20. Exit Sub

21. GestionErreur:

22. Select Case Err.Number

23. Case 9 'date et/ou heure incorrectes ou Null

24. Call Changer

25. Case Else

26. MsgBox "Erreur dans Changer " & Err.Number & " " & Err.Description & " !"

27. End Select

28. End Sub

30. Public Sub Restaurer()

31. Dim tDuree As Double

32. tDuree = Now - tChange

33. Date = CDate(Fix(tOrigine + tDuree))

34. Time = CDate(tOrigine + tDuree - Fix(tOrigine + tDuree))

35. tOrigine = 0

36. tChange = 0

37. End Sub

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

Call Changer

Il vient la fenêtre :

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

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

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é.

Attention, ce programme doit être exécuté avec les droits Administrateur.

Pour Windows 10, la procédure pour activer le compte "Administrateur caché" est décrite ici.

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

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

on voudrait ventiler la quantité en stock par fournisseur

XI-A - Étapes du raisonnement

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

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

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

- par produit,

- par ordre chronologique inverse

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 :

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

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 ?

il vient

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

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 :

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

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

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

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

XI-C - Téléchargement

La BdD en version Access2000 se trouve ici

XII - Importer depuis Excel pour rafraîchir une table Access

Ceci en relation avec cette question sur le forum.

XII-A - Le contexte

Dans la base, nous avons une table :

Dans le même répertoire que la db, un fichier Excel :

Remarquez que les entêtes de colonne correspondent aux noms de colonne dans la table. Toutefois, cette dernière contient une colonne supplémentaire : « Commentaire ».

XII-B - Ce qu'on souhaite

En un clic, rafraîchir les données de la table en fonction du contenu du fichier Excel. En d'autres mots : ajouter dans la table les données des nouveaux clients et, pour les clients déjà connus, actualiser le contenu des colonnes.

XII-C - L'idée

- Importer les données Excel dans une table tampon.

- Ajouter les nouveaux éventuels dans la table cible.

- Remplacer le contenu des colonnes de la table cible par celui de la table tampon.

XII-D - Première étape : créer la table tampon

XII-D-1 - On importe le fichier Excel dans la db

XII-D-2 - Examinons le résultat

Access a cru bien faire d'ajouter une colonne « Numéro ». Elle ne nous est pas utile, on la supprime et on rebaptise la « Feuil1 » en « Tampon ».

Il vient :

XII-E - Procédure en régime de croisière

XII-E-1 - D'abord vidanger la table Tampon

XII-E-2 - Importer le fichier Excel

'Importer Excel dans Tampon
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, "Tampon", _
CurrentProject.Path & "\FichierExcel.xls", True

XII-E-3 - Ajouter les nouveaux

À l'exécution, viennent ces deux massages :

Le premier annonce l'ajout des 16 lignes de Tampon (en fait les 16 lignes du fichier Excel).

Et le second informe que sur les 16, 11 ont été rejetées, car elles constituaient des doublons => les 11 enregistrements déjà dans TablePrincipale sont donc restés intacts !

À ce stade, TablePrincipale contient 16 enregistrements et dans les 5 nouveaux, la colonne « Commentaire » est bien sûr vierge :

XII-E-4 - Rafraîchir les données

XII-E-5 - Résultat

XII-F - Et en un clic

Code associé au bouton :

Option Compare Database
Option Explicit

Private Sub BtMaJ_Click()
DoCmd.SetWarnings False
'Vidanger Tampon
DoCmd.OpenQuery "rVidange"
'Importer Excel dans Tampon
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, "Tampon", _
CurrentProject.Path & "\FichierExcel.xls", True
'Ajouter les nouveaux éventuels dans TablePrincipale
DoCmd.OpenQuery "rAjoutNouveaux"
'Mettre à jour
DoCmd.OpenQuery "rMaJ"
DoCmd.SetWarnings True
End Sub

XII-G - Téléchargement

La BdD en version Access2000 se trouve ici.

XIII - Une routine pour vider toutes les tables de la base de données

En réponse à cette question posée sur le forum.

Cette routine est générique : elle vide toutes les tables de la base, quel que soit leur nom !

La base doit contenir au moins une table et aucune table ne peut être utilisée au moment de l'exécution de la routine.

N.B. Il faut être sûr de son coup. Prendre d'abord une copie de la base, au cas où on regretterait !

Il suffit de copier/coller le code proposé dans un module.
Placer le curseur à l'intérieur du code et <F5>. C'est fait !

Si en plus, vous voulez réinitialiser les compteurs « NuméroAuto », il faut ensuite compacter la base.

XIII-A - Le code

1. Option Compare Database

2. Option Explicit

4. Public Sub RaZTables()

5. Dim oTable As DAO.TableDef

6. Dim bContinue As Boolean

7. DoCmd.SetWarnings False

8. bContinue = True

9. Do While bContinue = True

10. bContinue = False

11. For Each oTable In CurrentDb.TableDefs

12. If Left(oTable.Name, 4) <> "MSys" Then DoCmd.RunSQL "DELETE * from " & oTable.Name & ";"

13. If Left(oTable.Name, 4) <> "MSys" And oTable.RecordCount <> 0 Then bContinue = True

14. Next oTable

15. Loop

16. DoCmd.SetWarnings True

17. End Sub

XIII-B - Explication du code

N° ligne

Commentaires

5

On définit une variable de type objet.
N.B. La bibliothèque « Microsoft DAO […] Object Library» doit donc être assignée :

6

On définit une variable booléenne qui servira de point test pour détecter s'il reste des tables à vider.
La valeur True lui est assignée à l'instruction N° 8.

7

On occulte temporairement les messages d'avertissement. Sinon pour chaque table, on aurait à répondre à ceci :

On rétablit les messages, en fin de procédure (N° 16).

De 9 à 15

On déclenche une boucle qui s'arrêtera lorsque bContinue sera à False.

10

D'emblée, on positionne bContinue à False => en principe, la boucle n'aura qu'un cycle.

De 11 à 14

On demande à Access d'explorer, une à une, toutes les tables contenues dans la base.

12

En clair : s'il ne s'agit pas d'une table système (If Left(oTable.Name, 4) <> "MSys"), alors supprimez ce qu'elle contient (DoCmd.RunSQL "DELETE * from " & oTable.Name & ";")

13

En clair : si ce n'est pas une table système et qu'elle n'est pas vide (oTable.RecordCount <> 0) après l'instruction 12, alors positionnez cContinue à True (bContinue = True).

Que s'est-il passé ? Cette table contient des éléments qui interviennent dans une relation avec contrôle de l'intégrité référentielle et la table dépendante n'a pas encore été vidée.
(L'ordre de lecture est aléatoire.)
Le fait de positionner bContinue à True provoquera l'exécution d'un nouveau cycle de la boucle (la table dépendante aura été vidée entretemps).