Const MAX_IP = 5   ' --créer un buffer ... je pense pas que vous en ayez plus de 5
Type IPINFO
     dwAddr As Long   ' -- adresse IP
    dwIndex As Long 
    dwMask As Long 
    dwBCastAddr As Long 
    dwReasmSize  As Long 
    unused1 As Integer 
    unused2 As Integer 
End Type
Type MIB_IPADDRTABLE
    dEntrys As Long   
    mIPInfo(MAX_IP) As IPINFO 
End Type
Type IP_Array
    mBuffer As MIB_IPADDRTABLE
    BufferLen As Long
End Type
Public Declare Sub CopyMemory Lib "kernel32" Alias _
     "RtlMoveMemory" (destination As Any, Source As Any, ByVal Length As Long)
Public Declare Function GetIpAddrTable Lib "IPHlpApi"  _
     (pIPAdrTable As Byte, pdwSize As Long, ByVal Sort As Long) As Long

  ' --convertion d'un Long vers un string
Public Function ConvertAddressToString(longAddr As Long) As String
    Dim myByte(3) As Byte
    Dim Cnt As Long
    CopyMemory myByte(0), longAddr, 4
    For Cnt = 0 To 3
        ConvertAddressToString = ConvertAddressToString + CStr(myByte(Cnt)) + "."
    Next Cnt
    ConvertAddressToString = Left$(ConvertAddressToString, Len(ConvertAddressToString) - 1)
End Function

' --Déterminer l'adresse IP
Public Function Get_IP_Click() As String
Dim Ret As Long, Tel As Long
Dim bBytes() As Byte
Dim TempList() As String
Dim TempIP As String
Dim Tempi As Long
Dim Listing As MIB_IPADDRTABLE
Dim L3 As String
On Error GoTo END1
    GetIpAddrTable ByVal 0&, Ret, True
    If Ret <= 0 Then Exit Function
    ReDim bBytes(0 To Ret - 1) As Byte
    ReDim TempList(0 To Ret - 1) As String
    GetIpAddrTable bBytes(0), Ret, False
    CopyMemory Listing.dEntrys, bBytes(0), 4
    For Tel = 0 To Listing.dEntrys - 1
        CopyMemory Listing.mIPInfo(Tel), bBytes(4 + (Tel * Len(Listing.mIPInfo(0)))),  _
                Len(Listing.mIPInfo(Tel))
        TempList(Tel) = ConvertAddressToString(Listing.mIPInfo(Tel).dwAddr)
    Next Tel
        TempIP = TempList(0)
        For Tempi = 0 To Listing.dEntrys - 1
            L3 = Left(TempList(Tempi), 3)
            If L3 <> "169" And L3 <> "127" And L3 <> "192" Then
                TempIP = TempList(Tempi)
            End If
        Next Tempi
        GetWanIP = TempIP 'Return The TempIP
Exit Function
END1:
GetWanIP = ""
End Function

Private Type MEMORYSTATUS
    dwLength As Long
    dwMemoryLoad As Long
    dwTotalPhys As Long
    dwAvailPhys As Long
    dwTotalPageFile As Long
    dwAvailPageFile As Long
    dwTotalVirtual As Long
    dwAvailVirtual As Long
End Type
Private Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MEMORYSTATUS)

Sub memoireinfo()
    Dim MemStat As MEMORYSTATUS
    GlobalMemoryStatus MemStat
    MsgBox "Vous avez " & (MemStat.dwTotalPhys / 1024) / 1024 & " Mo de RAM"
    MsgBox "Vous avez "  & (MemStat.dwAvailPhys / 1024) / 1024 & " Mo de RAM disponible"
End Sub

