Macro qui ne fonctione plus

Résolu/Fermé
Vivi - Modifié le 12 mars 2021 à 13:15
 Vivi - 12 mars 2021 à 13:14
Bonjour à vous j'ai du changer de pc car mon ancien pc ne fonctionnait plus trop avant j'avais office 2010 et maintenant office 2016 32 bits.

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.
EDIT : Ajout des balises de code (la coloration syntaxique).
Explications disponibles ici : ICI

Merci d'y penser dans tes prochains messages.
A voir également:

2 réponses

Patrice33740 Messages postés 8556 Date d'inscription dimanche 13 juin 2010 Statut Membre Dernière intervention 2 mars 2023 1 776
12 mars 2021 à 11:07
1
Je vais regarder ce que je peut faire merci
0