Macro qui ne fonctione plus

viivii60 · Mars 11, 2021, 9:43

Bonjour à vous j’ai du changer de pc car mon ancien pc ne fonctionnait plus trop.

Et lorsque j’ai ouvert mon fichier excel joint, ma macro ne fonctionne plus.

C’est une macro qui me permet de pixeliser une image, je l’importe et lorsque je clique sur « Généré une fresque à partir… », la macro se lance mais elle colorise tout en blanc, alors qu’avant elle gênerait parfaitement l’image en pixel avec les couleurs qui correspondaient.

Lorsque je rentre dans les codes dans le module « GenerateField » je ne vois rien de bizarre, et je n’ai surtout rien changer entre mes 2 pc.

Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As Rect) As Long
Private Declare Function GetCursorPos Lib "user32" (ByRef lpPoint As POINT) As Long
Private Declare Function CreateICA Lib "gdi32" (ByVal sDriver As String, _
ByVal sDevice As String, ByVal sOut As String, ByVal pDVM As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, _
ByVal nIndex As Long) As Long

Public running As Boolean

Private Type Rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private Type POINT
    x As Long
    y As Long
End Type

Private Function GetWindowHandle() As Long

Const CLASSNAME_MSExcel = "XLMAIN"

GetWindowHandle = FindWindow(CLASSNAME_MSExcel, vbNullString)
End Function

Sub GenerateField()
Dim ColorInteger As Long
Dim CurrentCell As Range
Dim pic As Object
Dim Rows As Integer
Dim Columns As Integer
Dim cnt As Integer
Dim Rec As Rect, i
Dim pLocation As POINT
Dim hDC As Long
Dim xRes As Long
Dim yRes As Long
Dim xWidth As Single
Dim yHeight As Single
Dim xPoints As Double
Dim yPoints As Double
Dim ZoomFactorX As Integer
Dim ZoomFactorY As Integer

cnt = 0
For Each pic In ActiveSheet.Pictures
    cnt = cnt + 1
Next pic
    
If cnt = 0 Then
    MsgBox "Erreur: Vous devez sélectionner une image d'abbord"

ElseIf cnt > 1 Then
    MsgBox "Erreur: Vous ne pouvez utiliser qu'une image"

ElseIf IsNumeric(UserForm1.TextBox1.Value) And IsNumeric(UserForm1.TextBox2.Value) And UserForm1.TextBox1.Value > 0 And UserForm1.TextBox2.Value > 0 Then
    Rows = UserForm1.TextBox1.Value
    Columns = UserForm1.TextBox2.Value
    
    Application.WindowState = xlMaximized
    Range("a1").Select
    GetWindowRect GetWindowHandle, Rec
    hDC = CreateICA("DISPLAY", vbNullString, vbNullString, 0)
    If (hDC <> 0) Then
        xRes = GetDeviceCaps(hDC, 88)
        yRes = GetDeviceCaps(hDC, 90)
        DeleteDC (hDC)
    End If
    xPoints = Sheets(2).Range("a1").Width
    yPoints = Sheets(2).Range("a1").Height
    xWidth = (xPoints / 72) * xRes
    yHeight = (yPoints / 72) * yRes
    
    For i = 0 To Rows - 1
        For j = 0 To Columns - 1
            Set CurrentCell = ActiveSheet.Cells(1, 27).Offset(i, j)
            
            ZoomFactorX = xWidth * ActiveWindow.Zoom / 100
            ZoomFactorY = yHeight * ActiveWindow.Zoom / 100
            x = (ActiveWindow.PointsToScreenPixelsX(Range("a1").Left)) + (26.5 + j) * ZoomFactorX
            y = (ActiveWindow.PointsToScreenPixelsY(Range("a1").Top)) + (i) * ZoomFactorY + 0.5 * yHeight
            
            'MsgBox x & ", " & y
            
            SetCursorPos x, y
            
            Call GetCursorPos(pLocation)
             
            hDC = GetDC(Application.hwnd)
            
            ColorInteger = GetPixel(hDC, pLocation.x, pLocation.y)
            
            CurrentCell.Interior.Color = ColorInteger
        DoEvents
        Next j
    Next i
    
    'For Each pic In ActiveSheet.Pictures
    'pic.Delete
    'Next pic
    
Else
    MsgBox "Erreur: Utiliser 'Redimensioner la fresque' por sélectionner la taille de votre fresque"
End If
End Sub

Auriez vous une idée s’il vous plaît?

Cordialement Vivi.

