Actualité informatique
Test comparatif matériel informatique
Jeux vidéo
Astuces informatique
Vidéo
Télécharger
Services en ligne
Forum informatique
01Business

|-  LOGICIELS


|||-  

Erreur compilation excel

 

18 utilisateurs inconnus
Ajouter une réponse
 

 
Page photos
 
 Mot :  Pseudo :  
Vider la liste des messages à citer
 
 Page :
1
Auteur
 Sujet :

Erreur compilation excel

Prévenir les modérateurs en cas d'abus 
choukie01
  1. Posté le 27/01/2019 à 15:58:00  
  1. answer
  1. Prévenir les modérateurs en cas d'abus
 
Bonjour à tous,
Depuis quelque temps systématiquement lors de l'ouverture d'excel plusieurs fenêtres s'ouvrent avec Microsoft Visual Basic "erreur compilation" Vérifiez et mettez à jour instructions Déclare … attribut PtrSfafe.
Après plusieurs recherches j'ai intégré le message PtrSafe dans les lignes rouges après le mot Declare mais une fois cela fait rien ne bouge je ne sais pas comment valider ma modification. Même si je ferme la fenêtre ça recommence au lancement suivant. Comment dois je procéder pour ne plus avoir ses fenêtres???
Merci par avance pour votre aide

  1. config
tintin10
Habitué (de 5 000 à 9 999 messages postés) Développeur
  1. Posté le 27/01/2019 à 16:41:21  
  1. answer
  1. Prévenir les modérateurs en cas d'abus
 
Bonjour. Aurais-tu du code V.B.A. qui s'exécute au démarrage du logiciel ? Si oui, pourrais-tu le poster, s'il te plaît ?


---------------
Configuration matérielle : voir ce lien
Merci de respecter les règles du forum
(Publicité)
choukie01
  1. Posté le 28/01/2019 à 10:20:00  
  1. answer
  1. Prévenir les modérateurs en cas d'abus
 