Private Const MAX_COMPUTERNAME_LENGTH As Long = 31
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" _
(ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function GetUserName Lib "advapi32.dll" Alias _
         "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

  '--Déterminer le nom de la machine
Private Function recherche_name() As String
Dim dwLen As Long
Dim strString As String
Dim strUserName As String
    dwLen = MAX_COMPUTERNAME_LENGTH + 1
    strString = String(dwLen, "X")
    strUserName = String(100, Chr$(0))
    GetComputerName strString, dwLen
    GetUserName strUserName, 100
    strUserName = Left$(strUserName, InStr(strUserName, Chr$(0)) - 1)
txt_ip.Value = strUserName
    strString = Left(strString, dwLen)
    recherche_name = strString
End Function

Dim strComputerName As String 
Dim strUserName As String 
strComputerName = Environ("COMPUTERNAME") 
strUserName  = Environ("USERNAME") 

Private Declare Sub GetSystemInfo Lib "kernel32" (lpSystemInfo As SYSTEM_INFO)
Private Type SYSTEM_INFO
    dwOemID As Long
    dwPageSize As Long
    lpMinimumApplicationAddress As Long
    lpMaximumApplicationAddress As Long
    dwActiveProcessorMask As Long
    dwNumberOrfProcessors As Long
    dwProcessorType As Long
    dwAllocationGranularity As Long
    dwReserved As Long
End Type

Private Sub getsysinfo()
    Dim SInfo As SYSTEM_INFO
    GetSystemInfo SInfo
    MsgBox "Processeur de type " & str$(SInfo.dwProcessorType)
End Sub

Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
 
Sub OpenDB()

Dim db As Database
Dim appAccess As Access.Application
Const csts = "D:\Mes documents\BaseTests.mdb"
 
 
    keybd_event vbKeyShift, 0, 0, 0 'Enfonce la touche SHift
    Set appAccess = New Access.Application
    appAccess.Visible = True
    appAccess.OpenCurrentDatabase csts
    appAccess.DoCmd.OpenForm "MonForm"
    keybd_event vbKeyShift, 0, 2, 0 'libère la touche SHift

End Sub

Option Explicit
 
' Déclarations pour GetRemoteMACAddress
Private Declare Function inet_addr Lib "WSOCK32.DLL" _
  (ByVal s As String) As Long
Private Declare Function SendARP Lib "iphlpapi.dll" _
  (ByVal DestIP As Long, _
   ByVal SrcIP As Long, _
   pMacAddr As Long, _
   PhyAddrLen As Long) As Long
Private Declare Sub CopyMemory Lib "KERNEL32" _
   Alias "RtlMoveMemory" _
  (dst As Any, _
   src As Any, _
   ByVal bcount As Long)
' Déclarations pour LetterToUNC
Private Const RESOURCETYPE_ANY = &H0
Private Const RESOURCE_CONNECTED = &H1
 
Private Type NETRESOURCE
   dwScope As Long
   dwType As Long
   dwDisplayType As Long
   dwUsage As Long
   lpLocalName As Long
   lpRemoteName As Long
   lpComment As Long
   lpProvider As Long
End Type
Private Declare Function WNetOpenEnum Lib "mpr.dll" Alias _
   "WNetOpenEnumA" (ByVal dwScope As Long, ByVal dwType As Long, _
   ByVal dwUsage As Long, lpNetResource As Any, lphEnum As Long) _
   As Long
Private Declare Function WNetEnumResource Lib "mpr.dll" Alias _
   "WNetEnumResourceA" (ByVal hEnum As Long, lpcCount As Long, _
   lpBuffer As Any, lpBufferSize As Long) As Long
Private Declare Function WNetCloseEnum Lib "mpr.dll" ( _
   ByVal hEnum As Long) As Long
Private Declare Function lstrlen Lib "KERNEL32" Alias "lstrlenA" _
   (ByVal lpString As Any) As Long
Private Declare Function lstrcpy Lib "KERNEL32" Alias "lstrcpyA" _
   (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
 
' Déclarations pour LetterToUNC
Private Const WS_VERSION_REQD = &H101
Private Const WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF&
Private Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF&
Private Const MIN_SOCKETS_REQD = 1
Private Const SOCKET_ERROR = -1
Private Const WSADescription_Len = 256
Private Const WSASYS_Status_Len = 128
 
Private Type HOSTENT
    hName As Long
    hAliases As Long
    hAddrType As Integer
    hLength As Integer
    hAddrList As Long
End Type
 
Private Type WSADATA
    wversion As Integer
    wHighVersion As Integer
    szDescription(0 To WSADescription_Len) As Byte
    szSystemStatus(0 To WSASYS_Status_Len) As Byte
    iMaxSockets As Integer
    iMaxUdpDg As Integer
    lpszVendorInfo As Long
End Type
 
Private Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long
Private Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal _
wVersionRequired As Integer, lpWSAData As WSADATA) As Long
Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
 
Private Declare Function gethostname Lib "WSOCK32.DLL" (ByVal hostname$, _
ByVal HostLen As Long) As Long
Private Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal _
hostname$) As Long
Private Declare Sub RtlMoveMemory Lib "KERNEL32" (hpvDest As Any, ByVal _
hpvSource&, ByVal cbCopy&)
 
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
Public Function GetRemoteMACAddress(ByVal pIPDistante As String) As String
Dim lAddr As Long
Dim lMacAddr As Long
Dim lMacAddrByte() As Byte
Dim lPhyAddrLen As Long
Dim lCpt As Integer
' Transforme l'adresse IP texte en adresse IP numérique
lAddr = inet_addr(pIPDistante)
If lAddr <> -1 Then
    ' Taille d'une adresse MAC = 6
    lPhyAddrLen = 6
    ' Recherche l'adresse MAC distante
    If SendARP(lAddr, 0&, lMacAddr, lPhyAddrLen) = 0 Then
        If (lMacAddr <> 0) And (lPhyAddrLen <> 0) Then
            ' Tableau de byte qui contiendra l'adresse MAC
            ReDim lMacAddrByte(0 To lPhyAddrLen - 1)
            ' Copy l'adresse MAC dans le tableau (lMacAddr est une adresse mémoire)
            CopyMemory lMacAddrByte(0), lMacAddr, ByVal lPhyAddrLen
            ' Converti l'adresse MAC en texte
            GetRemoteMACAddress = ""
            For lCpt = LBound(lMacAddrByte) To UBound(lMacAddrByte)
                GetRemoteMACAddress = GetRemoteMACAddress & Right("00" & Hex(lMacAddrByte(lCpt)), 2) & IIf(lCpt = UBound(lMacAddrByte), "", "-")
            Next
        End If
    End If
