Option Explicit Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long Private Declare Function TranslateColor Lib "olepro32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As Long, col As Long) As Long Private Sub CommandButton1_Click() Dim toto As New StdPicture, i As Long, j As Long, couleur As Long Dim hdc As Long, pixels_width As Long, pixels_height As Long, R As Byte, G As Byte, B As Byte Set toto = LoadPicture("d:\bateau.bmp") pixels_width = Int(Application.CentimetersToPoints(toto.Width / 1000) * 20 / TwPerPix("X")) pixels_height = Int(Application.CentimetersToPoints(toto.Height / 1000) * 20 / TwPerPix("Y")) hdc = CreateCompatibleDC(0) SelectObject hdc, toto.Handle For i = 0 To pixels_width For j = 0 To pixels_height couleur = GetPixel(hdc, i, j) Dim RealColor As Long TranslateColor couleur, 0, RealColor R = RealColor And &HFF& G = (RealColor And &HFF00&) / 2 ^ 8 B = (RealColor And &HFF0000) / 2 ^ 16 MsgBox "R " & R & " G " & G & " B = " & B ' sors de cette boucle par CTRL + PAUSE Next j Next i End Sub Function TwPerPix(sens As String) As Single Dim axe As Long, lngDC As Long axe IIf(sens "X", 88, 90) lngDC = GetDC(0) TwPerPix = 1440& / GetDeviceCaps(lngDC, axe) ReleaseDC 0, lngDC End Function
For i = 0 To pixels_width For j = pixels_height to 0 step -1 '<<<<==== j'inverse la lecture couleur = GetPixel(hdc, i, pixels_height- j) '<<<=== je corrige pour m'y retrouver Dim RealColor As Long TranslateColor couleur, 0, RealColor R = RealColor And &HFF& G = (RealColor And &HFF00&) / 2 ^ 8 B = (RealColor And &HFF0000) / 2 ^ 16 MsgBox "R " & R & " G " & G & " B = " & B ' sors de cette boucle par CTRL + PAUSE Next j Next i
For j = 0 To -pixels_height Step -1 For i = 0 To pixels_width couleur = GetPixel(hdc, i, j + pixels_height) Dim RealColor As Long TranslateColor couleur, 0, RealColor R = RealColor And &HFF& G = (RealColor And &HFF00&) / 2 ^ 8 B = (RealColor And &HFF0000) / 2 ^ 16 Next i Next j
Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre questionDim toto As New StdPicture Set toto = LoadPicture("d:\bateau.bmp") lwidth = toto.Width lheight = toto.Height MsgBox "en unités himetric (millièmes de centimètre) : " & vbCrLf & _ "lageur : " & lwidth & vbCrLf & _ "hauteur : " & lheight & vbCrLf & vbCrLf & _ "soit, en points : " & vbCrLf & _ "largeur : " & Application.CentimetersToPoints(lwidth / 1000) & " points" & vbCrLf & _ "hauteur : " & Application.CentimetersToPoints(lheight / 1000) & " points"
Dim toto As New StdPicture
ensuite c'est le nouveau code à mettre à la suite du tien
Contrôle_Image1.Object.Autosize=True
xPixel=Contrôle_Image1.Object.ScaleX(PicSource.Picture.Width,8,3)
yPixel=Contrôle_Image1.Object.ScaleY(PicSource.Picture.Height,8,3)
tu devrais obtenir la taille de ton image en pixels
Bonjour, Galain,
Scalex sous VBA/Excel ?
Tu es sûr ?
SERIEUXETCOOL, j'attends que tu testes la proposition de Galain et si c'est négatif,
quel est le souci rencontré en VBA, à quelles fins as-tu besoin de ces infos, ... ?
Correction
Contrôle_Image1.Object.Autosize=True
xPixel=Contrôle_Image1.Object.ScaleX(Contrôle_Image1.Picture.Width,8,3)
yPixel=Contrôle_Image1.Object.ScaleY(Contrôle_Image1.Picture.Height,8,3)
8,3 pour pixels et 8,6 pour les mm
ScaleX / Y n'existent pas dans la version 2003, sont-ce des nouvelles fonctions d'une version ultérieure ?
Bon, Alain
Non, cette méthode n'existe pas sous VBA (c'est du VB6 !)
Je vais donc tenter petit truc
A +
Dim toto As New StdPicture Set toto LoadPicture("d:\bateau.bmp") lwidth toto.Width lheight = toto.Height MsgBox "en unités himetric (millièmes de centimètre) : " & vbCrLf & _ "lageur : " & lwidth & vbCrLf & _ "hauteur : " & lheight & vbCrLf & vbCrLf & _ "soit, en points : " & vbCrLf & _ "largeur : " & Application.CentimetersToPoints(lwidth / 1000) & " points" & vbCrLf & _ "hauteur : " & Application.CentimetersToPoints(lheight / 1000) & " points"
Là ucfoutu me colle un doute : André tu veux bien en retour des pixels et non pas des points ?
Alors voilà et voilà pourquoi il faut passer par une stdPicture
D'une pierre trois coups (et SERIEUXETCOOL va comprendre, lui, ce "cadeau-là)) :
... Set toto = LoadPicture("d:\bateau.bmp") pixels_width = CInt(Application.CentimetersToPoints(toto.Width / 1000) * 20 / TwPerPix("X")) pixels_height = CInt(Application.CentimetersToPoints(toto.Height / 1000) * 20 / TwPerPix("Y")) hdc = CreateCompatibleDC(0) ...
... Set toto = LoadPicture("d:\bateau.bmp") pixels_width = Application.CentimetersToPoints(toto.Width / 1000) * 20 / TwPerPix("X") pixels_height = Application.CentimetersToPoints(toto.Height / 1000) * 20 / TwPerPix("Y") hdc = CreateCompatibleDC(0) ...