Dim strCheminRaccourci As String
Dim oWsh As New WshShell
Dim oRac As WshShortcut
'Récupère le chemin du bureau et le concatène avec le nom du raccourci
strCheminRaccourci = oWsh.SpecialFolders("Desktop") & "\Fichier.lnk"
'Crée un nouveau raccourci
Set oRac = oWsh.CreateShortcut(strCheminRaccourci)

'Paramètre le raccourci
With oRac
    'Cible
    .TargetPath = Chr(34) & "C:\Program Files\Microsoft Office\Office\MSACCESS.EXE" & Chr(34)
    'Argument
    .Arguments = "D:\mabase.mdb /wrkgrp d:\system.mdw"
    'Style de fenêtre
    .WindowStyle = 4
    'Chemin vers l'icône
    .IconLocation = "d:\monicone.ico"
    'Dossier de travail
    .WorkingDirectory = "D:\"
    'Enregistre le raccourci
    .Save
End With
'Libère les objets
Set oRac = Nothing
Set oWsh = Nothing

Sub tesjdn() 
Dim textemsg As String 

textemsg = "coucou" & "<br>" & "TEST3" 
DoCmd.SendObject , , acFormatTXT, "toto@aol.com", , , "titre", textemsg, True 
End Sub

mabarre.min = 0 
mabarre.max = 100 
i=1 
While i <= 100 
     mabarre.value = i 
     i=i+1 
Wend 

Syscmd acSysCmdInitMeter,"Text à afficher", 100 'Définit le texte à afficher et la valeur maximale de la jauge.
Syscmd acSysCmdUpdateMeter, 50 'Définit le texte à afficher et la valeur actuelle de la jauge.
Syscmd acSysCmdRemoveMeter 'Supprime la jauge d'avancement

Function DeleteObjectExterne() 
Dim acApp As Access.Application 
Set acApp = GetObject("toto.mbd") 
acApp.DoCmd.DeleteObject acForm, "nom_form" 
acApp.Quit 
Set acApp = Nothing 
End Function

Me.Undo

DoCmd.Rename 

Set rs = CodeDB.Openrecordset()

Private Declare Function InternetGetConnectedState Lib "wininet.dll" _
                                                   (ByRef lpdwFlags As Long, _
                                                    ByVal dwReserved As Long) As Long

Public Function ConnexionInternetActive() As Boolean

ConnexionInternetActive = InternetGetConnectedState(0&, 0&)

End Function

CurrentDb.Name 

Application.CurrentProject.Path 

Dim bMasqué as Boolean
bMasqué = Application.GetHiddenAttribute(acQuery,"Ma Requête")

Option Compare Database

Type ParamTendance
    Pente As Double
    OrdonneeZero As Double
End Type

Public Function CalculTendance(DatDebut As Date, X As Double) As Double


Dim Rst As New ADODB.Recordset
Dim MaRequete As String
Dim NbDonnee As Integer
Dim DonneeCumul() As Double
Dim i As Integer
Dim SumX As Double
Dim SumX2 As Double
Dim SumChiffre As Double
Dim SumChiffreX As Double
Dim Type_Param As ParamTendance

MaRequete = "SELECT T.DateJour, T.ChiffreDAffaire AS Chiffre" & vbNewLine & _
            "FROM T_ChiffreDAffaire T" & vbNewLine & _
            "WHERE T.DateJour>=#" & DatDebut & "#" & vbNewLine & _
            "ORDER BY T.DateJour;"
           
Rst.Open MaRequete, CurrentProject.Connection, adOpenStatic

NbDonnee = Rst.RecordCount

If NbDonnee = 0 Then
    MsgBox "Pas de données"
    CalculTendance = 0
    Exit Function
End If

Rst.Close

ReDim DonneeCumul(1 To NbDonnee)

Rst.Open MaRequete, CurrentProject.Connection, adOpenDynamic
Rst.MoveFirst

'Calcul le cumul du chiffre d'affaire pour chaque jour

For i = 1 To NbDonnee
    If i = 1 Then
        DonneeCumul(1) = Rst("Chiffre")
    Else
        DonneeCumul(i) = Rst("Chiffre") + DonneeCumul(i - 1)
    End If
    Rst.MoveNext