End If
End Function
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
 
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
' Source KB Microsoft : http://support.microsoft.com/kb/192689/fr
Public Function LetterToUNC(DriveLetter As String) As String
Dim hEnum As Long
Dim NetInfo(1023) As NETRESOURCE
Dim entries As Long
Dim nStatus As Long
Dim LocalName As String
Dim UNCName As String
Dim i As Long
Dim r As Long
 
' Begin the enumeration
nStatus = WNetOpenEnum(RESOURCE_CONNECTED, RESOURCETYPE_ANY, _
   0&, ByVal 0&, hEnum)
 
LetterToUNC = "Drive Letter Not Found"
 
'Check for success from open enum
If ((nStatus = 0) And (hEnum <> 0)) Then
   ' Set number of entries
   entries = 1024
 
   ' Enumerate the resource
   nStatus = WNetEnumResource(hEnum, entries, NetInfo(0), _
      CLng(Len(NetInfo(0))) * 1024)
 
   ' Check for success
   If nStatus = 0 Then
      For i = 0 To entries - 1
         ' Get the local name
         LocalName = ""
         If NetInfo(i).lpLocalName <> 0 Then
            LocalName = Space(lstrlen(NetInfo(i).lpLocalName) + 1)
            r = lstrcpy(LocalName, NetInfo(i).lpLocalName)
         End If
 
         ' Strip null character from end
         If Len(LocalName) <> 0 Then
            LocalName = Left(LocalName, (Len(LocalName) - 1))
         End If
 
         If UCase$(LocalName) = UCase$(DriveLetter) Then
            ' Get the remote name
            UNCName = ""
            If NetInfo(i).lpRemoteName <> 0 Then
               UNCName = Space(lstrlen(NetInfo(i).lpRemoteName) _
                  + 1)
               r = lstrcpy(UNCName, NetInfo(i).lpRemoteName)
            End If
 
            ' Strip null character from end
            If Len(UNCName) <> 0 Then
               UNCName = Left(UNCName, (Len(UNCName) _
                  - 1))
            End If
 
            ' Return the UNC path to drive
            LetterToUNC = UNCName
 
            ' Exit the loop
            Exit For
         End If
      Next i
   End If
End If
 
