openaccess/test/source/modules/Utilitaires.bas

Option Compare Database
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_DONTGOBELOWDOMAIN = 2
Private Const BIF_NEWDIALOGSTYLE As Long = &H40

Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, _
    ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, _
    ByVal lpString2 As String) As Long

Private 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

Function Environ(VarName)
    Dim wss, env
    Set wss = CreateObject("WScript.Shell")
    Set env = wss.environment("process")
    Environ = env(VarName)
    If Environ = "" Then
        Set env = wss.environment("system")
        Environ = env(VarName)
    End If
End Function

Public Sub ImprEtats(ByVal stEtat As String, ByVal itCopies As Integer, ByVal critere As String)
'imprime un état en plusieurs exemplaires
 ' stEtat   : nom de l'état
 ' itCopies : nombre de copies
DoCmd.OpenReport stEtat, acViewPreview, , critere
DoCmd.PrintOut acPages, , , , itCopies
DoCmd.Close acReport, stEtat
End Sub

Public Sub ExportBordereau(ByVal NomBord As String, ByVal moisRH As Integer, ByVal anneeRH As Integer)
Dim OuvAutoPdf As Boolean
Dim NomMois, repPDF As String

If MsgBox("Voulez-vous ouvrir le PDF une fois créé?", vbYesNo) = vbYes Then
 OuvAutoPdf = True
Else
 OuvAutoPdf = False
End If

repPDF = chemin(moisRH, anneeRH)
NomMois = Left(UCase(MonthName(moisRH)), 4)

If repPDF = "" Then
 Call MsgBox("Vous devez définir un répertoire de stockage pour utiliser cette fonction.", , NomEtat)
 Exit Sub
End If

If dir(repPDF, 16) = "" Then MkDir (repPDF)

critere = "[MoisRH]=" & moisRH & " AND [AnneeRH]=" & anneeRH

DoCmd.OpenReport NomBord, acViewPreview, , critere
DoCmd.OutputTo acOutputReport, , "PDF", repPDF & NomBord & "_" & NomMois & anneeRH & ".pdf", OuvAutoPdf
DoCmd.Close acReport, NomBord

End Sub

Public Sub ExportEtatPDF(ByVal NomEtat As String, ByVal CodeAgent As String, ByVal moisRH As Integer, ByVal anneeRH As Integer)
Dim OuvAutoPdf As Boolean
Dim NomMois, repPDF, nomFichier, NomAgent, critere, str As String

OuvAutoPdf = False

NomAgent = Nz(Split(DLookup("Nom", "r_Agents", "[CodeAgent]='" & CodeAgent & "'"), " ")(0), "") & "." & _
           Left(Nz(Split(DLookup("Nom", "r_Agents", "[CodeAgent]='" & CodeAgent & "'"), " ")(1), ""), 1)

If NomAgent = "" Then
  'erreur nom
  NomAgent = Nz(InputBox("L'application n'a pas trouvé le nom de famille de l'agent. Celui ci doit se trouver dans la table tbl_Equipe, au format 'NOM Prenom'. Vous pouvez le renseigner manuellement:"), "")
  If NomAgent = "" Then Exit Sub
End If

repPDF = chemin(moisRH, anneeRH)
'NomMois = Left(UCase(MonthName(moisRH)), 4)
'NomFichier=NomAgent & "_" & NomMois & anneeRH & "_" & NomEtat & ".pdf"


If Len(CStr(moisRH)) = 1 Then
  NomMois = anneeRH & "0" & moisRH
Else
  NomMois = anneeRH & moisRH
End If

nomFichier = NomAgent & "_" & NomMois & "_" & NomEtat & ".pdf"

If repPDF = "" Then
 Call MsgBox("Vous devez définir un répertoire de stockage pour utiliser cette fonction.", , NomEtat)
 Exit Sub
End If

If dir(repPDF, 16) = "" Then MkDir (repPDF)

critere = "[CodeAgent]='" & CodeAgent & "' AND [MoisRH]=" & moisRH & " AND [AnneeRH]=" & anneeRH