Patrice33740 · Mars 11, 2021, 11:30

Regardes ici :

viivii60 · Mars 12, 2021, 5:55

Bonjour,
Je viens de regarder votre lien, j ai vérifier la version du pack office que je possède et la 32 bit. doi-je changer le code quand même ?.

Patrice33740 · Mars 12, 2021, 9:11

Comme expliqué dans l’article, il y a 2 évolutions qui nécessitent de modifier le code :

Passage d’Office avec VB6 à Office avec VB7
Passage de Windows 32 bits à Windows 64

Le premier lorsque on passe d’une version Office 2007 ou Antérieure à une version plus récente.
Le second quand on change de système d’exploitation.

Le code que tu présentes est conçu pour VBA6 et Win32.

Vérifies si Windows est en 32 ou 64 bits.

viivii60 · Mars 12, 2021, 9:17

D’accord je comprend mieux j’ai donc tout faux haha.

J’ai modifié cela mais ça ne fonctionne hélas toujours pas.

Private Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As Rect) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32" (ByRef lpPoint As POINT) As Long
Private Declare PtrSafe Function CreateICA Lib "gdi32" (ByVal sDriver As String, _
ByVal sDevice As String, ByVal sOut As String, ByVal pDVM As Long) As Long
Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, _
ByVal nIndex As Long) As Long

Public running As Boolean

Private Type Rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private Type POINT
    x As Long
    y As Long
End Type

Private Function GetWindowHandle() As Long

Const CLASSNAME_MSExcel = "XLMAIN"

GetWindowHandle = FindWindow(CLASSNAME_MSExcel, vbNullString)
End Function

Sub GenerateField()
Dim ColorInteger As Long
Dim CurrentCell As Range
Dim pic As Object
Dim Rows As Integer
Dim Columns As Integer
Dim cnt As Integer
Dim Rec As Rect, i
Dim pLocation As POINT
Dim hDC As Long
Dim xRes As Long
Dim yRes As Long
Dim xWidth As Single
Dim yHeight As Single
Dim xPoints As Double
Dim yPoints As Double
Dim ZoomFactorX As Integer
Dim ZoomFactorY As Integer

cnt = 0
For Each pic In ActiveSheet.Pictures
    cnt = cnt + 1
Next pic
    
If cnt = 0 Then
    MsgBox "Erreur: Vous devez sélectionner une image d'abbord"

ElseIf cnt > 1 Then
    MsgBox "Erreur: Vous ne pouvez utiliser qu'une image"

ElseIf IsNumeric(UserForm1.TextBox1.Value) And IsNumeric(UserForm1.TextBox2.Value) And UserForm1.TextBox1.Value > 0 And UserForm1.TextBox2.Value > 0 Then
    Rows = UserForm1.TextBox1.Value
    Columns = UserForm1.TextBox2.Value
    
    Application.WindowState = xlMaximized
    Range("a1").Select
    GetWindowRect GetWindowHandle, Rec
    hDC = CreateICA("DISPLAY", vbNullString, vbNullString, 0)
    If (hDC <> 0) Then
        xRes = GetDeviceCaps(hDC, 88)
        yRes = GetDeviceCaps(hDC, 90)
        DeleteDC (hDC)
    End If
    xPoints = Sheets(2).Range("a1").Width
    yPoints = Sheets(2).Range("a1").Height
    xWidth = (xPoints / 72) * xRes
    yHeight = (yPoints / 72) * yRes
    
    For i = 0 To Rows - 1
        For j = 0 To Columns - 1
            Set CurrentCell = ActiveSheet.Cells(1, 27).Offset(i, j)
            
            ZoomFactorX = xWidth * ActiveWindow.Zoom / 100
            ZoomFactorY = yHeight * ActiveWindow.Zoom / 100
            x = (ActiveWindow.PointsToScreenPixelsX(Range("a1").Left)) + (26.5 + j) * ZoomFactorX
            y = (ActiveWindow.PointsToScreenPixelsY(Range("a1").Top)) + (i) * ZoomFactorY + 0.5 * yHeight
            
            'MsgBox x & ", " & y
            
            SetCursorPos x, y
            
            Call GetCursorPos(pLocation)
             
            hDC = GetDC(Application.hwnd)
            
            ColorInteger = GetPixel(hDC, pLocation.x, pLocation.y)
            
            CurrentCell.Interior.Color = ColorInteger
        DoEvents
        Next j
    Next i
    
    'For Each pic In ActiveSheet.Pictures
    'pic.Delete
    'Next pic
    