Merci je ne sais pas ce qu'est un code VBA mais j'ai cela qui s'affiche
Code :(Double-cliquez pour supprimer les numéros de ligne)
  1. ' --------------------------
  2. '
  3. ' Macro de mise à jour de la macro QuadraBureautique
  4. ' et de QuadraPaie pour Excel
  5. '
  6. '------------------------------------------------------
  7.  
  8. Option Explicit
  9.  
  10. Public Const NOM_CMDBAR As String = "QXLMaj"
  11.  
  12. Public Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
  13.  
  14. Public Type SHFILEOPSTRUCT
  15.  hWnd As Long
  16.  wFunc As Long
  17.  pFrom As String
  18.  pTo As String
  19.  fFlags As Long
  20.  fAnyOperationsAborted As Long
  21.  hNameMappings As Long
  22.  lpszProgressTitle As String
  23. End Type
  24.  
  25. Public Const FO_MOVE = &H1
  26. Public Const FO_COPY = &H2
  27. Public Const FO_DELETE = &H3
  28. Public Const FO_RENAME = &H4
  29. Public Const FOF_NOCONFIRMATION = &H10
  30. Public Const FOF_NOCONFIRMMKDIR = &H200
  31. Public Const FOF_RENAMEONCOLLISION = &H8
  32. Public Const FOF_SILENT = &H4
  33. Public Const FOF_ALLOWUNDO = &H40
  34. Public Const FOF_WANTMAPPINGHANDLE = &H20
  35.  
  36. Public TypeEntree As String
  37. Public bufSrc As String, bufDst As String
  38.  
  39. '--------
  40. '<<CreeTb
  41. '--------
  42. Public Sub CreeTb()
  43.  On Error Resume Next
  44.  Dim MyCmdBar As CommandBar
  45.  
  46.  If Not ReadCmdFile Then
  47. 'Desinstallation de la macro de mise a jour
  48.    AddIns("QXLMaj").Installed = False
  49.    Exit Sub
  50.  End If
  51.  
  52.  CommandBars(NOM_CMDBAR).Delete
  53.  Set MyCmdBar = CommandBars.Add(Name:=NOM_CMDBAR, Position:=msoBarFloating) '.Visible = True
  54.  MyCmdBar.Visible = True
  55.  CommandBars(NOM_CMDBAR).Controls.Add Type:=msoControlButton, before:=1
  56.  
  57.  With MyCmdBar
  58.    With .Controls(1)
  59.      .Style = msoButtonIconAndCaption
  60.      .FaceId = 362
  61.      Select Case TypeEntree
  62.        Case "QUADRAXL"
  63.          .Caption = "Cliquez ici pour mettre à jour QuadraBureautique"
  64.          .TooltipText = "Cliquez ici pour mettre à jour QuadraBureautique"
  65.        Case "QPAIEXL"
  66.          .Caption = "Cliquez ici pour mettre à jour QuadraPaie pour Excel"
  67.          .TooltipText = "Cliquez ici pour mettre à jour QuadraPaie pour Excel"
  68.      End Select
  69.      .OnAction = "Module1.DoMaj"
  70.    End With
  71.  End With
  72. End Sub
  73.  
  74. '-------
  75. '<<DoMaj
  76. '-------
  77. Public Sub DoMaj()
  78.  Dim ii As Integer
  79.  Dim AddInFound As Boolean
  80.  Dim TmpFile As String
  81.  
  82.  If Not ReadCmdFile() Then
  83. 'Desinstallation de la macro de mise a jour
  84.    AddIns("QXLMaj").Installed = False
  85.    Exit Sub
  86.  End If
  87.  
  88.  If FileExist(bufSrc + ".xla") = False Then
  89.    MsgBox "Fichier 'qxl.tmp' incorrect !" + vbCrLf + "Impossible de faire la mise à jour.", vbExclamation
  90.    Exit Sub
  91.  End If
  92.  If FileExist(bufDst + ".xla") = False Then
  93.    MsgBox "Fichier 'qxl.tmp' incorrect !" + vbCrLf + "Impossible de faire la mise à jour.", vbExclamation
  94.    Exit Sub
  95.  End If
  96.  
  97. 'Recherche de l'indice de la macro complementaire QuadraBureautique
  98.  AddInFound = False
  99.  For ii = 1 To AddIns.Count
  100.    If StrComp(AddIns(ii).Name, TypeEntree + ".xla", vbTextCompare) = 0 Then
  101.      AddInFound = True
  102.      Exit For
  103.    End If
  104.  Next ii
  105.  
  106. 'Si la macro existe et est installee, on la desinstalle
  107.  If AddInFound = True Then
  108.    If AddIns(ii).Installed = True Then AddIns(ii).Installed = False
  109.  End If
  110.  
  111. 'Copie de la macro et du fichier de version
  112.  Call QFileCopySH(bufSrc + ".xla", bufDst + ".xla")
  113.  Call QFileCopySH(bufSrc + ".ver", bufDst + ".ver")
  114.  
  115. 'Reinstallation de la macro QuadraBureautique (meme si elle ne l'etait au prealable...)
  116.  AddIns(ii).Installed = True
  117.  
  118. 'Variables publiques vides, au cas où
  119.  TypeEntree = ""
  120.  bufSrc = ""
  121.  bufDst = ""
  122.  
  123. 'Suppression du fichier qxl.tmp
  124.  On Error Resume Next
  125.  TmpFile = QDirAvecSlash(GetTmpDir())
  126.  If Len(TmpFile) = 0 Then TmpFile = "c:\"
  127.  TmpFile = TmpFile & "qxl.tmp"
  128.  If FileExist(TmpFile) = True Then
  129.    Call QFileDeleteSH(TmpFile)
  130.  End If
  131. '
  132.  TmpFile = "c:\qxl.tmp"
  133.  If FileExist(TmpFile) = True Then
  134.    Call QFileDeleteSH(TmpFile)
  135.  End If
  136.  
  137. 'Desinstallation de la macro de mise a jour
  138.  AddIns("QXLMaj").Installed = False
  139. End Sub
  140.  
  141. Private Function ReadCmdFile() As Boolean
  142.  Dim ii As Integer
  143.  Dim fd As Integer
  144.  Dim buffer As String
  145.  Dim TmpFile As String
  146.  
  147.  TmpFile = "c:\qxl.tmp"
  148.  If FileExist(TmpFile) = False Then
  149.    TmpFile = QDirAvecSlash(GetTmpDir())
  150.    If Len(TmpFile) = 0 Then TmpFile = "c:\"
  151.    TmpFile = TmpFile & "qxl.tmp"
  152.  End If
  153.  
  154. 'Teste l'existence du fichier qxl.tmp contenant les noms des dossiers
  155.  If FileExist(TmpFile) = False Then
  156.    MsgBox "Impossible de retrouver le fichier '" & TmpFile & "' contenant" + vbCrLf + _
  157.      "les répertoires des macros : Impossible d'effectuer la mise à jour !", vbExclamation
  158.    Exit Function
  159.  End If
  160.  
  161. 'Ouverture et interpretation du fichier qxl.tmp
  162.  fd = FreeFile
  163.  Open TmpFile For Input Shared As #fd
  164.  Line Input #fd, buffer
  165.  If QElimine(buffer, "bufsrc=") = True Then
  166.    bufSrc = Trim$(buffer)
  167.  Else
  168.    If QElimine(buffer, "bufdst=") = True Then bufDst = Trim$(buffer)
  169.  End If
  170.  Line Input #fd, buffer
  171.  If QElimine(buffer, "bufsrc=") = True Then
  172.    bufSrc = Trim$(buffer)
  173.  Else
  174.    If QElimine(buffer, "bufdst=") = True Then bufDst = Trim$(buffer)
  175.  End If
  176.  Close #fd
  177.  
  178.  buffer = ""
  179.  For ii = Len(bufSrc) To 1 Step -1
  180.    If Mid$(bufSrc, ii, 1) = "\" Then Exit For
  181.    buffer = Mid$(bufSrc, ii, 1) + buffer
  182.  Next ii
  183.  TypeEntree = UCase$(buffer)
  184.  
  185.  ReadCmdFile = True
  186. End Function
  187.  
  188. '-----------
  189. '<<FileExist
  190. '-----------
  191. Private Function FileExist(NomFichier As String) As Boolean
  192.  On Error GoTo TrtErr
  193.  Dim YaErr As Boolean
  194.  
  195.  YaErr = False
  196.  Call GetAttr(NomFichier)
  197.  FileExist = Not YaErr
  198.  Exit Function
  199.  TrtErr:
  200.    YaErr = True
  201.    Resume Next
  202. End Function
  203.  
  204. '----------
  205. '<<QElimine
  206. '----------
  207. Private Function QElimine(InOutStr As String, Search As String) As Boolean
  208.  QElimine = False
  209.  If Search = "" Then Exit Function
  210.  If Len(InOutStr) < Len(Search) Then Exit Function
  211.  If UCase$(Left$(InOutStr, Len(Search))) <> UCase$(Search) Then Exit Function
  212.  InOutStr = Right$(InOutStr, Len(InOutStr) - Len(Search))
  213.  QElimine = True
  214. End Function
  215.  
  216. '-------------
  217. '<<QFileCopySH
  218. '-------------
  219. Private Function QFileCopySH(pFrom As String, pTo As String) As Long
  220.  On Error GoTo TrtErr
  221.  Dim FileStruct As SHFILEOPSTRUCT
  222.  
  223.  FileStruct.pFrom = pFrom + Chr$(0) + Chr$(0)
  224.  FileStruct.pTo = pTo + Chr$(0) + Chr$(0)
  225.  FileStruct.fFlags = FOF_NOCONFIRMMKDIR + FOF_NOCONFIRMATION
  226.  FileStruct.wFunc = FO_COPY
  227.  QFileCopySH = SHFileOperation(FileStruct)
  228.  Exit Function
  229.  TrtErr:
  230.    MsgBox Err.Description
  231.    Resume Next
  232. End Function
  233.  
  234. '---------------
  235. '<<QFileDeleteSH
  236. '---------------
  237. Private Function QFileDeleteSH(FileName As String) As Long
  238.  On Error Resume Next
  239.  Dim FileStruct As SHFILEOPSTRUCT
  240.  
  241.  FileStruct.pFrom = FileName
  242.  FileStruct.fFlags = FOF_SILENT + FOF_ALLOWUNDO + FOF_NOCONFIRMATION
  243.  FileStruct.wFunc = FO_DELETE
  244.  QFileDeleteSH = SHFileOperation(FileStruct)
  245. End Function
  246.  
  247. Public Function GetTmpDir() As String
  248.  Dim ss As String
  249.  ss = Environ("TEMP")
  250.  If Len(ss) = 0 Then ss = Environ("TMP")
  251.  If Len(ss) = 0 Then ss = Environ("USERPROFILE")
  252.  GetTmpDir = ss
  253. End Function
  254.  
  255. Public Function QDirAvecSlash(ByVal path As String) As String
  256.  path = Trim$(path)
  257.  Do
  258.    If Len(path) = 0 Then Exit Do
  259.    If Right$(path, 1) = "\" Then Exit Do
  260.    path = path + "\"
  261.  Exit Do
  262.  Loop
  263.  QDirAvecSlash = path
  264. End Function


