Malicious Office (OOXML) — malware analysis report

Static analysis result for SHA-256 94a54be1204134eb…

MALICIOUS

Office (OOXML)

236.3 KB Created: 2020-10-05 13:01:04 UTC Authoring application: Microsoft Excel 16.0300 First seen: 2020-10-16
MD5: 58ad993f9444ebae1606c9cf4b5d81c6 SHA-1: 0463e6d5577d6cafc5f56876357af291a8d0a6e9 SHA-256: 94a54be1204134eb956bda1eb9560fad8a0f42b815191a2363f77c2a5cb326ad
306 Risk Score

Heuristics 10

  • VBA project inside OOXML medium 5 related findings OOXML_VBA
    Document contains a VBA project — VBA macros present
  • Potential Shell call in VBA critical OLE_VBA_SHELL
    Potential Shell call in VBA
    Matched line in script
                Shell "RunDll32.exe InetCpl.cpl,ClearMyTracksByProcess 8 "
  • URLDownloadToFile in VBA critical OLE_VBA_DOWNLOAD
    URLDownloadToFile in VBA
    Matched line in script
        Public Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias _
  • LOLBin reference in VBA critical OLE_VBA_LOLBIN
    LOLBin reference in VBA
    Matched line in script
                Shell "RunDll32.exe InetCpl.cpl,ClearMyTracksByProcess 8 "
  • CreateObject call high OLE_VBA_CREATEOBJ
    CreateObject call
    Matched line in script
      Set myShell = CreateObject("Shell.Application")
  • Environ() call (env variable access) low OLE_VBA_ENVIRON
    Environ() call (env variable access)
    Matched line in script
          Shell Environ("WINDIR") & "\explorer.exe " & MonDossier, vbNormalFocus
  • Password-protected archive handoff high SE_PASSWORD_ARCHIVE_LURE
    Document gives password instructions for an archive or attachment — often used to keep payloads encrypted until after gateway scanning
  • External hyperlinks (9) low OOXML_EXTERNAL_HYPERLINKS
    Document contains 9 external hyperlinks — clickable URLs are stored as external relationships. First target: http://utbmontceau.fr/Logos_Badges/
  • External workbook data link low OOXML_EXTERNAL_REL_DATALINK
    External workbook reference in xl/externalLinks/_rels/externalLink1.xml.rels: /Users/UTB/Documents/UTB/Exportation Gestionnaire UTB Désinfecté/Gestionnaire UTB.xlsm
  • Embedded URL info EMBEDDED_URL
    One or more URLs were extracted from the document. The URL itself is not a detection — see the per-URL labels for which channel (macro, JS, link annotation, document body, ...) reached each URL.
    URL http://utbmontceau.fr/Conferences/ Referenced by macro
    • http://utbmontceau.fr/Cartes_Badges/Referenced by macro
    • http://utbmontceau.fr/Images/Referenced by macro
    • http://utbmontceau.fr/Logos_Badges/Referenced by macro
    • http://utbmontceau.fr/Voyages/Referenced by macro
    • http://api.qrserver.com/v1/create-qr-code/?data=Referenced by macro
    • http://api.qrserver.com/v1/create-qr-QR_Code/?data=Referenced by macro

Extracted artifacts 2

Files carved from inside the sample during analysis.

FilenameKindSourceSize
macros.bas vba-macro oletools.olevba.extract_macros (decoded VBA source from OOXML) 250932 bytes
SHA-256: d14dc68e01dceb5252614de58c09f13cd4055e42bc1356e9c10ea749ef8db059
Preview script
First 1,000 lines of the extracted script
Attribute VB_Name = "ThisWorkbook"
Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Feuil1"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Feuil5"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Feuil2"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   ' pInit
    'frmPointages.zPointage = Fc(2).Range("O2")
   ' Fc(2).Range("O2").Select
   
End Sub

Attribute VB_Name = "Feuil3"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Feuil4"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "mdlUtilitaires"

Public ID_Adhérent, Statut, Bénévolat, k, ID_Carte_Invité, ID_Carte_Oubliée, ID_Carte_Accès_Sans_Réservation, Tps, Temps, r, g, b
Public Code128_Couleur, QR_Code_H, QR_Code_Couleur, QR_Code_Background, QR_Code_Left, QR_Code_Top, QR_Code_W, QR_Code_Visible, QR_Code_Ordre