Else
    MsgBox "Erreur: Utiliser 'Redimensioner la fresque' por sélectionner la taille de votre fresque"
End If
End Sub

Mimimathy · Mars 12, 2021, 9:18

Bonjour Patrice,
Cela ne vient pas de la version 32 ou 64, sinon, il y aurait eu un message d’erreur au départ
Peut-être regarder dans les références s’il n’y a pas de références manquantes non cochées
et voir si c’est la même version EXCEL

viivii60 · Mars 12, 2021, 9:19

Je viens de regarder mon windows et en 64 bit

Patrice33740 · Mars 12, 2021, 9:23

Revois l’article, en Win64, les handle (hwnd) et les pointeurs doivent être en LongPtr.
Revoir aussi les variables.

viivii60 · Mars 12, 2021, 9:24

Je viens de regarder dans les références, lesquels doivent être cocher ?

Vivi

viivii60 · Mars 12, 2021, 9:25

La je vous avoue que je n’ai pas tout comprit.

Mimimathy · Mars 12, 2021, 9:29

Re,
Si tu as, depuis Outils --> References une référence qui est cochée avec comme intitulé
MANQUANT ….
Il faut que tu prennes dans la liste la référence qui correspond. A savoir si tu as changer de PC, est-ce la même version EXCEL

viivii60 · Mars 12, 2021, 9:32

Re,
Mes références on l’air bonne :

Capture

Je suis passé du pack office 2010 ou 2007 au celui de 2016

Mimimathy · Mars 12, 2021, 9:48

Re,
Eh bien cherche pas plus loin, il y a eu des changements depuis,
alors , le problème ne peut être résolu qu’avec une lecture de la macro, il faut l’analyser en direct
Mais pas pour moi, je suis sous 2007, 2010, 2013 et pas plus haut

Patrice33740 · Mars 12, 2021, 9:52

A ma connaissance il n’y a pas de doc pour l’API Win64.
Celle de l’API Win 32 permet de connaitre le type de variable donc de savoir ce qu’il faut convertir.

Pas très simple tout ça …
Exemple :

HDC est un handle donc :

Private Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hDC As LongPtr, ByVal x As Long, ByVal y As Long) As Long

A vérifier pour chaque dll utilisée …

viivii60 · Mars 12, 2021, 10:12

Merci en tout cas pour votre aide, l’une des solutions ne serait pas de supprimer open office 2016 et d’installer le 2007 ?

viivii60 · Mars 12, 2021, 10:13

Si je comprend bien tous, le gros du problème est ici on est d’accord ?

Private Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As Rect) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32" (ByRef lpPoint As POINT) As Long
Private Declare PtrSafe Function CreateICA Lib "gdi32" (ByVal sDriver As String, _
ByVal sDevice As String, ByVal sOut As String, ByVal pDVM As Long) As Long
Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, _
ByVal nIndex As Long) As Long
```

Mimimathy · Mars 12, 2021, 10:16

Re,
C’est une solution,
Une autre est de placer ton classeur sur le post, au moins, il serait plus facile de l’étudier

viivii60 · Mars 12, 2021, 12:13

Re,

Bien sur voici le fichier en question

Image V1.xlsm (3,6 Mo)

J ai tester cela :

Private Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hDC As LongPtr, ByVal x As Long, ByVal y As Long) As Long
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As Rect) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32" (ByRef lpPoint As POINT) As Long
Private Declare PtrSafe Function CreateICA Lib "gdi32" (ByVal sDriver As String, _
ByVal sDevice As String, ByVal sOut As String, ByVal pDVM As Long) As Long
Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, _
ByVal nIndex As Long) As Long

Mais sans sucées

FFO · Mars 12, 2021, 1:17

Bonjour

Je viens de tester ton fichier avec Excel version 2019

onglet « Plannificateur De Fresques »

j’ai importé une image avec le bouton "Sélectionner une image " :

puis j’ai utiliser le bouton « Générer une Fresque à Partir d’une image » ce qui à donné ceci :

je n’ai pas ton résultat :

« je l’importe et lorsque je clique sur « Généré une fresque à partir… », la macro se lance mais elle colorise tout en blanc »

Je voulais te faire profiter de mes constatations

Peut être un PB sur ton environnement Excel qui c’est mal installé

Voir une désinstallation réinstallation

viivii60 · Mars 12, 2021, 1:21

Bonjour,

J’ai moi aussi le même problème elle colorise tout en blanc, alors qu’elle devrait coloriser de la couleur de la photo.