Edit par Tintin10 : rajout des balises de code
Message édité par Tintin10 le 28/01/2019 à 17:18:37
choukie01
  1. Posté le 28/01/2019 à 10:22:01  
  1. answer
  1. Prévenir les modérateurs en cas d'abus
 
J'ai ça aussi
Code :(Double-cliquez pour supprimer les numéros de ligne)
  1. Option Compare Text
  2. Option Explicit
  3.  
  4. Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
  5. Const LR_LOADFROMFILE = &H10
  6. Const IMAGE_BITMAP = 0
  7. Const CF_BITMAP = 2
  8. Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal dwImageType As Long, ByVal dwDesiredWidth As Long, ByVal dwDesiredHeight As Long, ByVal dwFlags As Long) As Long
  9. Private Declare Function CloseClipboard Lib "user32" () As Long
  10. Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
  11. Private Declare Function EmptyClipboard Lib "user32" () As Long
  12. Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
  13. Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
  14. Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
  15. Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
  16. Public Const NomAppli As String = "QPaie Excel"
  17. Public Const NomBarreUtil As String = "QPaie Excel"
  18.  
  19. Public MClicDroit As New EventClassModule
  20. Public FirstActivate As Boolean
  21. '
  22. ' Valeur de retour des feuilles (Ok/Cancel ...)
  23. Public RetourForm As Integer
  24. '
  25. Private RsEsGlob As DAO.Recordset
  26.  
  27. Sub Register_Event_Handler()
  28.  If Not MClicDroit.App Is Nothing Then
  29.    Set MClicDroit.App = Nothing
  30.  End If
  31.  Set MClicDroit.App = Excel.Application
  32. End Sub
  33.  
  34. 'Création de la barre d'outils du Concepteur de modèles
  35. Public Sub Cree_BarreQPaie(Optional DelIfExist As Boolean = False)
  36.  Dim MyCmdBar As CommandBar
  37.  Dim n As Integer, CC As Control
  38.  Dim KeepPos As Boolean
  39.  Dim m_Top As Long
  40.  Dim m_Left As Long
  41.  Dim m_Pos As Long
  42.  KeepPos = False
  43.  If BarreExist(NomBarreUtil) Then
  44. 'On conserve son ancienne position
  45.    Application.CommandBars(NomBarreUtil).Visible = True
  46.    KeepPos = True
  47.    m_Pos = Application.CommandBars(NomBarreUtil).Position
  48.    m_Top = Application.CommandBars(NomBarreUtil).Top
  49.    m_Left = Application.CommandBars(NomBarreUtil).Left
  50.  End If
  51.  
  52.  If DelIfExist Then
  53.    If BarreExist(NomBarreUtil) Then Application.CommandBars(NomBarreUtil).Delete
  54.    Else
  55.    If BarreExist(NomBarreUtil) Then
  56.      If Application.CommandBars(NomBarreUtil).Controls.Count = 2 And Application.CommandBars(NomBarreUtil).Visible = True Then
  57.        Exit Sub
  58.      Else
  59.        Application.CommandBars(NomBarreUtil).Delete
  60.      End If
  61.    End If
  62.  End If
  63.  
  64.  CommandBars.Add(Name:=NomBarreUtil).Visible = True
  65. '2 boutons
  66.  CommandBars(NomBarreUtil).Controls.Add Type:=msoControlButton
  67.  CommandBars(NomBarreUtil).Visible = True
  68.  CommandBars(NomBarreUtil).Controls.Add Type:=msoControlButton
  69.  CommandBars(NomBarreUtil).Visible = True
  70.  
  71.  Set MyCmdBar = Application.CommandBars(NomBarreUtil)
  72.  
  73.  With MyCmdBar
  74.    .Visible = False
  75.  
  76.    .Controls(1).FaceId = 566 'Import depuis Dossier Paie
  77.    .Controls(2).FaceId = 317 'Export vers Dossier Paie
  78.    .Controls(1).Style = msoButtonIcon
  79.    .Controls(2).Style = msoButtonIcon
  80.  
  81.    .Controls(1).Caption = "Impport"
  82.    .Controls(2).Caption = "Export"
  83.  
  84.    .Controls(1).OnAction = "QP_ImportPaie.Import"
  85.    .Controls(2).OnAction = "QP_ExportPaie.Export"
  86.  
  87.    .Controls(1).DescriptionText = "Import à partir du dossier de Paie"
  88.    .Controls(2).DescriptionText = "Export vers dossier de Paie"
  89.  
  90.    .Controls(1).TooltipText = "Import à partir du dossier de Paie"
  91.    .Controls(2).TooltipText = "Export vers dossier de Paie"
  92.  
  93.    If KeepPos Then
  94.      Application.CommandBars(NomBarreUtil).Position = m_Pos
  95.      Application.CommandBars(NomBarreUtil).Top = m_Top
  96.      Application.CommandBars(NomBarreUtil).Left = m_Left
  97.      If Application.CommandBars(NomBarreUtil).Top <> m_Top Then
  98.        Application.CommandBars(NomBarreUtil).Top = m_Top
  99.      End If
  100.      If Application.CommandBars(NomBarreUtil).Top <> m_Left Then
  101.        Application.CommandBars(NomBarreUtil).Top = m_Left
  102.      End If
  103.    End If
  104.    LoadPictureToButton FrmIcones.IcoPaie.Picture, .Controls(2)
  105.  End With
  106.  
  107.  Exit Sub
  108.  
  109.  trterr:
  110.    Exit Sub
  111. End Sub
  112.  
  113. Public Sub LoadPictureToButton(Pic As Object, Btn As Object)
  114.  On Error Resume Next
  115.  Dim hBit As Long
  116.  Dim BmpFile As String
  117.  BmpFile = QTmpFile
  118.  SavePicture Pic, BmpFile
  119.  If Not FileExist(BmpFile) Then Exit Sub
  120.  If OpenClipboard(0) = 1 Then
  121.    EmptyClipboard
  122.    hBit = LoadImage(0, BmpFile, IMAGE_BITMAP, 16, 16, LR_LOADFROMFILE)
  123.    If hBit = 0 Then
  124.      Exit Sub
  125.    End If
  126.    Call SetClipboardData(CF_BITMAP, hBit)
  127.    If IsClipboardFormatAvailable(CF_BITMAP) = 0 Then
  128.      Exit Sub
  129.    End If
  130.  End If
  131.  CloseClipboard
  132.  Btn.PasteFace
  133.  QFileDeleteSH BmpFile
  134. End Sub
  135.  
  136. Function BarreExist(szNomBarre As String) As Boolean
  137.  Dim BarreTemp As CommandBar
  138.  On Error GoTo trterr
  139.  
  140.  Set BarreTemp = Application.CommandBars(szNomBarre)
  141.  BarreExist = True
  142.  Set BarreTemp = Nothing
  143.  Exit Function
  144.  
  145.  trterr:
  146.    BarreExist = False
  147. End Function
  148.  
  149. Public Sub ActiveBtn()
  150.  Dim n As Integer, ii As Integer
  151. End Sub
  152.  
  153. Public Function DPExist(Param_DP As String) As Boolean
  154.  On Error GoTo trterr
  155.  Dim ll As Long
  156.  
  157.  DPExist = True
  158.  ll = Len(ActiveWorkbook.CustomDocumentProperties(Param_DP))
  159.  Exit Function
  160.  
  161.  trterr:
  162.    DPExist = False
  163. End Function
  164.  
  165. '-------
  166. '<<CNull
  167. '-------
  168. Public Function CNull(valeur As Variant) As String
  169.  If IsNull(valeur) Then
  170.    CNull = ""
  171.  Else
  172.    CNull = valeur
  173.  End If
  174. End Function
  175.  
  176. '***************************************************************************
  177. '* Fonctions communes aux différentes feuilles
  178. '***************************************************************************
  179.  
  180. 'Test des dates employé
  181. 'RsEmp : recordset contenant l'employé
  182. 'DbDossier : base du dossier de paie
  183. 'RsEs : record sur la table des entrées/sorties employé (en mode table)
  184. 'DebPer , FinPer: début et fin de période de référence
  185. 'Renvoit : -1 : Erreur dates employe
  186. ' 0 : Employé non présent dans la période
  187. ' 1 : Employé présent dans la période
  188. 'DetailAbsence : renvoit 1 si employé sorti avant la période
  189. ' 2 entré après la période
  190. 'Renvoie dans Entree la dernière date d'entrée et de sortie de l'employé dans la période donnée
  191. '(cas entrées multiples, on renvoie la dernière entrée dans la période)
  192. Public Function QPIsPresent(RsEmp As Recordset, DebPer As Date, FinPer As Date, Optional MsgErr As String, _
  193.  Optional DetailAbsence As Integer, Optional Entree As Date, Optional Sortie As Date, Optional CodeMotifRupture As String, _
  194.  Optional MyRsES As Recordset = Nothing, Optional DbDossier As Database = Nothing) As Integer
  195.  
  196.  Dim EntreeSal As Date, SortieSal As Date
  197.  Dim TypeES As Integer
  198.  Dim RsES As Recordset
  199.  On Error GoTo trt_err
  200.  
  201.  If Not MyRsES Is Nothing Then
  202. 'On utilise le record E/S passé en paramètre
  203.    Set RsES = MyRsES
  204.  Else
  205. 'On utilise le recordset global sur les E/S
  206.    If RsEsGlob Is Nothing Then
  207. 'Ouvre le recordset global des E/S sur la base donnée
  208.      If DbDossier Is Nothing Then
  209.        Set DbDossier = OpenDatabase(QDirAvecSlash(RacDataPaie) + GetNumDossier + "\Qpaie.mdb")
  210.      End If
  211.      Set RsEsGlob = DbDossier.OpenRecordset("EntreeSortieEmp", dbOpenTable)
  212.      RsEsGlob.Index = "PrimaryKey"
  213.    End If
  214.    Set RsES = RsEsGlob
  215.  End If
  216.  
  217.  DetailAbsence = 0
  218.  QPIsPresent = 0
  219.  EntreeSal = CDate(0)
  220.  SortieSal = CDate(0)
  221.  CodeMotifRupture = ""
  222.  TypeES = 2
  223.  
  224. 'Premier Seek, s'il plante, le record est réouvert pour le second
  225.  RsES.Seek ">=", RsEmp!Numero, CDate(0), 1
  226.  
  227.  RsES.Seek ">=", RsEmp!Numero, CDate(0), 1
  228.  If RsES.NoMatch Then
  229. 'Aucune E/S
  230.    MsgErr = "Dates d'entrées non renseignées"
  231.    QPIsPresent = -1
  232.    Exit Function
  233.  Else
  234.    If RsES!NumeroEmploye <> RsEmp!Numero Then
  235.      MsgErr = "Dates d'entrées non renseignées"
  236.      QPIsPresent = -1
  237.      Exit Function
  238.    End If
  239.  End If
  240.  
  241.  Do While Not RsES.EOF
  242.    If RsES!NumeroEmploye <> RsEmp!Numero Then Exit Do
  243.    If RsES!DateES > FinPer Then Exit Do
  244.    If RsES!TypeES = 2 And TypeES = 2 Then
  245.      MsgErr = "Date sortie positionnée, date entrée absente"
  246.      QPIsPresent = -1
  247.      Exit Function
  248. 'ElseIf rsEsTyES = 1 And TypeEs = 1 Then
  249. 'QPIsPresent = -1
  250. 'Exit Function
  251.    End If
  252.  
  253.    If RsES!TypeES = 1 Then
  254. 'Entrée
  255.      EntreeSal = RsES!DateES
  256.      SortieSal = CDate(0)
  257.    Else
  258. 'Sortie
  259.      SortieSal = RsES!DateES
  260.      CodeMotifRupture = CNull(RsES!CodeMotifRupture)
  261.    End If
  262.    TypeES = RsES!TypeES
  263.    RsES.MoveNext
  264.  Loop
  265.  
  266.  If EntreeSal = CDate(0) Then
  267. 'Entrée après la période ou pas de date d'entrée : employé non présent dans la période
  268.    DetailAbsence = 2
  269.    QPIsPresent = 0
  270.  Else
  271. 'Entrée avant la fin de la période (Entrée <= FinPer)
  272.    If SortieSal = CDate(0) Then
  273. 'Pas sorti ou sorti après la période
  274.      QPIsPresent = 1
  275.    Else
  276. 'Sortie <= FinPer
  277.      If SortieSal < DebPer Then
  278. 'Sortie avant la période
  279.        DetailAbsence = 1
  280.        QPIsPresent = 0
  281.      Else
  282. 'Sortie dans la période
  283.        QPIsPresent = 1
  284.      End If
  285.    End If
  286.  End If
  287.  
  288.  Entree = EntreeSal
  289.  Sortie = SortieSal
  290.  
  291.  Exit Function
  292.  trt_err:
  293.    If Err.Number = 3420 Then
  294. 'Cas où le recordset ne vaut pas nothing mais n'est plus défini, il faut le réouvrir
  295.      If DbDossier Is Nothing Then
  296.        Set DbDossier = OpenDatabase(QDirAvecSlash(RacDataPaie) + GetNumDossier + "\Qpaie.mdb")
  297.      End If
  298.      Set RsEsGlob = DbDossier.OpenRecordset("EntreeSortieEmp", dbOpenTable)
  299.      RsEsGlob.Index = "PrimaryKey"
  300.      Set RsES = RsEsGlob
  301.      Resume Next
  302.    End If
  303. End Function
  304.  
  305. Public Function Periode(DateOrg As Date) As Date
  306.  On Error Resume Next
  307.  If DateOrg = CDate(0) Then Exit Function
  308.  Periode = CDate("01/" + Format(DateOrg, "MM/YYYY"))
  309. End Function
  310.  
  311. Public Sub AddToSortedCol(MyCol As Collection, Value As String, Optional Key As String = "")
  312.  Dim Idx As Long
  313.  Dim tmp As String
  314.  If MyCol Is Nothing Then Exit Sub
  315.  tmp = Value
  316.  For Idx = 1 To MyCol.Count
  317.    If MyCol(Idx) > tmp Then Exit For
  318.  Next Idx
  319.  If Key <> "" Then
  320.    If Idx = MyCol.Count + 1 Then
  321.      MyCol.Add tmp, Key
  322.    Else
  323.      MyCol.Add tmp, Key, Idx
  324.    End If
  325.  Else
  326.    If Idx = MyCol.Count + 1 Then
  327.      MyCol.Add tmp
  328.    Else
  329.      MyCol.Add tmp, , Idx
  330.    End If
  331.  End If
  332. End Sub
  333.  
  334. Public Function FormatNum(Num As String) As String
  335.  FormatNum = QFormatCode(Trim$(Num), 10, " ")
  336. End Function
  337.  
  338. Public Function Arrond(Vl As Double, NbDec As Byte) As Double
  339.  Dim tmp As String
  340.  If NbDec > 0 Then
  341.    tmp = Format(Vl, "#." + String$(NbDec, "0"))
  342.  Else
  343.    tmp = Format(Vl, "#")
  344.  End If
  345.  Arrond = CDbl(tmp)
  346. End Function
  347.  
  348. '-------------
  349. '<<QFormatCode
  350. '-------------
  351. Public Function QFormatCode(ByVal sCode As String, lSize As Long, Optional ByVal sChar As String = " ") As String
  352.  sCode = Trim$(sCode)
  353.  If QIsAllNum(sCode) And Len(sCode) < lSize Then
  354.    Do
  355.      If sCode = "" Then Exit Do
  356.      If Left$(sCode, 1) <> "0" Then Exit Do
  357.      sCode = Right$(sCode, Len(sCode) - 1)
  358.    Loop
  359.    QFormatCode = String$(lSize - Len(sCode), sChar) + sCode
  360.  Else
  361.    QFormatCode = Trim$(sCode)
  362.  End If
  363. End Function
  364.  
  365. '----------
  366. '<<QTmpFile
  367. '----------
  368. Public Function QTmpFile(Optional Prefixe As String, Optional Suffixe As String) As String
  369.  Dim TempPath As String
  370.  Dim Fichier As String
  371.  Dim ii As Long
  372.  QTmpFile = ""
  373.  TempPath = GetTmpDir + "\"
  374.  ii = 0
  375.  If Suffixe = "" Then
  376.    Suffixe = ".tmp"
  377.  Else
  378.    QElimine Suffixe, "."
  379.    Suffixe = "." + Suffixe
  380.    Suffixe = Left$(Suffixe, 4)
  381.  End If
  382.  If Prefixe = "" Then
  383.    Prefixe = "Q"
  384.  Else
  385.    Prefixe = Left$(Prefixe, 2)
  386.  End If
  387.  Do
  388.    Fichier = TempPath + Prefixe + "tmp"
  389.    Fichier = Fichier + Right$("000" + CStr(ii), 3) + Suffixe
  390.    If Not FileExist(Fichier) Then Exit Do
  391.    ii = ii + 1
  392.    If ii > 999 Then
  393.      Fichier = ""
  394.      Exit Do
  395.    End If
  396.  Loop
  397.  QTmpFile = Fichier
  398. End Function
  399.  
  400. Public Function CalculNbhJ(DataB As DAO.Database, RecEmp As DAO.Recordset) As Double
  401.  Dim Recset As DAO.Recordset
  402.  Set Recset = DataB.OpenRecordset("Etablissements", dbOpenTable)
  403.  Recset.Index = "PrimaryKey"
  404.  If Not (Recset.EOF And Recset.BOF) Then
  405.    Recset.Seek "=", RecEmp("CodeEtablissement")
  406.    If Recset.NoMatch Then
  407.      Recset.MoveFirst
  408.    End If
  409.    CalculNbhJ = ((Recset("NbHeureTravMois") * 12) / 52) / 5
  410.  End If
  411.  Recset.Close
  412.  Set Recset = Nothing
  413. End Function
  414.  
  415. '--------------
  416. '<<QTableExiste
  417. ' Teste l'existence d'une table dans une base de donnees
  418. '--------------
  419. Public Function QTableExiste(InDB As DAO.Database, NomTable As String) As Boolean
  420.  On Error GoTo trterr
  421.  Dim rsTest As DAO.Recordset
  422.  
  423.  Set rsTest = InDB.OpenRecordset(NomTable, dbOpenTable)
  424.  rsTest.Close
  425.  Set rsTest = Nothing
  426.  QTableExiste = True
  427.  
  428.  Exit Function
  429.  
  430.  trterr:
  431.    QTableExiste = False
  432.    Exit Function
  433. End Function