#If VBA7 Then
    Public Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias _
            "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, _
            ByVal szFileName As String, ByVal dwReserved As Long, _
            ByVal lpfnCB As Long) As Long
    Declare PtrSafe Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" ( _
                 ByVal sAgent As String, ByVal lAccessType As Long, _
                 ByVal sProxyName As String, _
                 ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
    Declare PtrSafe Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" ( _
                 ByVal hInternetSession As Long, ByVal sServerName As String, _
                 ByVal nServerPort As Integer, ByVal sUserName As String, _
                 ByVal sPassword As String, ByVal lService As Long, _
                 ByVal lFlags As Long, ByVal lContext As Long) As Long
    Declare PtrSafe Function FtpSetCurrentDirectory Lib "wininet.dll" Alias _
                 "FtpSetCurrentDirectoryA" (ByVal hFtpSession As Long, _
                 ByVal lpszDirectory As String) As Boolean
    Declare PtrSafe Function FtpPutFile Lib "wininet.dll" Alias "FtpPutFileA" ( _
                 ByVal hFtpSession As Long, _
                 ByVal lpszLocalFile As String, _
                 ByVal lpszRemoteFile As String, _
                 ByVal dwFlags As Long, _
                 ByVal dwContext As Long) As Boolean
    Declare PtrSafe Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer
    Declare PtrSafe Function FtpFindFirstFile Lib "wininet.dll" Alias "FtpFindFirstFileA" (ByVal hFtpSession As Long, ByVal lpszSearchFile As String, lpFindFileData As WIN32_FIND_DATA, ByVal dwFlags As Long, ByVal dwContent As Long) As Long
    Declare PtrSafe Function InternetFindNextFile Lib "wininet.dll" Alias "InternetFindNextFileA" (ByVal hFind As Long, lpvFindData As WIN32_FIND_DATA) As Long
    Declare PtrSafe Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
    Declare PtrSafe Function FileTimeToLocalFileTime Lib "kernel32" (lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long
    Declare PtrSafe Function FtpDeleteFile Lib "wininet.dll" Alias "FtpDeleteFileA" (ByVal hFtpSession As Long, ByVal lpszFileName As String) As Boolean
    Declare PtrSafe Function FtpGetFile Lib "wininet.dll" Alias "FtpPutFileA" ( _
         ByVal hFtpSession As Long, _
         ByVal lpszLocalFile As String, _
         ByVal lpszRemoteFile As String, _
         ByVal dwFlags As Long, _
         ByVal dwContext As Long) As Boolean
    Declare PtrSafe Function FtpRemoveDirectory Lib "wininet.dll" Alias "FtpRemoveDirectoryA" (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean
    
    'Declare Function SHBrowseForFolder Lib "Shell32" (lpbi As BrowseInfo) As Long
    Declare PtrSafe Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
    Private Declare PtrSafe Function FtpCreateDirectory Lib "wininet.dll" Alias _
    "FtpCreateDirectoryA" (ByVal hFtpSession As Long, ByVal lpszDirectory As _
    String) As Boolean
    Declare Function Beep Lib "kernel32" (ByVal Frequence As Long, ByVal Duree As Long) As Long
#Else
    Public Declare Function URLDownloadToFile Lib "urlmon" Alias _
            "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, _
            ByVal szFileName As String, ByVal dwReserved As Long, _
            ByVal lpfnCB As Long) As Long
    Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" ( _
                 ByVal sAgent As String, ByVal lAccessType As Long, _
                 ByVal sProxyName As String, _
                 ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
    Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" ( _
                 ByVal hInternetSession As Long, ByVal sServerName As String, _
                 ByVal nServerPort As Integer, ByVal sUserName As String, _
                 ByVal sPassword As String, ByVal lService As Long, _
                 ByVal lFlags As Long, ByVal lContext As Long) As Long
    Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias _
                 "FtpSetCurrentDirectoryA" (ByVal hFtpSession As Long, _
                 ByVal lpszDirectory As String) As Boolean
    Declare Function FtpPutFile Lib "wininet.dll" Alias "FtpPutFileA" ( _
                 ByVal hFtpSession As Long, _
                 ByVal lpszLocalFile As String, _
                 ByVal lpszRemoteFile As String, _
                 ByVal dwFlags As Long, _
                 ByVal dwContext As Long) As Boolean
    Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer
    Declare Function FtpFindFirstFile Lib "wininet.dll" Alias "FtpFindFirstFileA" (ByVal hFtpSession As Long, ByVal lpszSearchFile As String, lpFindFileData As WIN32_FIND_DATA, ByVal dwFlags As Long, ByVal dwContent As Long) As Long
    Declare Function InternetFindNextFile Lib "wininet.dll" Alias "InternetFindNextFileA" (ByVal hFind As Long, lpvFindData As WIN32_FIND_DATA) As Long
    Declare Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
    Declare Function FileTimeToLocalFileTime Lib "kernel32" (lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long
    Declare Function FtpDeleteFile Lib "wininet.dll" Alias "FtpDeleteFileA" (ByVal hFtpSession As Long, ByVal lpszFileName As String) As Boolean
    Declare Function FtpGetFile Lib "wininet.dll" Alias "FtpPutFileA" ( _
         ByVal hFtpSession As Long, _
         ByVal lpszLocalFile As String, _
         ByVal lpszRemoteFile As String, _
         ByVal dwFlags As Long, _
         ByVal dwContext As Long) As Boolean
    Declare Function FtpRemoveDirectory Lib "wininet.dll" Alias "FtpRemoveDirectoryA" (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean
    
    'Declare Function SHBrowseForFolder Lib "Shell32" (lpbi As BrowseInfo) As Long
    Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
    Private Declare Function FtpCreateDirectory Lib "wininet.dll" Alias _
    "FtpCreateDirectoryA" (ByVal hFtpSession As Long, ByVal lpszDirectory As _
    String) As Boolean
    Declare Function Beep Lib "kernel32" (ByVal Frequence As Long, ByVal Duree As Long) As Long
#End If
Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type
Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * 300
    cAlternate As String * 14
End Type
Type BROWSEINFO
    hwndOwner As Long
    pidlRoot As Long
    pszDisplayName As Long
    lpszTitle As Long
    ulFlags As Long
    lpfnCallback As Long
     lParam As Long
    iImage As Long
End Type
'
Const Clef              As String = "@nbvfdszé""'(-è_ijhgfcKLKjhgyuilM^+)àçiu-('32azsDRtvBhujkoç_è6tre""zsXWqazerfcx<;:<?"
Const NBROTATIONSMAX    As Long = 15
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Vérification de l'existence de la photo sur Amen
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function Existe_Fichier_FTP(Fichier)
    pInit
    Dim InternetOK
    Dim FtpOK
    Dim FtpServeur
    Dim FtpLogin
    Dim FtpPass
    Dim DossierLocal
    Dim DossierDistant
    Dim Result
    Dim Internet_OK
    Dim FTP_OK
    Dim Select_DossierDistant
    Dim Resultat
    Dim res
    Dim fichdata As WIN32_FIND_DATA, loc_tps As FILETIME, tps_sys As SYSTEMTIME
    With Fc(2)
        DossierLocal = .Range("rep") & "Identités\"
        DossierDistant = .Range("rep_identité")
        FtpServeur = .Range("hosting_ftp")
        FtpLogin = .Range("utilisateur_ftp")
        FtpPass = .Range("mot_de_passe_ftp")
    End With
     'Vérifier la connection à internet
     InternetOK = InternetOpen("PutFtpFile", 1, "", "", 0)
      If InternetOK = 0 Then
      MsgBox "connection internet impossible"
      Exit Function
      End If
     Const INTERNET_FLAG_PASSIVE = &H8000000
     'Vérifier l'accès ftp
     FtpOK = InternetConnect(InternetOK, FtpServeur, 21, FtpLogin, FtpPass, 1, INTERNET_FLAG_PASSIVE, 0)
      If FtpOK = 0 Then
      MsgBox "connection FTP impossible"
      Exit Function
      End If
    
     'vérifier le dossier distant
     Select_DossierDistant = FtpSetCurrentDirectory(FtpOK, DossierDistant)
     If Select_DossierDistant = 0 Then
      MsgBox "impossible de trouver le répertoire distant "
      Exit Function
     End If
    'recherche du premier fichier du répertoire
    fichdata.cFileName = String(300, 0)
    prems = FtpFindFirstFile(FtpOK, "Alliot Josette.bmp", fichdata, 0, 0)
    If prems = 0 Then
        Existe_Fichier_FTP = False
    Else
        Existe_Fichier_FTP = True
    End If
    
End Function
Sub ExportFtp()
 'transfère un fichier (ici un classeur nommé transfert2.xls)
 'du répertoire local vers le répertoire adhoc du serveur ftp (upload)
 pInit
 Dim InternetOK
 Dim FtpOK
 Dim FtpServeur
 Dim FtpLogin
 Dim FtpPass
 Dim DossierLocal
 Dim DossierDistant
 Dim Result
 Dim Internet_OK
 Dim FTP_OK
 Dim Select_DossierDistant
 Dim Resultat
 Dim res
 Dim fichdata As WIN32_FIND_DATA, loc_tps As FILETIME, tps_sys As SYSTEMTIME
  With Fc(2)
        DossierLocal = .Range("rep") & "Identités\"
        DossierDistant = .Range("rep_identité_Site")
        FtpServeur = .Range("hosting_ftp")
        FtpLogin = .Range("utilisateur_ftp")
        FtpPass = .Range("mot_de_passe_ftp")
    End With
 'DossierLocal = "C:\Users\UTB-UDS\Documents\UTB\Identités\"
 'DossierDistant = "/public/www/Images"
 'FtpServeur = "utbmontceau.fr"
 'FtpLogin = "utbmichel"
 'FtpPass = "utb@michel@1945"

 'Vérifier la connection à internet
 InternetOK = InternetOpen("PutFtpFile", 1, "", "", 0)
  If InternetOK = 0 Then
  MsgBox "connection internet impossible"
  Exit Sub
  End If
 Const INTERNET_FLAG_PASSIVE = &H8000000
 'Vérifier l'accès ftp
 FtpOK = InternetConnect(InternetOK, FtpServeur, 21, FtpLogin, FtpPass, 1, INTERNET_FLAG_PASSIVE, 0)
  If FtpOK = 0 Then
  MsgBox "connection FTP impossible"
  Exit Sub
  End If

 'vérifier le dossier distant
 Select_DossierDistant = FtpSetCurrentDirectory(FtpOK, DossierDistant)
 If Select_DossierDistant = 0 Then
  MsgBox "impossible de trouver le répertoire distant "
  Exit Sub
 End If
'recherche du premier fichier du répertoire
    fichdata.cFileName = String(300, 0)
    prems = FtpFindFirstFile(FtpOK, "Peteuil Michel Essai.bmp", fichdata, 0, 0)
    If prems = 0 Then Exit Sub
encore:
'nom du fichier
    nomf = Left(fichdata.cFileName, InStr(1, fichdata.cFileName, Chr(0)) - 1)
'recherche du fichier suivant
    fichdata.cFileName = String(300, 0)
    suiv = InternetFindNextFile(prems, fichdata)
    
    If suiv <> 0 Then GoTo encore

 Resultat = ""
 'adresses du ou des fichiers à transférer
 FichierLocal = DossierLocal & "Peteuil Michel Essai.bmp"
 FichierDistant = "Peteuil Michel Essai.bmp"

 'transférer les fichiers
 Const FTP_TRANSFER_TYPE_BINARY = &H2
 'mode passif proxy
 'transfert du fichier sql
 succès = FtpGetFile(FtpOK, FichierLocal, FichierDistant, FTP_TRANSFER_TYPE_BINARY, 0)
 If succès Then
  Result = FichierDistant & " a été transféré "
 Else
  Result = FichierDistant & " n'a pas pu être transféré"
 End If

 'annoncer le résultat de l'opération
 If Result = "" Then
 MsgBox Result
 Else
 MsgBox "aucun fichier transféré"
 End If

 'fermer les pointeurs, ménage
 InternetCloseHandle FTP_OK
 InternetCloseHandle Internet_OK

 End Sub
        


Sub pAdhérentsmysql_vers_excel()
    pInit
    
    With Fc(4)
        Nb = .Columns("D").Find("").Row
        For i = 1 To Nb - 1
        
        Next
    
    End With
    
MsgBox Nb
''Vérification de la connexion
    Test_Serveur
'
'Selection des traitements
    Set rs = New ADODB.Recordset
    rs.CursorLocation = adUseServer
    
'Transfert des E/S dans le bordereau
    rs.Open "SELECT ID_Troupeau, Pays, Numero, Nom, Date_Naissance, Race, QR_Code,Sexe," _
    & "Type_Mouvement, Mouvement, Date_Mouvement, Poids,Numero_N FROM Troupeau ", conn
    If Not (rs.EOF = True And rs.BOF = True) Then
        rs.MoveFirst
    End If
    Do Until rs.EOF
            conn.Execute "INSERT INTO bovins SET " _
                & " ID_bovin = " & rs.Fields("ID_Troupeau").Value & ",Pays_bovin = '" & rs.Fields("Pays").Value & "', Numero_national_bovin = '" & rs.Fields("numero").Value & "'," _
                & " Nom_bovin = '" & rs.Fields("Nom").Value & "',Date_Naissance_bovin = " & rs.Fields("Date_Naissance").Value & ", Race_bovin ='" & rs.Fields("Race").Value & "',Sexe_bovin ='" & rs.Fields("Sexe").Value & "'," _
                & " Numero_Exploitant_Naissance = ' " & rs.Fields("Numero_N") & "',Type_Mouvement = '" & rs.Fields("Type_Mouvement").Value & "',Date_Mouvement = " & rs.Fields("Date_Mouvement").Value & ",Mouvement ='" & rs.Fields("Mouvement").Value & "'," _
                & " Poids_bovin = '" & rs.Fields("Poids").Value & "';"
        
        rs.MoveNext
    Loop
       
    rs.Close
   
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Reprise des adhérents depuis le fichier Excel
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub pAdhérent_excel_vers_mysql()
    pInit
    pSupprime_Adhérent_mysql
    k = 0
     With Fc(4)
      Nb = .Columns("D").Find("").Row
        For i = 1 To Nb - 1
            k = k + 1
            ID_Adhérent = k
            Titre = .Range("Titre").Offset(k, 0)
            Nom = .Range("Nom").Offset(k, 0)
            Prénom = .Range("Prénom").Offset(k, 0)
            Adresse = .Range("Adresse").Offset(k, 0)
            QR_Code_Postal = .Range("QR_Code_Postal").Offset(k, 0)
            Ville = .Range("Ville").Offset(k, 0)
            Téléphone_Fixe = Format(.Range("Téléphone_Fixe").Offset(k, 0), "0#"" ""##"" ""##"" ""##"" ""##")
            Téléphone_Portable = Format(.Range("Téléphone_Portable").Offset(k, 0), "0#"" ""##"" ""##"" ""##"" ""##")
            Email = .Range("Email").Offset(k, 0)
            'N_Adhérent = .Range("N_Adhérent").Offset(k, 0)
            Identité = .Range("Identité").Offset(k, 0)
            'Statut = .Range("Statut").Offset(k, 0)
            'Bénévolat = .Range("Bénévolat").Offset(k, 0)
            date_naissance = .Range("Date_Naissance").Offset(k, 0)
            pReprise_Enregistrer_Adhérent
        Next
    End With

End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Enregistrement d'un adhérent
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub pReprise_Enregistrer_Adhérent()
    
    Dim rs As ADODB.Recordset
    Dim fld As ADODB.Field
    Dim i, L
    Dim myarray(100, 70)
'Ouverture de la connexion
    
   
    conn.Open
'Enregistrement dans la base
    conn.Execute "INSERT INTO adherents SET " _
    & "ID_Adherent= " & k & "," _
    & " Titre= '" & Replace(Titre, "'", "\'", 1, 10) & "'," _
    & " Nom = '" & Replace(Nom, "'", "\'", 1, 10) & "'," _
    & " Prenom = '" & Replace(Prénom, "'", "\'", 1, 10) & "'," _
    & " Adresse = '" & Replace(Adresse, "'", "\'", 1, 10) & "'," _
    & " QR_Code_Postal= '" & Replace(QR_Code_Postal, "'", "\'", 1, 10) & "'," _
    & " Ville = '" & Replace(Ville, "'", "\'", 1, 10) & "'," _
    & " Telephone_Fixe= '" & Replace(Téléphone_Fixe, "'", "\'", 1, 10) & "'," _
    & " Telephone_Portable = '" & Replace(Téléphone_Portable, "'", "\'", 1, 10) & "'," _
    & " Email= '" & Replace(Email, "'", "\'", 1, 10) & "'," _
    & " Date_Naissance= " & 0 & "," _
    & " Identite = '" & "" & "';"
'Fermeture de la connexion
   
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Reprise des conférenciers depuis le fichier Excel
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub pConférenciers_excel_vers_mysql()
    pInit
    pSupprime_Conférenciers_mysql
    k = 0
     With Fc(9)
      Nb = .Columns("D").Find("").Row
        For i = 1 To Nb - 1
            k = k + 1
            ID_Conférencier = k
            Titre = .Range("Titre").Offset(k, 0)
            Nom = .Range("Nom").Offset(k, 0)
            Prénom = .Range("Prénom").Offset(k, 0)
            Adresse = .Range("Adresse").Offset(k, 0)
            QR_Code_Postal = Format(.Range("QR_Code_Postal").Offset(k, 0), "00000")
            Ville = .Range("Ville").Offset(k, 0)
            Téléphone_Fixe_Pro = Format(.Range("Téléphone_Fixe_Pro").Offset(k, 0), "0#"" ""##"" ""##"" ""##"" ""##")
            Téléphone_Mobile_Pro = Format(.Range("Téléphone_Mobile_Pro").Offset(k, 0), "0#"" ""##"" ""##"" ""##"" ""##")
            Email = .Range("Email").Offset(k, 0)
            Téléphone_Fixe_Perso = Format(.Range("Téléphone_Fixe_Perso").Offset(k, 0), "0#"" ""##"" ""##"" ""##"" ""##")
            Téléphone_Mobile_Perso = Format(.Range("Téléphone_Mobile_Perso").Offset(k, 0), "0#"" ""##"" ""##"" ""##"" ""##")
            pReprise_Enregistrer_Conférencier
        Next
    End With
End Sub
Sub pSupprime_Adhérent_mysql()

    
    Dim rs As ADODB.Recordset
    Dim fld As ADODB.Field
    Dim i, L
    Dim myarray(100, 70)
'Ouverture de la connexion
    
   
    conn.Open
'Enregistrement dans la base
    conn.Execute "DELETE FROM adherents; "
    
   
End Sub
Sub pSupprime_Conférenciers_mysql()
    Dim rs As ADODB.Recordset
    Dim fld As ADODB.Field
    Dim i, L
    Dim myarray(100, 70)
'Ouverture de la connexion
    conn.Open
'Enregistrement dans la base
    conn.Execute "DELETE FROM Conferenciers; "
End Sub
'Préparation du mailing sur options
Sub pEnvoi_Mails_Evolution()
     pInit
    With frmMailings_New
        .Caption = Space(5) & "U.T.B. Montceau-les-Mines - Préparation du mailing"
        .zNb_Groupes = 30
        pListe_Saisons ("frmMailings_New")
'Présélection des adresses mail
        .zMessage = "Traitement réalisé sur la base opérationnelle."
      
        Année = Right(.zSaison, 4)
        .zRelations_Ext = False
        
        With .zAdhérents_Saison_Precedente
            .Value = False
            .Enabled = True
            .Caption = "Adhérents non renouvelés de la saison : " & Année - 2 & "/" & Année - 1
        End With
        'MsgBox .zAdhérents_Saison.Caption
        With .zAdhérents_Saison
            .Value = True
            .Enabled = True
            .Caption = "Adhérents de la saison : " & frmMailings_New.zSaison
        End With
        
        .Show
    End With
    Select Case Ret
        Case 1
            GoTo suite
        Case 0
            Exit Sub
    End Select
suite:
    a2 = frmMailings_New.zSaison
    Ind = frmMailings_New.zSaison.ListIndex + 1
    a1 = frmMailings_New.zSaison.List(Ind)
    Dim rs As ADODB.Recordset
    Dim fld As ADODB.Field
    Dim i, L, Nb

    Set rs = New ADODB.Recordset
    rs.CursorLocation = adUseServer
    Test_Serveur
    rs.Open "set sql_big_selects=1;", conn
    For Each ctrl In frmMailings_New.Controls
        If TypeName(ctrl) = "OptionButton" Then
            If ctrl.Value = True Then
            Select Case ctrl.TabIndex
                Case 0 'Adhérents de la saison en cours
                    req_nb = "select count(distinct(email)) from (select * from adherents where Email<>'' and  statut is null or statut=''or statut<>'R') as A , (select * from inscriptions_conferences where Saison='" & a2 & "' ) as B  where a.id_adherent=b.id_adherent and a.email<>''"
                    Req = "select distinct(email) from (select * from adherents WHERE Email<>'' and  statut is null or statut=''or statut<>'R' ) as A , (select * from inscriptions_conferences where Saison='" & a2 & "'    union select * from inscriptions_conferences where Saison='" & a2 & "' ) as B  where a.id_adherent=b.id_adherent and a.email<>''"
                Case 1 'Adhérents non renouvelés de la saison précédente
                    'req_nb = "select count(distinct(email)) from (select * from adherents where Email<>'' and  statut is null or statut=''or statut<>'R') as A , (select * from inscriptions_conferences where Saison='" & .zSaison & "' ) as B  where a.id_adherent=b.id_adherent and a.email<>''"
                    'Req = "select distinct(email) from (select * from adherents WHERE Email<>'' and  statut is null or statut=''or statut<>'R' ) as A , (select * from inscriptions_conferences where Saison='" & .zSaison & "'    union select * from inscriptions_conferences where Saison='" & .zSaison & "' ) as B  where a.id_adherent=b.id_adherent and a.email<>''"
                   ' Req = "select distinct(email) from (select * from adherents) as C , (select * from inscriptions_conferences where Saison='" & A1 & "' ) as A   left JOIN (select * from inscriptions_conferences where Saison='" & a2 & "' ) as B  ON  a.ID_Adherent = b.ID_Adherent  where B.saison is null and c.id_adherent=a.id_adherent"
                    'req_nb = "select count(distinct(email)) from (select * from adherents where email<>'' ) as C , (select * from inscriptions_conferences where Saison='" & a2 & "' ) as A   left JOIN (select * from inscriptions_conferences where Saison='" & a1 & "' ) as B  ON  a.ID_Adherent = b.ID_Adherent  where B.saison is null and c.id_adherent=a.id_adherent"
                    Req = "select distinct(email) from (select * from adherents where email<>'' and statut<>'R' ) as C , (select * from inscriptions_conferences where Saison='" & a1 & "' ) as A   left JOIN (select * from inscriptions_conferences where Saison='" & a2 & "' ) as B  ON  a.ID_Adherent = b.ID_Adherent  where B.saison is null and c.id_adherent=a.id_adherent"
                    req_nb = "select count(distinct(email)) from (select * from adherents where email<>'' and  statut<>'R') as C , (select * from inscriptions_conferences where Saison='" & a1 & "' ) as A   left JOIN (select * from inscriptions_conferences where Saison='" & a2 & "' ) as B  ON  a.ID_Adherent = b.ID_Adherent  where B.saison is null and c.id_adherent=a.id_adherent"
    'rs.Open "SELECT titre,nom,prenom,email,commentaires FROM adherents,relations_utb where adherents.id_adherent = relations_utb.id_adherent order by nom,prenom", conn

                
                Case 2 'Relations extérieures
                    req_nb = "select count(distinct(email)) from (select * from adherents WHERE Email<>'' and  statut is null or statut=''or statut<>'R') as A , (select * from relations_utb) as C  where  a.id_adherent=c.id_adherent"
                    Req = "select distinct(email) from (select * from adherents WHERE Email<>'' and  statut is null or statut=''or statut<>'R') as A , (select * from relations_utb) as C  where  a.id_adherent=c.id_adherent"
            End Select
                GoTo suite_100
            End If
        End If
    Next

    
    
'Exit Sub

'Test de la base des relations UTB
    rs.Open " select count(*) from relations_utb", conn
    nb_relations = rs.Fields("count(*)")
    rs.Close
'Etablissement du mailing
     With frmMailings
        Select Case nb_relations
            Case 0
                 Select Case Right(.zAdhérents_Saison.Caption, 4)
                    Case Left(.zSaison, 4) 'Saison précedente
                        If .zRelations_Ext_UTB = True Then
                            req_nb = "select count(distinct(email)) from (select * from adherents WHERE Email<>'' and  statut is null or statut=''or statut<>'R') as A , (select * from inscriptions_conferences where Saison='" & Right(.zAdhérents_Saison.Caption, 9) & "'    union select * from inscriptions_conferences where Saison='" & .zSaison & "' ) as B   where a.id_adherent=b.id_adherent"
                            Req = "select distinct(email) from (select * from adherents WHERE Email<>'' and  statut is null or statut=''or statut<>'R') as A , (select * from inscriptions_conferences where Saison='" & Right(.zAdhérents_Saison.Caption, 9) & "'    union select * from inscriptions_conferences where Saison='" & .zSaison & "' ) as B   where a.id_adherent=b.id_adherent"
                        Else
                            req_nb = "select count(distinct(email)) from (select * from adherents WHERE Email<>'' and  statut is null or statut=''or statut<>'R') as A , (select * from inscriptions_conferences where Saison='" & Right(.zAdhérents_Saison.Caption, 9) & "'    union select * from inscriptions_conferences where Saison='" & .zSaison & "' ) as B  where a.id_adherent=b.id_adherent "
                            Req = "select distinct(email) from (select * from adherents WHERE Email<>'' and  statut is null or statut=''or statut<>'R') as A , (select * from inscriptions_conferences where Saison='" & Right(.zAdhérents_Saison.Caption, 9) & "'    union select * from inscriptions_conferences where Saison='" & .zSaison & "' ) as B  where a.id_adherent=b.id_adherent"
                        End If
                    Case Right(.zSaison, 4) 'Saison en cours
                        If .zRelations_Ext_UTB = True Then
                            req_nb = "select count(distinct(email)) from (select * from adherents WHERE Email<>'' and  statut is null or statut=''or statut<>'R') as A , (select * from inscriptions_conferences where Saison='" & .zSaison & "') as B  where a.id_adherent=b.id_adherent and a.email<>''"
                            Req = "select distinct(email) from (select * from adherents WHERE Email<>'' and  statut is null or statut=''or statut<>'R') as A , (select * from inscriptions_conferences where Saison='" & .zSaison & "'    union select * from inscriptions_conferences where Saison='" & .zSaison & "' ) as B where a.id_adherent=b.id_adherent and a.email<>''"
                        Else
                            req_nb = "select count(distinct(email)) from (select * from adherents where Email<>'' and  statut is null or statut=''or statut<>'R') as A , (select * from inscriptions_conferences where Saison='" & .zSaison & "' ) as B  where a.id_adherent=b.id_adherent and a.email<>''"
                            Req = "select distinct(email) from (select * from adherents WHERE Email<>'' and  statut is null or statut=''or statut<>'R' ) as A , (select * from inscriptions_conferences where Saison='" & .zSaison & "'    union select * from inscriptions_conferences where Saison='" & .zSaison & "' ) as B  where a.id_adherent=b.id_adherent and a.email<>''"
                        End If
                End Select
            Case Else
                Select Case Right(.zAdhérents_Saison.Caption, 4)
                    Case Left(.zSaison, 4)  'Saison précedente
                        If .zRelations_Ext_UTB = True Then
                            req_nb = "select count(distinct(email)) from (select * from adherents WHERE Email<>'' and  statut is null or statut=''or statut<>'R') as A , (select * from inscriptions_conferences where Saison='" & Right(.zAdhérents_Saison.Caption, 9) & "'union select * from inscriptions_conferences where Saison='" & .zSaison & "' ) as B ,(select * from relations_utb) as C  where a.id_adherent=b.id_adherent or a.id_adherent=c.id_adherent"
                            Req = "select distinct(email) from (select * from adherents WHERE Email<>'' and  statut is null or statut='' or statut<>'R') as A , (select * from inscriptions_conferences where Saison='" & Right(.zAdhérents_Saison.Caption, 9) & "'union select * from inscriptions_conferences where Saison='" & .zSaison & "' ) as B ,(select * from relations_utb) as C  where a.id_adherent=b.id_adherent or a.id_adherent=c.id_adherent"
                        Else
                            req_nb = "select count(distinct(email)) from (select * from adherents WHERE Email<>'' and  statut is null or statut=''or statut<>'R') as A , (select * from inscriptions_conferences where Saison='" & Right(.zAdhérents_Saison.Caption, 9) & "'    union select * from inscriptions_conferences where Saison='" & .zSaison & "' ) as B  where a.id_adherent=b.id_adherent"
                            Req = "select distinct(email) from (select * from adherents WHERE Email<>'' and  statut is null or statut=''or statut<>'R') as A , (select * from inscriptions_conferences where Saison='" & Right(.zAdhérents_Saison.Caption, 9) & "'union select * from inscriptions_conferences where Saison='" & .zSaison & "' ) as B  where a.id_adherent=b.id_adherent"
                        End If
                    Case Right(.zSaison, 4) 'Saison en cours
                        rs.Open " select count(*) from inscriptions_conferences where saison ='" & .zSaison & "'", conn
                            nb_inscrits = rs.Fields("count(*)")
                        rs.Close
                        If nb_inscrits <> 0 Then
                            If .zRelations_Ext_UTB = True Then
                                req_nb = "select count(distinct(email)) from (select * from adherents WHERE Email<>'' and  statut is null or statut=''or statut <>'R') as A , (select * from inscriptions_conferences where Saison='" & .zSaison & "') as B ,(select * from relations_utb) as C  where a.id_adherent=b.id_adherent or a.id_adherent=c.id_adherent"
                                Req = "select distinct(email)from (select * from adherents WHERE Email<>'' and  statut is null or statut=''or statut<>'R') as A , (select * from inscriptions_conferences where Saison='" & .zSaison & "') as B ,(select * from relations_utb) as C  where a.id_adherent=b.id_adherent or a.id_adherent=c.id_adherent"
                            Else
                                req_nb = "select count(distinct(email)) from (select * from adherents WHERE Email<>'' and  statut is null or statut=''or statut<>'R') as A , (select * from inscriptions_conferences where Saison='" & .zSaison & "') as B  where a.id_adherent=b.id_adherent"
                                Req = "select distinct(email) from (select * from adherents WHERE Email<>'' and  statut is null or statut=''or statut<>'R') as A , (select * from inscriptions_conferences where Saison='" & .zSaison & "') as B  where a.id_adherent=b.id_adherent"
                            End If
                        Else
                            If .zRelations_Ext_UTB = True Then
                                req_nb = "select count(distinct(email)) from (select * from adherents WHERE Email<>'' and  statut is null or statut=''or statut<>'R') as A , (select * from relations_utb) as C  where  a.id_adherent=c.id_adherent"
                                Req = "select distinct(email) from (select * from adherents WHERE Email<>'' and  statut is null or statut=''or statut<>'R') as A , (select * from relations_utb) as C  where  a.id_adherent=c.id_adherent"
                            Else
                                req_nb = "select count(distinct(email)) from (select * from adherents WHERE Email<>'' and  statut is null or statut=''or statut<>'R') as A , (select * from inscriptions_conferences where Saison='" & .zSaison & "') as B  where a.id_adherent=b.id_adherent"
                                Req = "select distinct(email) from (select * from adherents WHERE Email<>'' and  statut is null or statut=''or statut<>'R') as A , (select * from inscriptions_conferences where Saison='" & .zSaison & "') as B  where a.id_adherent=b.id_adherent"
                            End If
                        End If
                End Select
            End Select
    End With
suite_100:
    rs.Open req_nb
        Nb = rs.Fields("count(distinct(email))")
    rs.Close
    'Tri par fournisseurs d'accès
    'rs.Open req & " order by Mid(Email, InStr(Email, '@') + 1, Length(Email) - InStr(Email, '@')), left(email,4)"
    'Tri par mails
    rs.Open Req & " order by Email"
    If Not (rs.EOF = True And rs.BOF = True) Then
        rs.MoveFirst
    End If
   k = 0
   j = 2
   msg = ""
   Email = ""
   nb_groupe = frmMailings_New.zNb_Groupes
   With Fc(6)
        '.Activate
        .Rows("1:1").RowHeight = 46
        Lg = .Columns("A").Find("").Row
        With .Range("A2:B" & Lg)
            .ClearContents
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlTop
            .WrapText = True
            .Orientation = 0
            .AddIndent = False
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .Rows("2:12").EntireRow.AutoFit
        End With
        Entête_0 = " - Liste, par groupes de " & nb_groupe & ", des mails de la sélection comprenant : "
        With frmMailings_New
            Select Case Right(.zAdhérents_Saison.Caption, 4)
                Case Left(.zSaison, 4)
                    Entête_1 = "- les adhérents de la saison précedente : " & Right(.zAdhérents_Saison.Caption, 9)
                    Entête_2 = "- les nouveaux adhérents de la saison en cours : " & .zSaison
                Case Right(.zSaison, 4)
                    Entête_1 = "- les adhérents de la saison en cours : " & frmMailings.zSaison
                    Entête_2 = ""
            End Select
            Select Case .zRelations_Ext
                Case True
                    Entête_3 = "- les relations extérieures de l'UTB"
                Case Else
                    Entête_3 = ""
            End Select
            Entête_4 = "Situation au : " & Format(Now, "dd/mm/yyyy")
        End With
        entête = Entête_4 & " " & Entête_0 & Chr(10) & Entête_1 & " " & Entête_2 & " " & Entête_3 '& Chr(10) & Entête_4
        .Range("A1") = entête
            Do Until rs.EOF
                msg = rs.Fields("email")
                If msg = "" Then GoTo suite45
                'If Msg = "f-m.fievet@orange.fr" Then
                   'MsgBox Msg
               ' End If
                If msg <> "" Then
                        Email = Email & ";" & msg
                        k = k + 1
                End If
                If k Mod nb_groupe = 0 Then
                    .Range("A" & j) = k
                    .Range("B" & j) = Right(Email, Len(Email) - 1)
                    j = j + 1
                    msg = ""
                    Email = ""
                End If
suite45:
            rs.MoveNext
            Loop
             If k < nb_groupe And Email <> "" Then
                .Range("A" & j) = Nb
                .Range("B" & j) = Right(Email, Len(Email) - 1)
            Else
                .Range("B" & j) = "Pas de mails pour votre sélection"
            End If
    End With
'Fermeture de l'enregistrement
    rs.Close
'Affichage
    MsgBox "Traitement terminé"
    If val(frmMail_Evolution.Tag) = 1 Then Exit Sub
Exit Sub
    Application.ScreenUpdating = True
   ' Workbooks("Editions.xlsm").Activate
    With Workbooks("Editions.xlsm")
        .Activate
        .Sheets("Listes Mailings").Select
   End With
    With ActiveWindow
        .ScrollColumn = 1
        .ScrollRow = 1
    End With

End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Préparation d'envoi d'Emails aux adhérents et relations extérieures de l'UTB
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub pEnvoi_Emails()
    pInit
    With frmMailings
        .Caption = Space(5) & "U.T.B. Montceau-les-Mines - Préparation du mailing"
        .zNb_Groupes = 30
        pListe_Saisons ("frmMailings")
'Présélection des adresses mail
        .zMessage = "Traitement réalisé sur la base opérationnelle."
        'Opt = frmMail_Evolution.Tag
       ' If Opt = 1 Then
            .OptionButton1 = True
            .zRelations_Ext_UTB = True
       ' Else
            '.OptionButton1.Visible = False
            With .OptionButton2
                .Value = True
                '.Enabled = False
            End With
            'With .zRelations_Ext_UTB
                '.Value = False
                '.Visible = False
            'End With
        'End If
        .Show
    End With
    Select Case Ret
        Case 1
            GoTo suite
        Case 0
            Exit Sub
    End Select
   
suite:
    Dim rs As ADODB.Recordset
    Dim fld As ADODB.Field
    Dim i, L, Nb

    Set rs = New ADODB.Recordset
    rs.CursorLocation = adUseServer
    Test_Serveur
    rs.Open "set sql_big_selects=1;", conn

'Test de la base des relations UTB
    rs.Open " select count(*) from relations_utb", conn
    nb_relations = rs.Fields("count(*)")
    rs.Close
'Etablissement du mailing
     With frmMailings
        Select Case nb_relations
            Case 0
                 Select Case Right(.zAdhérents_Saison.Caption, 4)
                    Case Left(.zSaison, 4) 'Saison précedente
                        If .zRelations_Ext_UTB = True Then
                            req_nb = "select count(distinct(email)) from (select * from adherents WHERE Email<>'' and  statut is null or statut=''or statut<>'R') as A , (select * from inscriptions_conferences where Saison='" & Right(.zAdhérents_Saison.Caption, 9) & "'    union select * from inscriptions_conferences where Saison='" & .zSaison & "' ) as B   where a.id_adherent=b.id_adherent"
                            Req = "select distinct(email) from (select * from adherents WHERE Email<>'' and  statut is null or statut=''or statut<>'R') as A , (select * from inscriptions_conferences where Saison='" & Right(.zAdhérents_Saison.Caption, 9) & "'    union select * from inscriptions_conferences where Saison='" & .zSaison & "' ) as B   where a.id_adherent=b.id_adherent"
                        Else
                            req_nb = "select count(distinct(email)) from (select * from adherents WHERE Email<>'' and  statut is null or statut=''or statut<>'R') as A , (select * from inscriptions_conferences where Saison='" & Right(.zAdhérents_Saison.Caption, 9) & "'    union select * from inscriptions_conferences where Saison='" & .zSaison & "' ) as B  where a.id_adherent=b.id_adherent "
                            Req = "select distinct(email) from (select * from adherents WHERE Email<>'' and  statut is null or statut=''or statut<>'R') as A , (select * from inscriptions_conferences where Saison='" & Right(.zAdhérents_Saison.Caption, 9) & "'    union select * from inscriptions_conferences where Saison='" & .zSaison & "' ) as B  where a.id_adherent=b.id_adherent"
                        End If
                    Case Right(.zSaison, 4) 'Saison en cours
                        If .zRelations_Ext_UTB = True Then
                            req_nb = "select count(distinct(email)) from (select * from adherents WHERE Email<>'' and  statut is null or statut=''or statut<>'R') as A , (select * from inscriptions_conferences where Saison='" & .zSaison & "') as B  where a.id_adherent=b.id_adherent and a.email<>''"
                            Req = "select distinct(email) from (select * from adherents WHERE Email<>'' and  statut is null or statut=''or statut<>'R') as A , (select * from inscriptions_conferences where Saison='" & .zSaison & "'    union select * from inscriptions_conferences where Saison='" & .zSaison & "' ) as B where a.id_adherent=b.id_adherent and a.email<>''"
                        Else
                            req_nb = "select count(distinct(email)) from (select * from adherents where Email<>'' and  statut is null or statut=''or statut<>'R') as A , (select * from inscriptions_conferences where Saison='" & .zSaison & "' ) as B  where a.id_adherent=b.id_adherent and a.email<>''"
                            Req = "select distinct(email) from (select * from adherents WHERE Email<>'' and  statut is null or statut=''or statut<>'R' ) as A , (select * from inscriptions_conferences where Saison='" & .zSaison & "'    union select * from inscriptions_conferences where Saison='" & .zSaison & "' ) as B  where a.id_adherent=b.id_adherent and a.email<>''"
                        End If
                End Select
            Case Else
                Select Case Right(.zAdhérents_Saison.Caption, 4)
                    Case Left(.zSaison, 4)  'Saison précedente
                        If .zRelations_Ext_UTB = True Then
                            req_nb = "select count(distinct(email)) from (select * from adherents WHERE Email<>'' and  statut is null or statut=''or statut<>'R') as A , (select * from inscriptions_conferences where Saison='" & Right(.zAdhérents_Saison.Caption, 9) & "'union select * from inscriptions_conferences where Saison='" & .zSaison & "' ) as B ,(select * from relations_utb) as C  where a.id_adherent=b.id_adherent or a.id_adherent=c.id_adherent"
                            Req = "select distinct(email) from (select * from adherents WHERE Email<>'' and  statut is null or statut='' or statut<>'R') as A , (select * from inscriptions_conferences where Saison='" & Right(.zAdhérents_Saison.Caption, 9) & "'union select * from inscriptions_conferences where Saison='" & .zSaison & "' ) as B ,(select * from relations_utb) as C  where a.id_adherent=b.id_adherent or a.id_adherent=c.id_adherent"
                        Else
                            req_nb = "select count(distinct(email)) from (select * from adherents WHERE Email<>'' and  statut is null or statut=''or statut<>'R') as A , (select * from inscriptions_conferences where Saison='" & Right(.zAdhérents_Saison.Caption, 9) & "'    union select * from inscriptions_conferences where Saison='" & .zSaison & "' ) as B  where a.id_adherent=b.id_adherent"
                            Req = "select distinct(email) from (select * from adherents WHERE Email<>'' and  statut is null or statut=''or statut<>'R') as A , (select * from inscriptions_conferences where Saison='" & Right(.zAdhérents_Saison.Caption, 9) & "'union select * from inscriptions_conferences where Saison='" & .zSaison & "' ) as B  where a.id_adherent=b.id_adherent"
                        End If
                    Case Right(.zSaison, 4) 'Saison en cours
                        rs.Open " select count(*) from inscriptions_conferences where saison ='" & .zSaison & "'", conn
                            nb_inscrits = rs.Fields("count(*)")
                        rs.Close
                        If nb_inscrits <> 0 Then
                            If .zRelations_Ext_UTB = True Then
                                req_nb = "select count(distinct(email)) from (select * from adherents WHERE Email<>'' and  statut is null or statut=''or statut <>'R') as A , (select * from inscriptions_conferences where Saison='" & .zSaison & "') as B ,(select * from relations_utb) as C  where a.id_adherent=b.id_adherent or a.id_adherent=c.id_adherent"
                                Req = "select distinct(email)from (select * from adherents WHERE Email<>'' and  statut is null or statut=''or statut<>'R') as A , (select * from inscriptions_conferences where Saison='" & .zSaison & "') as B ,(select * from relations_utb) as C  where a.id_adherent=b.id_adherent or a.id_adherent=c.id_adherent"
                            Else
                                req_nb = "select count(distinct(email)) from (select * from adherents WHERE Email<>'' and  statut is null or statut=''or statut<>'R') as A , (select * from inscriptions_conferences where Saison='" & .zSaison & "') as B  where a.id_adherent=b.id_adherent"
                                Req = "select distinct(email) from (select * from adherents WHERE Email<>'' and  statut is null or statut=''or statut<>'R') as A , (select * from inscriptions_conferences where Saison='" & .zSaison & "') as B  where a.id_adherent=b.id_adherent"
                            End If
                        Else
                            If .zRelations_Ext_UTB = True Then
                                req_nb = "select count(distinct(email)) from (select * from adherents WHERE Email<>'' and  statut is null or statut=''or statut<>'R') as A , (select * from relations_utb) as C  where  a.id_adherent=c.id_adherent"
                                Req = "select distinct(email) from (select * from adherents WHERE Email<>'' and  statut is null or statut=''or statut<>'R') as A , (select * from relations_utb) as C  where  a.id_adherent=c.id_adherent"
                            Else
                                req_nb = "select count(distinct(email)) from (select * from adherents WHERE Email<>'' and  statut is null or statut=''or statut<>'R') as A , (select * from inscriptions_conferences where Saison='" & .zSaison & "') as B  where a.id_adherent=b.id_adherent"
                                Req = "select distinct(email) from (select * from adherents WHERE Email<>'' and  statut is null or statut=''or statut<>'R') as A , (select * from inscriptions_conferences where Saison='" & .zSaison & "') as B  where a.id_adherent=b.id_adherent"
                            End If
                        End If
                End Select
            End Select
    End With

    rs.Open req_nb
        Nb = rs.Fields("count(distinct(email))")
    rs.Close
    'Tri par fournisseurs d'accès
    'rs.Open req & " order by Mid(Email, InStr(Email, '@') + 1, Length(Email) - InStr(Email, '@')), left(email,4)"
    'Tri par mails
    rs.Open Req & " order by Email"
    If Not (rs.EOF = True And rs.BOF = True) Then
        rs.MoveFirst
    End If
   k = 0
   j = 2
   msg = ""
   Email = ""
   nb_groupe = frmMailings.zNb_Groupes
   With Fc(6)
        '.Activate
        .Rows("1:1").RowHeight = 46
        Lg = .Columns("A").Find("").Row
        With .Range("A2:B" & Lg)
            .ClearContents
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlTop
            .WrapText = True
            .Orientation = 0
            .AddIndent = False
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .Rows("2:12").EntireRow.AutoFit
        End With
        Entête_0 = " - Liste, par groupes de " & nb_groupe & ", des mails de la sélection comprenant : "
        With frmMailings
            Select Case Right(.zAdhérents_Saison.Caption, 4)
                Case Left(.zSaison, 4)
                    Entête_1 = "- les adhérents de la saison précedente : " & Right(.zAdhérents_Saison.Caption, 9)
                    Entête_2 = "- les nouveaux adhérents de la saison en cours : " & .zSaison
                Case Right(.zSaison, 4)
                    Entête_1 = "- les adhérents de la saison en cours : " & frmMailings.zSaison
                    Entête_2 = ""
            End Select
            Select Case .zRelations_Ext_UTB
                Case True
                    Entête_3 = "- les relations extérieures de l'UTB"
                Case Else
                    Entête_3 = ""
            End Select
            Entête_4 = "Situation au : " & Format(Now, "dd/mm/yyyy")
        End With
        entête = Entête_4 & " " & Entête_0 & Chr(10) & Entête_1 & " " & Entête_2 & " " & Entête_3 '& Chr(10) & Entête_4
        .Range("A1") = entête
            Do Until rs.EOF
                msg = rs.Fields("email")
                If msg = "" Then GoTo suite45
                'If Msg = "f-m.fievet@orange.fr" Then
                   'MsgBox Msg
               ' End If
                If msg <> "" Then
                        Email = Email & ";" & msg
                        k = k + 1
                End If
                If k Mod nb_groupe = 0 Then
                    .Range("A" & j) = k
                    .Range("B" & j) = Right(Email, Len(Email) - 1)
                    j = j + 1
                    msg = ""
                    Email = ""
                End If
suite45:
            rs.MoveNext
            Loop
             If k < nb_groupe And Email <> "" Then
                .Range("A" & j) = Nb
                .Range("B" & j) = Right(Email, Len(Email) - 1)
            Else
                .Range("B" & j) = "Pas de mails pour votre sélection"
            End If
    End With
'Fermeture de l'enregistrement
    rs.Close
'Affichage
    MsgBox "Traitement terminé"
    If val(frmMail_Evolution.Tag) = 1 Then Exit Sub
Exit Sub
    Application.ScreenUpdating = True
   ' Workbooks("Editions.xlsm").Activate
    With Workbooks("Editions.xlsm")
        .Activate
        .Sheets("Listes Mailings").Select
   End With
    With ActiveWindow
        .ScrollColumn = 1
        .ScrollRow = 1
    End With

End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Pointage des adhérents informés par mail
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub pEnvoi_Emails_Pointage()
'Mise à jour de la liste des adhérents
 '   pEdition_Liste_Adhérents
'Pointage

    '
    'Dim rs As ADODB.Recordset
   ' Dim fld As ADODB.Field
   ' Dim i, L, nb
    
'Ouverture de la connexion
    
   
   ' conn.Open
'Liste des adhérents informés en direct par email
    Set rs = New ADODB.Recordset
    rs.CursorLocation = adUseServer
    rs.Open "set sql_big_selects=1;", conn
    'rs.Close
    With Fc(5)
        i = 3
        Nb = .Columns("A").Find("").Row - 1
        If Nb = 2 Then Exit Sub
        .Range("M" & Nb).ClearContents
       With .Range("M" & Nb).Interior
            .Pattern = xlNone
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
        For Each cel In .Range("L3:L" & Nb)
            ID = cel
            rs.Open "SELECT count(Email) FROM inscriptions_conferences ,adherents where adherents.ID_Adherent= " & ID & " and inscriptions_conferences.saison='" & frmEdition.zSaison & "' and adherents.ID_Adherent=inscriptions_conferences.ID_adherent and adherents.email<>'' order by nom", conn
            
            'If Not (rs.EOF = True And rs.BOF = True) Then
               ' rs.MoveFirst
            'End If
            Nb = rs.Fields("count(Email)")
            If Nb <> 0 Then
            .Range("M" & i) = "D"
            Else
            .Range("M" & i) = ""
            End If
            rs.Close
            i = i + 1
        Next
    End With
  'Liste des adhérents informés en par email via le réseau
   'Exit Sub
    With Fc(5)
        i = 3
        Nb = .Columns("A").Find("").Row - 1
        .Range("N" & Nb).ClearContents
        .Range("N" & Nb).ClearFormats
        For Each cel In .Range("L3:L" & Nb)
            ID = cel
            
            rs.Open "SELECT   count(reseau.Contacts),adherents.Nom FROM inscriptions_conferences ,adherents,reseau where adherents.ID_Adherent= " & ID & " and adherents.ID_Adherent=reseau.ID_adherent  and inscriptions_conferences.saison='" & frmSaison.zSaison & "' and adherents.ID_Adherent=inscriptions_conferences.ID_adherent order by nom;"
            Nb = rs.Fields("count(reseau.Contacts)")

            If .Range("M" & i) <> "D" Then
                If Nb <> 0 Then
                    .Range("M" & i) = "R"
                Else
                    .Range("M" & i) = "Non joint par email et son réseau"
                End If
            Else
                If Nb <> 0 Then
                    .Range("M" & i) = "D + R"
               
…
vbaProject_00.bin vba-project OOXML VBA project: xl/vbaProject.bin 417280 bytes
SHA-256: f67baf7ff9f092ccd429567c7fbb8579d17134fe6553470ab36d0ef537c2afa0

Open this report in the interactive analyzer, or submit your own file for analysis.