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.
PrivateDeclareFunction GetPixel Lib"gdi32"(ByVal hDC AsLong,ByVal x AsLong,ByVal y AsLong)AsLongPrivateDeclareFunction GetDC Lib"user32"(ByVal hwnd AsLong)AsLongPrivateDeclareFunction FindWindow Lib"user32"Alias"FindWindowA"(ByVal lpClassName AsString,ByVal lpWindowName AsString)AsLongPrivateDeclareFunction SetCursorPos Lib"user32"(ByVal x AsLong,ByVal y AsLong)AsLongPrivateDeclareFunction GetWindowRect Lib"user32"(ByVal hwnd AsLong, lpRect As Rect)AsLongPrivateDeclareFunction GetCursorPos Lib"user32"(ByRef lpPoint As POINT)AsLongPrivateDeclareFunction CreateICA Lib"gdi32"(ByVal sDriver AsString, _
ByVal sDevice AsString,ByVal sOut AsString,ByVal pDVM AsLong)AsLongPrivateDeclareFunction DeleteDC Lib"gdi32"(ByVal hDC AsLong)AsLongPrivateDeclareFunction GetDeviceCaps Lib"gdi32"(ByVal hDC AsLong, _
ByVal nIndex AsLong)AsLongPublic running AsBooleanPrivate Type Rect
Left AsLong
Top AsLong
Right AsLong
Bottom AsLongEnd Type
Private Type POINT
x AsLong
y AsLongEnd Type
PrivateFunctionGetWindowHandle()AsLongConst CLASSNAME_MSExcel ="XLMAIN"
GetWindowHandle =FindWindow(CLASSNAME_MSExcel, vbNullString)EndFunctionSubGenerateField()Dim ColorInteger AsLongDim CurrentCell As Range
Dim pic AsObjectDim Rows AsIntegerDim Columns AsIntegerDim cnt AsIntegerDim Rec As Rect, i
Dim pLocation As POINT
Dim hDC AsLongDim xRes AsLongDim yRes AsLongDim xWidth AsSingleDim yHeight AsSingleDim xPoints AsDoubleDim yPoints AsDoubleDim ZoomFactorX AsIntegerDim ZoomFactorY AsInteger
cnt =0ForEach pic In ActiveSheet.Pictures
cnt = cnt +1Next pic
If cnt =0Then
MsgBox "Erreur: Vous devez sélectionner une image d'abbord"ElseIf cnt >1Then
MsgBox "Erreur: Vous ne pouvez utiliser qu'une image"ElseIfIsNumeric(UserForm1.TextBox1.Value)AndIsNumeric(UserForm1.TextBox2.Value)And UserForm1.TextBox1.Value >0And UserForm1.TextBox2.Value >0Then
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)EndIf
xPoints =Sheets(2).Range("a1").Width
yPoints =Sheets(2).Range("a1").Height
xWidth =(xPoints /72)* xRes
yHeight =(yPoints /72)* yRes
For i =0To Rows -1For j =0To Columns -1Set 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
CallGetCursorPos(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 picElse
MsgBox "Erreur: Utiliser 'Redimensioner la fresque' por sélectionner la taille de votre fresque"EndIfEndSub
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