Macro qui ne fonctione plus

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.

Bonsoir,

avez vous fait un déroulé "pas à pas" de votre code avec la touche F8 sous VBA ?
Comme cela vous déterminerez à quel endroit une variable ne prend pas la bonne couleur....

@ bientôt

LouReeD

Bonsoir,

Merci pour votre réponse,

Je viens de le faire et la ligne

Sub GenerateField()

Resort en Jaune mais je ne sais pas à quoi cela correspond.

Cordialement

Bonjour,

ma réflexion : si le nom d'une procédure engendre une erreur c'est qu'elle utilise peut-être un nom réservé par le système, du coup il ne comprend pas.
Vous n'avez pas de message d'erreur ?
Vous pouvez essayez en changeant son nom ici et au niveau de ses appels.

Avez vous sur ce nouveau PC activé les mêmes composant sous VBA ?

@ bientôt

LouReeD

Bonjour,

Non quand je lance excel ou la macro je n'ai aucun message d'erreur.

Avez vous sur ce nouveau PC activé les mêmes composant sous VBA ?

Je n'ai rien touché de se coter la.

Si besoin je peut vous envoyer le fichier

Merci Vivi

C'est mieux en effet

@ bientôt

LouReeD

Voici, merci a vous

J'ai regardé et j'avoue ne pas comprendre...

On choisi une image, on choisi un nombre de ligne et de colonne, puis on demande de faire la fresque.
Le curseur se déplace sur l'écran en fonction des données ci dessus, on récupère la couleur du point de l'image qui se trouve au coordonnée du curseur.
Mais cette couleur on en fait quoi ? Elle devrait être mise en place sur les cellule de la feuille qui correspondent au différent point testés ?

Lors du scan pas à pas, les couleurs récupérées sont toutes à -1, ce serait dont la fonction : ColorInteger = GetPixel(hDC, pLocation.x, pLocation.y) qui ne fonctionne pas ou mal...

Là ça dépasse mes compétences...

@ bientôt

LouReeD

Mais cette couleur on en fait quoi ? Elle devrait être mise en place sur les cellule de la feuille qui correspondent au différent point testés ?

Tout à fait la couleur devrait être collé sur la cellule excel.

J'avoue que je ne comprends pas tout, cela fonctionnait très bien sur mon ancien pc, certains sites disent que cela pourrait venir de la version du pack office mais pourtant j'ai bien une version 32 bit.

Vivi

En fait si vous déplacez l'image une fois avoir définie la taille de la fresque on s'aperçois que le curseur reste sur la zone en haut à gauche de la feuille, à l'endroit même où se trouvait à l'origine l'image. Donc en fait c'est la recherche de zone de l'image qui ne fonctionne pas, cette zone en taille "est bonne" mais elle ne suit pas l'objet, elle est donc attachée "à rien" et quelque soit ce qu'il y a d'afficher sur cette zone, le code renvoie -1 en couleur, vous devez donc "taper" sur le "sous écran", là où il n'y a rien...

Ce serait plutôt autour de ces lignes que le bas blesse :

GetWindowRect GetWindowHandle, Rec
hDC = CreateICA("DISPLAY", vbNullString, vbNullString, 0)

Pourquoi d'un PC à l'autre cela ne marche plus... En tous les cas ici cela ne marche pas non plus.

@ bientôt

LouReeD

Sur mon ancien pc, la zone ne suivait pas non plus l'image, il fallait la laisser à l'endroit ou on l'avait redimensionné, et une fois la macro terminée on supprimait l'image pour découvrir l'image pixelisée derrière.

Là je ne sait quoi vous dire... J'ai une application : Mosaïc en téléchargement, si cela peut vous aider au niveau du code.

Elle est largement moins "optionnelle" que la votre, mais cela peut donner une orientation de recherche, ne serait-ce que pour voir si elle fonctionne chez vous.

@ bientôt

LouReeD

Je viens en effet de la télécharger mais malheureusement cela ne va pas me convenir, même si l'idée de base et la même .

Merci beaucoup en tout cas

vivi

Après plusieurs recherches ici notamment et sur le web, si j'ai tout bien comprit, la macro ne marcherait plus car la version que j'utilise d"Open Office et trop récente (2016), du coup la macro que j’utilisais n'est plus compatible car mon ancienne version d'Open Office datait de 2007 ou 2010..

J'ai compris qu'il fallait changer le début de mon code, ce que j'ai fait mais sans résultat, je ne suis vraiment pas doué je pense haha.

J'avoue que je ne sais plus trop quoi faire pour le coup, car je me servais beaucoup de cette Macro.

Cordialement Vivi

Rrgatdez du côté des déclarations avec PTRSafe.

Pour vous aider regzrdez mon code Mosaïque je crois qu'il y a bien les deux type de déclaration, une normale et l'autre en fonction de la version de VBA ou Windows avec les déclarations en PTRSafe.

@ bientôt

LouReeD

En effet il y a les 2 mais les déclarations en commun semblent identiques.

Et j'ai l'impression que plus j'y touche, pire je fais

Vivi