Macro qui ne fonctione plus
Résolu
Vivi
-
Vivi -
Vivi -
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.
Auriez vous une idée s'il vous plaît?
Cordialement Vivi.
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:
- Macro qui ne fonctione plus
- Telecharger macro convertir chiffre en lettre excel - Télécharger - Tableur
- Jitbit macro recorder - Télécharger - Confidentialité
- Télécharger macro convertir chiffre en lettre excel - Télécharger - Tableur
- Macro maker - Télécharger - Divers Utilitaires
- Macro word - Guide