Edit par Tintin10 : rajout des balises de code
Message édité par Tintin10 le 28/01/2019 à 17:34:33
  1. config
tintin10
Habitué (de 5 000 à 9 999 messages postés) Développeur
  1. Posté le 28/01/2019 à 17:37:14  
  1. answer
  1. Prévenir les modérateurs en cas d'abus
 
O.K., très bien. N'aurais-tu pas un plug-in intégré à Microsoft Excel, apparemment pour gérer des calculs de paie ?
Si oui, le problème vient effectivement du code, et je voudrais bien que tu me mettes une capture d'écran du message d'erreur exact, avec la ligne de code qui est normalement surlignée en rouge ou en jaune.


---------------
Configuration matérielle : voir ce lien
Merci de respecter les règles du forum
(Publicité)
choukie01
  1. Posté le 29/01/2019 à 14:35:42  
  1. answer
  1. Prévenir les modérateurs en cas d'abus
 
erreur de compilation

Le code contenu dans ce projet doit être mis à jour pour pouvoir être utilisé sur les systèmes 64bits. Vérifiez et mettez à jour les instructions Declare, puis marquez-les avec les attributs PtrSafe.

En gros les lignes rouges sont celles où est écrit Private Declare Function (en orange et bleu sur le code que je vous ai envoyé)

