IdentifiantMot de passe
Loading...
Mot de passe oublié ?Je m'inscris ! (gratuit)
Navigation

Inscrivez-vous gratuitement
pour pouvoir participer, suivre les réponses en temps réel, voter pour les messages, poser vos propres questions et recevoir la newsletter

Macros et VBA Excel Discussion :

Affichage graph ds Usf HS sous XL 2019, ok autre version


Sujet :

Macros et VBA Excel

  1. #1
    Membre habitué
    Profil pro
    Collégien
    Inscrit en
    janvier 2008
    Messages
    276
    Détails du profil
    Informations personnelles :
    Localisation : France

    Informations professionnelles :
    Activité : Collégien

    Informations forums :
    Inscription : janvier 2008
    Messages : 276
    Points : 164
    Points
    164
    Par défaut Affichage graph ds Usf HS sous XL 2019, ok autre version
    Bonjour à tous,

    je développe un logiciel depuis quelques années dans lequel j'affiche à un moment dans une userform quelques graphiques type piechart

    donc je suis parti sur une méthode librairie User32 - gdi32 - olepro32.dll je mets le code plus bas (partiellement offusqué dsl)

    le souci c'est que je suis passé sur une nouvelle version sur un de mes ordinateurs de travail, Office 2019, et les graphiques ne s'affichent plus

    Nom : userform vide.png