' End enumeration
nStatus = WNetCloseEnum(hEnum)
End Function
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
 
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
' Source KB Microsoft : http://support.microsoft.com/kb/160215/fr
Private Function hibyte(ByVal wParam As Integer)
    hibyte = wParam \ &H100 And &HFF&
End Function
 
Private Function lobyte(ByVal wParam As Integer)
    lobyte = wParam And &HFF&
End Function
 
Private Sub SocketsInitialize()
Dim WSAD As WSADATA
Dim iReturn As Integer
Dim sLowByte As String, sHighByte As String, sMsg As String
    iReturn = WSAStartup(WS_VERSION_REQD, WSAD)
    If iReturn <> 0 Then
        MsgBox "Winsock.dll is not responding."
        End
    End If
    If lobyte(WSAD.wversion) < WS_VERSION_MAJOR Or (lobyte(WSAD.wversion) = _
        WS_VERSION_MAJOR And hibyte(WSAD.wversion) < WS_VERSION_MINOR) Then
        sHighByte = Trim$(Str$(hibyte(WSAD.wversion)))
        sLowByte = Trim$(Str$(lobyte(WSAD.wversion)))
        sMsg = "Windows Sockets version " & sLowByte & "." & sHighByte
        sMsg = sMsg & " is not supported by winsock.dll "
        MsgBox sMsg
        End
    End If
    'iMaxSockets is not used in winsock 2. So the following check is only
    'necessary for winsock 1. If winsock 2 is requested,
    'the following check can be skipped.
    If WSAD.iMaxSockets < MIN_SOCKETS_REQD Then
        sMsg = "This application requires a minimum of "
        sMsg = sMsg & Trim$(Str$(MIN_SOCKETS_REQD)) & " supported sockets."
        MsgBox sMsg
        End
    End If
End Sub
 
Private Sub SocketsCleanup()
Dim lReturn As Long
    lReturn = WSACleanup()
    If lReturn <> 0 Then
        MsgBox "Socket error " & Trim$(Str$(lReturn)) & " occurred in Cleanup "
        End
    End If
End Sub
 