J'ai désactivé le complément de paie et maintenant il affiche:

Désolé… Nous ne trouvons pas C:\users

  1. config
tintin10
Habitué (de 5 000 à 9 999 messages postés) Développeur
  1. Posté le 29/01/2019 à 17:51:43  
  1. answer
  1. Prévenir les modérateurs en cas d'abus
 
On dirait que tu utilises un complément 32 bits avec une version 64 bits.
Réactive le complément et modifie les lignes commençant par "Private Declare" par :
Code :(Double-cliquez pour supprimer les numéros de ligne)
  1. Private Declare PtrSafe Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal dwImageType As Long, ByVal dwDesiredWidth As Long, ByVal dwDesiredHeight As Long, ByVal dwFlags As Long) As Long
  2. Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
  3. Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
  4. Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
  5. Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
  6. Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
  7. Private Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
  8. Private Declare PtrSafe Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long


---------------
Configuration matérielle : voir ce lien
Merci de respecter les règles du forum
choukie01
  1. Posté le 05/02/2019 à 14:16:48  
  1. answer
  1. Prévenir les modérateurs en cas d'abus
 
Bonjour,

C'est ce que j'ai fait. Mais une fois que j'ai tout modifié comment je peux valider ce que j'ai mis??? La fenêtre reste ouverte te ne bouge plus et je ne sais pas où appuyer pour valider mes écritures.

(Publicité)
  1. config
tintin10
Habitué (de 5 000 à 9 999 messages postés) Développeur
  1. Posté le 05/02/2019 à 21:06:11  
  1. answer
  1. Prévenir les modérateurs en cas d'abus
 
Je pense qu'il suffit d'enregistrer dans le modèle Normal.dotm.


---------------
Configuration matérielle : voir ce lien
Merci de respecter les règles du forum
 Page :
1

Aller à :
 

Sujets relatifs
lien hypertexte avec excel 2012 sur win 10 messages d'erreur sur windows 7
comment résoudre une erreur code 2503? Code erreur 502 dans niouzefire
Erreur au lancement d'une machine virtualle Virtal box 5.2.14 Erreur de compilation dans un UserForm
Plus de sujets relatifs à : Erreur compilation excel

Les 5 sujets de discussion précédents Nombre de réponses Dernier message
Mon ordinateur portable hp ne démarre plus 1
Lien ne s'ouvre plus dans Outlook 2007 23
Ouverture de PPS 8
enchainement VBA sur 1 feuille xls 3
Créer un document PDF cliquable 3