Next i

Rst.Close

SumX = 0
SumX2 = 0
SumChiffre = 0
SumChiffreX = 0


For i = 1 To NbDonnee
    SumX = SumX + i
    SumX2 = SumX2 + i ^ 2
    SumChiffre = SumChiffre + DonneeCumul(i)
    SumChiffreX = SumChiffreX + DonneeCumul(i) * i
Next i

Type_Param.Pente = (NbDonnee * SumChiffreX - SumX * SumChiffre) / (NbDonnee * SumX2 - SumX ^ 2)

Type_Param.OrdonneeZero = (SumX2 * SumChiffre - SumX * SumChiffreX) / (NbDonnee * SumX2 - SumX ^ 2)

CalculTendance = Type_Param.Pente * X + Type_Param.OrdonneeZero

End Function

Public Sub ChiffreTendance18jour()
'calcul la tendance au 18ème jour
Debug.Print CalculTendance(CDate("01/01/2004"), 18)
End Sub

Option Compare Database
Option Explicit

Public LibName As String
Public GroupName As String
Public ItemName As String
Public ItemValue As Long

Property Get ClassType() As LocalClassType
    ClassType = LocalClassTypeCEnumValue
End Property

Option Compare Database
Option Explicit

Dim TLApp As TLI.TLIApplication
Dim TLInfo As TLI.TypeLibInfo
Dim Coll_TLI As Collection

Public Enum MethodType
    MethodConstant = TLI.InvokeKinds.INVOKE_CONST
    MethodEvent = TLI.InvokeKinds.INVOKE_EVENTFUNC
    MethodFunction = TLI.InvokeKinds.INVOKE_FUNC
    MethodGet = TLI.InvokeKinds.INVOKE_PROPERTYGET
    MethodLet = TLI.InvokeKinds.INVOKE_PROPERTYPUT
    MethodSet = TLI.InvokeKinds.INVOKE_PROPERTYPUTREF
    MethodSub = 0
    MethodAll = MethodConstant + MethodEvent + MethodFunction + MethodGet + MethodLet + MethodSet + MethodSub
End Enum

Public Enum MethodContext
    MethodContextNA = 0
    MethodContextReturns = 1
    MethodContextTakes = 2
    MethodContextBoth = MethodContextReturns + MethodContextTakes
End Enum

Public Enum PropertyType
    PropertyGet = TLI.InvokeKinds.INVOKE_PROPERTYGET
    PropertyLet = TLI.InvokeKinds.INVOKE_PROPERTYPUT
    PropertySet = TLI.InvokeKinds.INVOKE_PROPERTYPUTREF
    PropetyBoth = PropertyGet + PropertyLet + PropertySet
End Enum

Public Enum LocalClassType
    LocalClassTypeCEnumValue = 1
    LocalClassTypeCMethod
    LocalClassTypeCParam
End Enum

Public Function GetNameFromEnum(ByVal val As Long, _
                                ByVal strRefname As String, _
                                ByVal strEnumGroup As String) As String
Dim lngI As Long
Dim coll As Collection
Dim EnumV As CEnumValue

Set coll = EnumValues(strRefname, strEnumGroup)

For lngI = 1 To coll.count
    Set EnumV = coll(lngI)
    If EnumV.ItemValue = val Then
        GetNameFromEnum = EnumV.ItemName
    End If
Next lngI

Set coll = Nothing
Set EnumV = Nothing

End Function
                                

Public Function ListEnum(ByVal strRefname As String, _
                         ByVal strEnumGroup As String)

Dim lngI As Long
Dim coll As Collection
Dim EnumV As CEnumValue

Set coll = EnumValues(strRefname, strEnumGroup)

For lngI = 1 To coll.count
    Set EnumV = coll(lngI)
    Debug.Print EnumV.LibName, EnumV.GroupName, EnumV.ItemName, EnumV.ItemValue
Next lngI

Set coll = Nothing
Set EnumV = Nothing

End Function


Private Function EnumValues(ByVal strRefname As String, _
                            ByVal strEnumGroup As String) As Collection
