Quelques exemples d'utilisation d'Access2000

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

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

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

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

SELECT tJoueursPK,  NomJoueur FROM tJoueurs 
WHERE tJoueursPK Not In (0,9,3,0,0,0,0,0,0,0,0,0,) 
ORDER BY NomJoueur;

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

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

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