Affichages : 31
Taille : 3,9 Ko

    donc je m'inquiète un peu pour la compatibilité à venir, même si je ne pense pas que tout le monde passe à Office 2019 sur le champ
    si vous avez des éléments de compréhension, cela serait très séduisant

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
    100
    101
    102
    103
    104
    105
    106
    107
    108
    109
    110
    111
    112
    113
    114
    115
    116
    117
    118
    119
    120
    121
    122
    123
    124
    125
    126
    127
    128
    129
    130
    131
    132
    133
    134
    135
    136
    137
    138
    139
    140
    141
    142
    143
    144
     
    Private Type GUID
      Data1 As Long
      Data2 As Integer
      Data3 As Integer
      Data4(0 To 7) As Byte
    End Type
     
    Private Type uPicDesc
      Size As Long
      Type As Long
      hPic As Long
      hPal As Long
    End Type
     
    #If VBA7 Then
     
     
        Private Declare PtrSafe Function IsClipboardFormatAvailable& Lib "User32" (ByVal wFormat&)
        Private Declare PtrSafe Function OpenClipboard& Lib "User32" (ByVal hWnd&)
        Private Declare PtrSafe Function GetClipboardData& Lib "User32" (ByVal wFormat%)
        Private Declare PtrSafe Function CloseClipboard& Lib "User32" ()
        Private Declare PtrSafe Function OleCreatePictureIndirect& Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle&, IPic As IPicture)
        Private Declare PtrSafe Function CopyEnhMetaFile& Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc&, ByVal lpszFile$)
        Private Declare PtrSafe Function CopyImage& Lib "User32" (ByVal handle&, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
    #Else
     
     
     
     
        Private Declare Function IsClipboardFormatAvailable& Lib "User32" (ByVal wFormat&)
        Private Declare Function OpenClipboard& Lib "User32" (ByVal hWnd&)
        Private Declare Function GetClipboardData& Lib "User32" (ByVal wFormat%)
        Private Declare Function CloseClipboard& Lib "User32" ()
        Private Declare Function OleCreatePictureIndirect& Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle&, IPic As IPicture)
        Private Declare Function CopyEnhMetaFile& Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc&, ByVal lpszFile$)
        Private Declare Function CopyImage& Lib "User32" (ByVal handle&, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
     
    #End If
     
     
    Const CF_BITMAP = 2, CF_PALETTE = 9, CF_ENHMETAFILE = 14
    Const IMAGE_BITMAP = 0, LR_COPYRETURNORG = &H4
    Const PICTYPE_BITMAP = 1, PICTYPE_ENHMETAFILE = 4
     
    Sub abababaabbaaabb(aabababababaa)
        erk = 0
        On Error GoTo boucle0
        Dim Img As Shape
        Dim Grph As Chart
        Dim Curve As Worksheet
        Set Curve = ThisWorkbook.Sheets("MYTCD")
     
        If aabababababaa <> 4 And aabababababaa <> 5 Then
            Set Grph = Curve.ChartObjects(aabababababaa).Chart
        ElseIf aabababababaa = 4 Then
            Set Grph = Sheets("Simulation").ChartObjects(2).Chart
        ElseIf aabababababaa = 5 Then
            Set Grph = Sheets("Simulation").ChartObjects(1).Chart
        End If
     
        Grph.CopyPicture
        ThisWorkbook.Activate
        Sheets("Graphiques").Activate
        Sheets("Graphiques").Paste
        Call waittime
        On Error Resume Next
        Set Img = Sheets("Graphiques").Shapes(aabababababaa)
     
        On Error GoTo 0
     
        If Not Img Is Nothing Then
     
            Img.CopyPicture xlScreen, xlPicture
     
            Select Case aabababababaa
                Case 1
                Set Graphs.Image1.Picture = babababababaa()
                Case 4
                Set Graphs.Image2.Picture = babababababaa()
                Case 2
                Set Graphs.Image3.Picture = babababababaa()
                Case 3
                Set Graphs.Image4.Picture = babababababaa()
                Case 5
                Set Graphs.Image5.Picture = babababababaa()
            End Select
     
        End If
     
        Set Grph = Nothing
     
        Exit Sub
    boucle0:
     
        If erk < 10 Then
            Debug.Print "Erreur 0." & erk
            Grph.CopyPicture
            Resume Next
        End If
    End Sub
     
    Function babababababaa(Optional lXlPicType& = xlPicture) As IPicture
    Dim hPtr&, lPicType&, hCopy&
      lPicType = IIf(lXlPicType = xlBitmap, CF_BITMAP, CF_ENHMETAFILE)
     
      If IsClipboardFormatAvailable(lPicType) Then
        If OpenClipboard(0&) > 0 Then
          hPtr = GetClipboardData(lPicType)
          If lPicType = CF_BITMAP Then
            hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
          Else
            hCopy = CopyEnhMetaFile(hPtr, vbNullString)
          End If
          CloseClipboard
          If hPtr <> 0 Then Set babababababaa = CreatePicture(hCopy, 0, lPicType)
        End If
      End If
    End Function
     
    Private Function CreatePicture(hPic&, hPal&, lPicType&) As IPicture
    Dim uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPicture
      With IID_IDispatch
        .Data1 = &H7BF80980
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
      End With
      With uPicInfo
        .Size = Len(uPicInfo)
        .Type = IIf(lPicType = CF_BITMAP, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE)
        .hPic = hPic
        .hPal = IIf(lPicType = CF_BITMAP, hPal, 0)
      End With
      OleCreatePictureIndirect uPicInfo, IID_IDispatch, True, IPic
      Set CreatePicture = IPic
    End Function

  2. #2
    Membre habitué
    Profil pro
    Collégien
    Inscrit en
    janvier 2008
    Messages
    276
    Détails du profil
    Informations personnelles :
    Localisation : France

    Informations professionnelles :
    Activité : Collégien

    Informations forums :
    Inscription : janvier 2008
    Messages : 276
    Points : 164
    Points
    164
    Par défaut
    toujours rien ?

Discussions similaires

  1. Affichage différent selon utilisateur excel
    Par mimititimi dans le forum Macros et VBA Excel
    Réponses: 6
    Dernier message: 04/09/2015, 11h35
  2. Affichage différent selon URL de provenance
    Par BnA dans le forum Général JavaScript
    Réponses: 4
    Dernier message: 07/08/2007, 14h30
  3. affichage différent selon résolution
    Par altadeos dans le forum AWT/Swing
    Réponses: 2
    Dernier message: 15/12/2006, 11h58
  4. [Dates] affichage différent selon le mois en cours
    Par itri2005 dans le forum Langage
    Réponses: 3
    Dernier message: 07/04/2006, 17h05
  5. Affichage différent selon texte dans une case
    Par pingoo78 dans le forum Général JavaScript
    Réponses: 1
    Dernier message: 22/11/2005, 16h32

Partager

Partager
  • Envoyer la discussion sur Viadeo
  • Envoyer la discussion sur Twitter
  • Envoyer la discussion sur Google
  • Envoyer la discussion sur Facebook
  • Envoyer la discussion sur Digg
  • Envoyer la discussion sur Delicious
  • Envoyer la discussion sur MySpace
  • Envoyer la discussion sur Yahoo