Dim MemInfo As TLI.MemberInfo
Dim TypInfo As TLI.TypeInfo
Dim ConstInfo As TLI.ConstantInfo
Dim coll As Collection
Dim EVI As CEnumValue

Init strRefname
Set coll = New Collection

Set ConstInfo = TLInfo.Constants.NamedItem(strEnumGroup)
If Not ConstInfo Is Nothing Then
    For Each MemInfo In ConstInfo.Members
        Set EVI = New CEnumValue
        With EVI
        .LibName = TLInfo.Name
        .GroupName = ConstInfo.Name
        .ItemName = MemInfo.Name
        .ItemValue = MemInfo.Value
        End With
        coll.Add Item:=EVI
    Next MemInfo
End If
    
Set EnumValues = coll

Set coll = Nothing
Set EVI = Nothing
Set ConstInfo = Nothing
Set TypInfo = Nothing
Set MemInfo = Nothing

End Function

Private Sub Init(ByVal strRefname As String)

Dim TL As TLI.TypeLibInfo
Dim Ref As Reference

If TLApp Is Nothing Then
    Set TLApp = New TLI.TLIApplication
End If

Set TLInfo = TLApp.TypeLibInfoFromFile( _
    Filename:=Application.References(strRefname).FullPath)

Set Coll_TLI = New Collection
For Each Ref In Application.References
    Set TL = New TLI.TypeLibInfo
    Set TL = TLApp.TypeLibInfoFromFile(Filename:=Ref.FullPath)
    Coll_TLI.Add Item:=TL, Key:=TL.Name
Next Ref

Set Ref = Nothing
Set TL = Nothing

End Sub

?getnamefromenum (1, "VBA","VbMsgBoxResult")
vbOk

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
    (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
    ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
    
Public Sub imprimer_fichier(Chemin As String, le_form As Form)
 
'imprimer le fichier dont le chemin est passé en paramètre
ShellExecute le_form.hwnd, "print", Chemin, "", "", 1
 
End Sub

Call imprimer_fichier("C:\monFic.pdf", Me)

ShellExecute Me.hwnd, "print", "C:\monImage.jpg", "", "", 1

Dim I As Integer
  For I = 1 To Application.CommandBars.Count
    If Application.CommandBars.Item(I).Visible = True Then
      DoCmd.ShowToolbar Application.CommandBars.Item(I).Name, acToolbarNo
    End If
  Next I

  MonControl.ControlTipText = "Texte à mettre"

Function GiveSep() As String
GiveSep = Mid(3 / 2, 2, 1)
End Function

SELECT MSysObjects.Name AS ReportName FROM MSysObjects WHERE ((Left([Name],1)<>"~") AND ((MSysObjects.Type)=-32768));

Function Test()
    Dim frm As AccessObject
    For Each frm In CurrentProject.AllForms
        MsgBox "Formulaire : " & frm.Name
    Next
End Function

Sub FormsName()

    Dim MyDb As DAO.Database
    Dim MyDocument As DAO.Document
   
    Set MyDb = CurrentDb()
   
    With MyDb
        For Each MyDocument In .Containers("Forms").Documents
            Debug.Print "Nom: " & MyDocument.name
        Next
    End With
    
End Sub

Dim WshShell
Set WshShell = CreateObject("WScript.Shell")
 
Dim xmlDoc
Set xmlDoc = CreateObject("Msxml2.DOMDocument.6.0")
xmlDoc.async = False
xmlDoc.validateOnParse = True
 
Dim xmlSchema
Set xmlSchema = CreateObject("Msxml2.DOMDocument.6.0")
xmlSchema.async = False
xmlSchema.validateOnParse = True
xmlSchema.Load "C:\Users\Morgan\Downloads\voiture.xsd"
 
Dim xsdCache
Set xsdCache = CreateObject("Msxml2.XMLSchemaCache.6.0")
xsdCache.Add "http://www.w3.org/1999/XMLSchema", xmlSchema
Set xmlDoc.schemas = xsdCache
 
xmlDoc.Load "C:\Users\Morgan\Downloads\voiture.xml"
 
Set myErr = xmlDoc.parseError
If (myErr <> 0) Then
    MsgBox ("Erreur : " & myErr.reason)
    Else
    MsgBox ("ok")
End If