Private Sub btnSebMsg_Click()
Call SendWhatsAppMsg(Me.txtToNumber, Nz(Me.txtMsg, ""), Nz(Me.txtFilePath, ""))
End Sub

Option Explicit
#If VBA7 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
 
Public Function SendWhatsAppMag(toNumber As String, Optional Mag As String, Optional FilePathh As String)
Dim IE As Object
 
    Set IE = CreateObject("InternetExplorer-Application")
    IE.Visible = False
 
    IE.Navigate "whatsapp://send?phone=" & toNumber & "&Text=" & Nz(Mag, "")
    Sleep 2000
 
    If Len(EilePathh) > 5 Then
        SendKeys "+(TAB)"
        SendKeys "~"
        Sleep 2000
        SendKeys " (UP)"
        SendKeys "(UP)"
        SendKeys "~"
        Sleep 2000
        SendKeys Nz(FilePathh, "")
        SendKeys "~"
        Sleep 3000
    Else
        'MagBox "No"
    End If
 
SendKeys "~"
SendKeys "{NUMLOCK}", True
Set IE = Nothing
 
End Function

Private Sub Form_Close()
'sauvegarde automatique de la base
' à la fermeture saisie
 
Dim fich As Object
Dim actuelle, destination As String
 
Set fich = CreateObject("scripting.filesystemobject")
 
'chemin actuel
 
actuelle = "c:\asp\ASP-CCFF  V2.4.1.accdb"
'Chemin et nom de la sauvegarde
'true pour ecraser l'ancienne copie
 
destination = "c:\ASP\ASP_sauvegarde.accdb"
 
 
fich.copyfile actuelle, destination, True
 
Set fich = Nothing
 
 
End Sub

Sub Fiche()
    Dim wApp As Word.Application
    Dim chemin As String
    Dim sqlA As String, sqlS As String, sqlB As String, sqlC As String
    Dim rsA As DAO.Recordset, rsS As DAO.Recordset, rsB As DAO.Recordset, rsC As DAO.Recordset
    Dim db As DAO.Database
    Set db = CurrentDb
    sqlA = "SELECT * FROM R_Publipostage_Adherents" & _
    " LEFT JOIN R_Publipostage_Circuits ON R_Publipostage_Adherents.numero = R_Publipostage_Circuits.numero" & _
    " WHERE Nz([R_Publipostage_Circuits.numero],0)=390.3;" 'Renseigner le Numéro adhérent pour éditer son courrier
    Set rsA = db.OpenRecordset(sqlA)
    Set wApp = New Word.Application
    wApp.Visible = True
    chemin = CurrentProject.Path
    While Not rsA.EOF
        With wApp
     cptLigneAdr = 0
    Set wDoc = wApp.Documents.Open(chemin & "\Modèle-circuits-attribués-2026.docx") 'mettre l'année à jour
 
        cptLigneAdr = cptLigneAdr + 1
        wDoc.Bookmarks("LigneAdr" & Format(cptLigneAdr, "00")).Range.Text = rsA.Fields("civilite") & " " & UCase(rsA.Fields("nom_adhe")) & " " & rsA.Fields("prenom")
        cptLigneAdr = cptLigneAdr + 1
        wDoc.Bookmarks("LigneAdr" & Format(cptLigneAdr, "00")).Range.Text = rsA.Fields("adresse")
If rsA.Fields("addresse2") <> " " Then
    cptLigneAdr = cptLigneAdr + 1
        wDoc.Bookmarks("LigneAdr" & Format(cptLigneAdr, "00")).Range.Text = rsA.Fields("addresse2")