Public Function GetIpFromHost(ByVal pHostName As String) As Variant
Dim hostname As String * 256
Dim hostent_addr As Long
Dim host As HOSTENT
Dim hostip_addr As Long
Dim temp_ip_address() As Byte
Dim i As Integer
Dim ip_address As String
Dim lCpt As Integer
Dim lResult() As String
On Error GoTo Gestion_Erreurs
    SocketsInitialize
    ' Retire le double \
    If Left(pHostName, 2) = "\\" Then
        pHostName = Right(pHostName, Len(pHostName) - 2)
    End If
    ' Retire un éventuel chemin
    If InStr(pHostName, "\") > 0 Then
        pHostName = Left(pHostName, InStr(pHostName, "\") - 1)
    End If
    hostname = Trim$(pHostName & vbNullChar)
    hostent_addr = gethostbyname(hostname)
    If hostent_addr = 0 Then
        MsgBox "Winsock.dll is not responding."
        Exit Function
    End If
    RtlMoveMemory host, hostent_addr, LenB(host)
    RtlMoveMemory hostip_addr, host.hAddrList, 4
    'get all of the IP address if machine is  multi-homed
    lCpt = 0
    Do
        ReDim temp_ip_address(1 To host.hLength)
        RtlMoveMemory temp_ip_address(1), hostip_addr, host.hLength
 
        For i = 1 To host.hLength
            ip_address = ip_address & temp_ip_address(i) & "."
        Next
        ip_address = Mid$(ip_address, 1, Len(ip_address) - 1)
 
        ReDim lResult(lCpt)
        lResult(lCpt) = ip_address
        lCpt = lCpt + 1
        ip_address = ""
        host.hAddrList = host.hAddrList + LenB(host.hAddrList)
        RtlMoveMemory hostip_addr, host.hAddrList, 4
     Loop While (hostip_addr <> 0)
Gestion_Erreurs:
    SocketsCleanup
    GetIpFromHost = lResult
End Function
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------

Option Explicit
 
Private Declare Function GetDesktopWindow Lib "user32" () As Long
 
Private Declare Function GetWindow Lib "user32" _
  (ByVal hWnd As Long, _
   ByVal wCmd As Long) As Long
 
Private Declare Function GetWindowText Lib "user32" _
   Alias "GetWindowTextA" _
  (ByVal hWnd As Long, _
   ByVal lpString As String, _
   ByVal cch As Long) As Long
 
Private Declare Function GetClassName Lib "user32" _
   Alias "GetClassNameA" _
  (ByVal hWnd As Long, _
   ByVal lpClassName As String, _
   ByVal nMaxCount As Long) As Long
 
Private Const GW_HWNDFIRST = 0
Private Const GW_HWNDLAST = 1
Private Const GW_HWNDNEXT = 2
Private Const GW_HWNDPREV = 3
Private Const GW_OWNER = 4
Private Const GW_CHILD = 5
 
Public Function GetWdwLike(ByVal hWndStart As Long, _
                                WindowText As String, _
                                Classname As String) As Long
 
   Dim hWnd As Long
   Dim sWindowText As String
   Dim sClassname As String
   Dim r As Long
  
  'niveau de récursion
   Static level As Integer
  
  
  ' initialisation du handle de départ et du niveau de récursion
   If level = 0 Then
      If hWndStart = 0 Then hWndStart = GetDesktopWindow()
   End If
  
  ' itération du niveau récursif
   level = level + 1
  
  ' on trouve le premier window
   hWnd = GetWindow(hWndStart, GW_CHILD)
 
   Do Until hWnd = 0
      
     'recherche récursive
      Call GetWdwLike(hWnd, WindowText, Classname)
      
     ' on obtient la classe et le text du window
      sWindowText = Space$(255)
      r = GetWindowText(hWnd, sWindowText, 255)
      sWindowText = Left(sWindowText, r)
        
      sClassname = Space$(255)
      r = GetClassName(hWnd, sClassname, 255)
      sClassname = Left(sClassname, r)
              
     ' on vérifie que c'est conforme à la recherche
      If (sWindowText Like WindowText) And _
         (sClassname Like Classname) Then
                GetWdwLike = hWnd
      End If
    
     'window suivant
      hWnd = GetWindow(hWnd, GW_HWNDNEXT)
  
   Loop
 
  'Reduce the recursion counter
   level = level - 1
 
End Function
 
 
Public Function GetCalcResult() As Double
 
Dim CalchWnd As Long, ReshWnd As Long
Dim sTxt As String, r As String
 
On Error Resume Next
 
CalchWnd = GetWdwLike(0, "*", "SciCalc")
ReshWnd = GetWdwLike(CalchWnd, "*.*", "Static")
 
sTxt = Space$(255)
r = GetWindowText(ReshWnd, sTxt, 255)
GetCalcResult = CDbl(Left(sTxt, r))
 
End Function

Private Declare Function FoldString Lib "kernel32.dll" Alias _
        "FoldStringA" (ByVal dwMapFlags As Long, ByVal lpSrcStr As Long, _
        ByVal cchSrc As Long, ByVal lpDestStr As Long, ByVal cchdest As Long) As Long
 
Function OteAccents(ByVal str As String) As String
 
    Dim i As Integer
    OteAccents = Space(Len(str))
    
    For i = 0 To (Len(str) - 1) * 2 Step 2
        FoldString &H40, StrPtr(str) + i, 1, StrPtr(OteAccents) + i, 1
    Next i
 
End Function

' Déclarations
Const WM_SYSCOMMAND As Long = &H112

Const SC_MINIMIZE As Long = &HF020&
Const SC_MAXIMIZE As Long = &HF030&
Const SC_RESTORE As Long = &HF120&

Private Declare Function PostMessage Lib "User32.dll" Alias "PostMessageA" ( _
ByVal hwnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private Declare Function FindWindow1 Lib "User32.dll" Alias "FindWindowA" ( _
ByVal lpClassName As Long, ByVal lpWindowName As String) As Long

Function AppMinimize(AppTitle As String) As Boolean
Dim hwnd As Long
hwnd = FindWindow1(0, AppTitle & vbNullChar)
If hwnd <> 0 Then
PostMessage hwnd, WM_SYSCOMMAND, SC_MINIMIZE, 0
AppMinimize = True
Else
AppMinimize = False ' Fenêtre pas trouvée
End If
End Function

Sub quicktest()
Dim AppTitle As String, tmr As Long

AppTitle = "Sans titre - Bloc-Notes"
AppActivate AppTitle
tmr = Timer
While ((Timer - tmr) < 2)
Wend
AppMinimize AppTitle

End Sub

Private Declare Function OleTranslateColor Lib "olepro32.dll" _
          (ByVal OLE_COLOR As Long, ByVal hPalette As Long, pccolorref As Long) As Long
 
'---------------------------------------------------------------------------------------
' Récupère la couleur système si nécessaire
'---------------------------------------------------------------------------------------
' pColor     : Numéro de la couleur
' Les couleurs définies par défaut dans Access sont souvent des couleurs systèmes
' Par exemple la couleur le fond d'un formulaire par défaut est -2147483633
' il faut retrouver la couleur définie dans le système pour cette valeur
' Renvoie la couleur dans un Long
'---------------------------------------------------------------------------------------
Private Function GetColor(pColor As Long) As Long
    If pColor < 0 Then
        Call OleTranslateColor(pColor, 0, pColor)
    End If
    GetColor = pColor
End Function
 
'---------------------------------------------------------------------------------------
' Conversion code couleur Long vers RGB
'---------------------------------------------------------------------------------------
' pLong     : Numéro de la couleur
' pRed      : Composante Rouge
' pGreen    : Composante Verte
' pBlue     : Composante Bleue
'---------------------------------------------------------------------------------------
Public Function LongToRGB(ByVal pLong As Long, pRed As Long, pGreen As Long, pBlue As Long) As Boolean
' On récupère la couleur système si nécessaire
    pLong = GetColor(pLong)
    On Error GoTo Gestion_Erreurs:
    pBlue = Int(pLong / 65536)
    pGreen = Int((pLong - (65536 * pBlue)) / 256)
    pRed = pLong - ((pBlue * 65536) + (pGreen * 256))
Gestion_Erreurs:
    If Err.Number = 0 Then LongToRGB = True    ' Renvoie Vrai si pas d'erreur
End Function

' Vérifier l'Etat d'une touche
Const VK_LSHIFT As Long = &HA0
Const VK_RSHIFT As Long = &HA1
Private Declare Function GetKeyState Lib "user32.dll" (ByVal nVirtKey As Integer) As Byte
 
Public Function IsShiftKeyDown() As Boolean
IsShiftKeyDown = False
If (GetKeyState(VK_LSHIFT) And &H80) = &H80 Then IsShiftKeyDown = True
If (GetKeyState(VK_RSHIFT) And &H80) = &H80 Then IsShiftKeyDown = True
End Function

Public Function Init()
If IsShiftKeyDown Then
   If InputBox("Mot de Passe ") = "123" Then
      ' Le mot de passe est valide
      ...
   End If
End If
End Function

Action : ExécuterCode                 Nom fonction : Init()

'Dans la section déclaration
Public Const SW_MINIMIZE = 6
Public Type POINTAPI
        x As Long
        y As Long
End Type
Public Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type
Public Type WINDOWPLACEMENT
        Length As Long
        flags As Long
        showCmd As Long
        ptMinPosition As POINTAPI
        ptMaxPosition As POINTAPI
        rcNormalPosition As RECT
End Type
 
Public Declare Function SetWindowPlacement Lib "user32" (ByVal hwnd As Long, lpwndpl As WINDOWPLACEMENT) As Long
Dim Rectan As RECT
 
'La procédure
Sub Reduire()
    'Réduire la fenêtre active dans la fenêtre d'Access
    DoCmd.Minimize
    
    'Réduire la fenêtre d'Access
    Dim WinEst As WINDOWPLACEMENT
    Dim Punto As POINTAPI
    Dim rtn As Long
    Punto.x = 100
    Punto.y = 100
    'initialize the structure
    WinEst.Length = Len(WinEst)
    WinEst.showCmd = SW_MINIMIZE
    WinEst.ptMinPosition = Punto
    WinEst.ptMaxPosition = Punto
    WinEst.rcNormalPosition = Rectan
    'La réduction effective se fait ici
    rtn = SetWindowPlacement(Application.hWndAccessApp, WinEst)
End Sub