nomFichier = repPDF & NomAgent & "_" & NomMois & "_" & Replace(NomEtat, "Et_", "") & ".pdf"

DoCmd.OpenReport NomEtat, acViewPreview, , critere
DoCmd.OutputTo acOutputReport, , "PDF", nomFichier, OuvAutoPdf
DoCmd.Close acReport, NomEtat

End Sub




Public Function SelectFolder(titre As String, Handle As Long) As String

Dim lpIDList As Long
Dim strBuffer As String
Dim strTitre As String
Dim tBrowseInfo As BrowseInfo

strTitre = titre
With tBrowseInfo
    .hwndOwner = Handle
    .lpszTitle = lstrcat(strTitre, "")
    .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN + BIF_NEWDIALOGSTYLE
End With

lpIDList = SHBrowseForFolder(tBrowseInfo)

If (lpIDList) Then
    strBuffer = String(260, vbNullChar)
    SHGetPathFromIDList lpIDList, strBuffer
    SelectFolder = Left(strBuffer, InStr(strBuffer, vbNullChar) - 1)
End If

End Function

Public Function NomImpr(Optional PremCo As Boolean)
'ouvre le formulaire frm_ChoixImpr et renvoie le nom de l'imprimante choisie

'ouverture du formulaire
DoCmd.OpenForm "frm_ChoixImpr"

If PremCo = True Then MsgBox "VEUILLEZ TOUT D'ABORD CHOISIR L'IMPRIMANTE QUE DEVRA UTILISER VOTRE APPLICATION" & vbNewLine & "(Vous pourrez ensuite en changer à partir du menu 'parametres', accessible depuis l'écran d'accueil)"

'la fonction reste en attente jusqu'à ce qu'une imprimante ait été choisie
Do Until Nz(forms![frm_ChoixImpr].impr, "") <> ""
 DoEvents
Loop

'récupération du nom de l'imprimante
If Not forms![frm_ChoixImpr].impr = "annuler" Then
 NomImpr = Nz(forms![frm_ChoixImpr].impr, "")
Else
 NomImpr = ""
End If
'fermeture du formulaire
DoCmd.Close acForm, "frm_ChoixImpr"

End Function

Public Function Attendre(tps As Double)
'tps en ms
Dim t0, t As Single

t0 = Timer

Do Until 1000 * (t - t0) >= tps
 t = Timer
 DoEvents
Loop

End Function

Sub testchrono()
MsgBox "1"
Call Attendre(5000) '5s
MsgBox "2"
End Sub

Public Function OuvrirRepertoire(chemin As String)
 
    'validité du chemin
    If (IsNull(chemin)) Then
        MsgBox ("Chemin d'accès non valide")
        Exit Function
    End If
    
    'existence du répertoire
    If (dir(chemin, vbDirectory) <> "") Then
        'Appel de l'explorateur Windows
        Shell "explorer " & chemin, vbNormalFocus
    Else
        MsgBox ("Ce répertoire n'existe pas")
    End If
 
End Function

Public Function ChercherNomFichier()
Dim initialFileName As Variant

' Displays the Office File Open dialog to choose a file name
' for the current employee record.
Dim fileName As String
Dim result As Integer


With Application.FileDialog(3) ' 3 is a constant: msoFileDialogFilePicker
.Title = "Selection d'un fichier à importer"
.Filters.Add "All Files", "*.*"
.Filters.Add "XML", "*.xml"
.FilterIndex = 2
.AllowMultiSelect = False


initialFileName = DLookup("Valeur", "tbl_parametre", "Parametre = 'RepXML'")
If dir(initialFileName) = "" Then initialFileName = DLookup("Valeur", "tbl_parametre", "Parametre = 'RepXML_defaut'")

If IsNull(initialFileName) Then
    initialFileName = fCurrentDBDir
End If
.initialFileName = initialFileName
result = .Show
If (result <> 0) Then 'result = 0 if nothing was selected
fileName = Trim(.SelectedItems.Item(1))
'filename contains the path you want.
ChercherNomFichier = fileName

End If
End With

End Function