End If
        cptLigneAdr = cptLigneAdr + 1
        wDoc.Bookmarks("LigneAdr" & Format(cptLigneAdr, "00")).Range.Text = rsA.Fields("CodePostal") & " " & UCase(rsA.Fields("ville"))
        wDoc.Bookmarks("Prenom1").Range.Text = rsA.Fields("Prenom")

            sqlC = "SELECT * FROM R_Publipostage_Circuits_Bornes WHERE numero_adhe=" & rsA.Fields("R_Publipostage_Adherents.numero")
            Set rsC = db.OpenRecordset(sqlC)
            .ActiveDocument.Bookmarks("InfoBornes").Range.Text = rsC.Fields("Informations")
         'If Not rsC.EOF Then wDoc.Bookmarks("NumAdherent").Range.Text = rsC.Fields("numero_adhe")
 
            sqlB = "SELECT * FROM R_Publipostage_nombrePR WHERE numero=" & rsA.Fields("R_Publipostage_Adherents.numero")
            Set rsB = db.OpenRecordset(sqlB)
            .ActiveDocument.Bookmarks("TotalPR").Range.Text = rsB.Fields("Nbr_PR")
         If Not rsB.EOF Then wDoc.Bookmarks("NumAdherent").Range.Text = rsB.Fields("numero")

            '--- tableau
            sqlS = "SELECT * FROM R_Publipostage_Circuits WHERE numero=" & rsA.Fields("R_Publipostage_Adherents.numero")
            Set rsS = db.OpenRecordset(sqlS)
            With .ActiveDocument.Tables(1)
                While Not rsS.EOF
                    .Rows.Add
                    .Rows.Last.Cells(1).Range.Text = rsS.Fields("secteur_balirando")
                    .Rows.Last.Cells(2).Range.Text = UCase(rsS.Fields("Code"))
                    .Rows.Last.Cells(3).Range.Text = rsS.Fields("nom_pr")
                    .Rows.Last.Cells(4).Range.Text = UCase(rsS.Fields("depart"))
                    .Rows.Last.Cells(5).Range.Text = rsS.Fields("balisage")
                    rsS.MoveNext
                Wend
            End With
 
            '---
            '.ActiveDocument.PrintOut Mettre l'année à jour
            .ActiveDocument.SaveAs "C:\Users\balir\BALIRANDO\2026\Publipostage\Attribution circuits\Adhérent unique\" & _
            "\Circuits " & Format(Date, "yyyy") & " " & _
                      rsA.Fields("nom_adhe") & " " & rsA.Fields("prenom") & ".docx"
 
 
            .ActiveDocument.Close (wdDoNotSaveChanges)
        End With
        rsA.MoveNext
    Wend
    rsS.Close:  Set rsS = Nothing
    rsA.Close:  Set rsA = Nothing
    db.Close:   Set db = Nothing
    Set wApp = Nothing
End Sub

SELECT
    T_Circuits.numero_adhe,
    T_Circuits.code,
    T_Circuits.Secteur_Balirando,
    T_Circuits.nom_pr,
    T_Circuits.Bornes,
    IIf(
        [Bornes] = "Non",
        NULL,
        "Votre circuit comporte une borne thématique, merci de joindre sa photo à votre compte rendu de balisage "
    ) AS Informations
FROM
    T_Circuits;

 
Private Sub Liste_Categorie_Change()
If (IsNull(Forms![F_Pesee]![Liste_Sexe])) Then
Me.F_SF_Pesee.Form.RecordSource = "R_Pesee_categorie"
Else
Me.F_SF_Pesee.Form.RecordSource = "R_Pesee_sexe_categorie"
End If
End Sub

Dim ctl As Control
 
For Each ctl In Me.Controls
 
ctl.OnKeyDown = "=maFonction(............?)"
 
Next ctl

 
Public Function maFonction(KeyCode ? as ?)
 
   Dim ctl as control
   Set ctl = Screen.ActiveControl
 
    Select Case KeyCode
 
        Case 65        
            'action1
 
        Case 66        
            'action2
 
    End Select
 
End Function

 
            DoCmd.OpenForm "Album", acNormal, , "[Achat_ID] = " & RecordID
            Forms("Album").SetFocus

Dim Fiche As Object
Dim Actuelle, Distination As String
Set Fiche = CreateObject("Scripting.filesystemObject")
Actuelle = "C:\Users\mahrez\Desktop\ESSAIE.accdb"
Distination = "D:\SauvegardeESSAIE.accdb"
Fiche.CopyFile Actuelle, Distination, True
Set Fiche = Nothing

Dim fichier As String
Dim client_msg As New Outlook.Application
Dim message As Outlook.MailItem
Dim adresse As String
fichier = "D:\SauvegardeESSAIE.accdb"
 
Set message = client_msg.CreateItem(olMailItem)
With message
adresse = ("mahrezs@gmail.com")
Subject = "la copie de l'application"
Body = "Application"
Attachments.Add fichier
Send
End With

 
    ' Exemple de données
    ' ListeFichiers => "Fleur_01.jpg|Fleur_02.jpg|Fleur_03.jpg"
 
    ListeFichiers = Forms![Edition_Achat]![ListeDesFichiers]
    d = 1
 
    For ct = 1 To qt
 
        ' Déclaration des 2 objets (1 - photo / 1 - nom du fichier)
 
        Set NomFichier = Me("NomFichier_" + CStr(ct))
        Set Photo = Me("Image_" + CStr(ct))
 
        ' Extrait le nom du fichier et le sauve dans le champs texte
        GoSub cherche
 
        NomFichier.Visible = True
        NomFichier.Value = nom      ' Affiche le nom du fichier
 
        ' Prépare le path complet de l'image et la charge dans l'objet image
        Rep_photo = repertoirePhoto & nom
        Photo.Visible = True
        Photo.Picture = Rep_photo
    Next ct
    Exit Sub
 
cherche:
    ' Extraction du nom de fichier contenu dans la chaine de caratères
    p = InStr(d, ListeFichiers, "|")
 
    If p > 0 Then
        nom = Mid(ListeFichiers, d, p - d)
        d = p + 1
    Else
        nom = Right(ListeFichiers, (Len(ListeFichiers) - d) + 1)
    End If
    Return

 
Private Sub Image_1_DblClick(Cancel As Integer)
    Dim FichierImage As String
 
    FichierImage = Me.Image_1.Picture
 
    Me.PhotoChoisi = FichierImage
 
    DoCmd.OpenForm "Zoom", acNormal, , , , , "Album"
End Sub

Private Type ChooseColor
    lStructSize As Long
    hWndOwner As Long
    hInstance As Long
    rgbResult As Long
    lpCustColors As String
    flags As Long
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type
 
Private Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As ChooseColor) As Long
Dim CustomColors() As Byte
 
Function ShowColor() As Long
On Error GoTo errHnd
    Dim cc As ChooseColor
 
    cc.lStructSize = Len(cc)
    cc.hInstance = Application.hWndAccessApp
    cc.lpCustColors = StrConv(CustomColors, vbUnicode)
    cc.flags = 0
 
    If ChooseColor(cc) <> 0 Then
        ShowColor = cc.rgbResult
 
 '
 '
 '
 '
 End Function

 Declare Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long)
Public Sub WaitSeconds(intSeconds As Integer)
  ' Comments: Waits for a specified number of seconds
  ' Params  : intSeconds      Number of seconds to wait
  ' Source  : Total Visual SourceBook
 
  On Error GoTo PROC_ERR
 
  Dim datTime As Date
 
  datTime = DateAdd("s", intSeconds, Now)
 
  Do
   ' Yield to other programs (better than using DoEvents which eats up all the CPU cycles)
    Sleep 100
    DoEvents
  Loop Until Now >= datTime
 
PROC_EXIT:
  Exit Sub
 
PROC_ERR:
  MsgBox "Error module waitseconds: " & Err.Number & ". " & Err.description, , "modDateTime.WaitSeconds"
  Resume PROC_EXIT
End Sub

    '#If VBA7 Then
       'MsgBox "32bits"
    '#Else
       'MsgBox "64bits"
    '#End If