Public Sub ImportXMLPDA(ByVal strfilename As String)

'déclaration file system object
Dim FSO
'instanciation
Set FSO = CreateObject("Scripting.FileSystemObject")

'importation des données xml
Application.ImportXML DataSource:=strfilename, ImportOptions:=acAppendData
    
End Sub

Public Function ExtraitNomFichier(strNomFichierCplt As String) As String
Dim i, j As Long
j = InStr(1, strNomFichierCplt, "\")
Do
i = j
j = InStr(i + 1, strNomFichierCplt, "\")
Loop Until j = 0
ExtraitNomFichier = Mid(strNomFichierCplt, i + 1, Len(strNomFichierCplt) - i)
End Function
Public Function ExtraitNomRep(strNomFichierCplt As String) As String
Dim i, j As Long
j = InStr(1, strNomFichierCplt, "\")
Do
i = j
j = InStr(i + 1, strNomFichierCplt, "\")
Loop Until j = 0
ExtraitNomRep = Mid(strNomFichierCplt, 1, i)
End Function

Function ReformateDate(InputDate As String) As Date 'change le format date importé en format intelligible ACCESS

Dim DateCourte As String
Dim y As String
Dim m As String
Dim d As String
Dim DateOrdre As String

DateCourte = Left(InputDate, 10)
y = Left(DateCourte, 4)
m = Mid(DateCourte, 6, 2)
d = Right(DateCourte, 2)
DateOrdre = d & "/" & m & "/" & y
ReformateDate = CDate(DateOrdre)

End Function

Public Function NomAgentAbrege(Nom As String)

If Not Len(Nom) > 0 Or Not UBound(Split(Nom, " ")) > 0 Then
 NomAgentAbrege = Nom
 Exit Function
End If

NomAgentAbrege = Left(Split(Nom, " ")(1), 1) & "." & Split(Nom, " ")(0)

End Function

Public Function parametre(ByVal param As String, Optional ByVal valeur2 As String)
'renvoie la valeur d'un paramètre demandé depuis tbl_parametre
Dim critere As String

If Not IsNull(valeur2) And valeur2 <> "" Then
 critere = "[parametre]='" & param & "' AND [valeur2]='" & valeur2 & "'"
Else
 critere = "[parametre]='" & param & "'"
End If

parametre = Nz(DLookup("valeur", "tbl_parametre", critere), Null)


End Function

Public Function chemin(ByVal moisRH As Integer, ByVal anneeRH As Integer)
'renvoie la valeur du répertoire PDF de la table tbl_ParamUtil
Dim critere, str As String

critere = "[parametre]='repPDF' AND [User]='" & CurrentUser & "'"

If Not moisRH > 0 Or Not moisRH <= 12 Or Not anneeRH > 2000 Then
chemin = Nz(DLookup("valeur", "tbl_ParamUtil", critere), "")
Exit Function
End If

'chemin = Nz(DLookup("valeur", "tbl_ParamUtil", critere), "") & "\" & Left(UCase(MonthName(moisRH)), 4) & anneeRH & "\"

chemin = Nz(DLookup("valeur", "tbl_ParamUtil", critere), "")
If Right(chemin, 1) <> "\" Then chemin = chemin & "\"

str = CStr(anneeRH) & "-"
If Len(CStr(moisRH)) = 1 Then str = str & "0"
str = str & moisRH

chemin = Nz(DLookup("valeur", "tbl_ParamUtil", critere), "") & str & "\"

End Function

Public Sub MAJParametre(ByVal param As String, ByVal Valeur As Variant, Optional ByVal valeur2 As String)
'met à jour une valeur de la table parametre
Dim critere As String

If Not Nz(valeur2, "") = "" Then
 critere = "[parametre]='" & param & "' AND [valeur2]='" & valeur2 & "'"
Else
 critere = "[parametre]='" & param & "'"
End If
DoCmd.SetWarnings False
DoCmd.RunSQL "UPDATE tbl_parametre SET tbl_parametre.valeur = '" & Valeur & "' WHERE " & critere & ";"
DoCmd.SetWarnings True
End Sub