Discussion :

[popol666]

Bonjour,

J'aimerais savoir si il est possible d'extraire une zone particulière d'une image pour ensuite enregistrer cette nouvelle image ?

D'avance merci

[avigeilpro]

j'ai peut-etre une solution mais je ne suis pas chez moi.Donne moi ton adresse mail en mp et je t'enverrais ce que j'ai (pas avant ce week-end par contre) à moins que quelqu'un d'autre en ait une.

[avigeilpro]

ok, j'ai une solution de bricolage mais elle ne peut marcher que pour des images Bitmap.Ca t'interesse toujours?

[AlainTech]

ok, j'ai une solution de bricolage mais elle ne peut marcher que pour des images Bitmap.Ca t'interesse toujours?

Si tu as quelque chose, je pense qu'il serait bon que tu le mettes sur le forum pour que tout le monde en profite.

[popol666]

bien sur que ça m'intéresse

[avigeilpro]

désolé mais je ne peut pas avancer sur le projet car j'ai un disque dur qui a sauter.je ne pourais reprendre que d'ici une semaine.pour faire bref, il ne me mank plus que le moyen de créer une image dont les dimension serait celles de la partie que tu souhaite garder.après il suffit de lire pixel par pixel l'image d'origine et d'inscrire la valeur de ces pixels dans l'image d'arrivée avec un controle de ma conception.si tu as moyen de creer ce fichier BMP a la bonne taille, tu pourra trouver mon control sur mon site :
http://www.geocities.com/avigeilpro
dans la zone de telechargement, le control s'appel OpenBmp.sinon attend une semaine et ce meme control sera capable de créer un fichier bitmap.

[popol666]

Merci beaucoup pour ton aide
pour créer un bitmap il y a une solution sur le site :
http://access.developpez.com/sources...dows#Imprecran

ça fait une capture d'écran donc ça crée une bitmap

[avigeilpro]

Ok, voici ce que j'ai :
a mettre dans un module :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
Private Declare Function CreateCompatibleDC Lib "gdi32" _
(ByVal hdc As Long) As Long
 
Private Declare Function CreateDIBSection Lib "gdi32" _
(ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, _
ByVal lplpVoid As Long, ByVal Handle As Long, ByVal dw As Long) As Long
 
Private Declare Function DeleteDC Lib "gdi32" _
(ByVal hdc As Long) As Long
 
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
 
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, ByVal hObject As Long) As Long
 
Private Type BITMAPINFO
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biRUsed As Long
    biRImportant As Long
End Type
 
Private Type BITMAPFILEHEADER
    bfType As Integer
    bfSize As Long
    bfReserved1 As Integer
    bfReserved2 As Integer
    bfOffBits As Long
End Type
 
Private Const GHND = &H42
Private Const MAXSIZE = 4096
Private Const SRCCOPY = &HCC0020
Private Const DIB_RGB_COLORS = 0&
Private Const BI_RGB = 0&
 
Public Function BmpCreate(strNomDuFichier As String, lngLargeur As Long, lngHauteur As Long)
On Error GoTo Finally
Dim lngHdc As Long
Dim lngHBmp As Long
Dim bmiBitmapInfo As BITMAPINFO
Dim bmfBitmapFileHeader As BITMAPFILEHEADER
Dim lngFnum As Integer
Dim pixels() As Byte
Dim bolOuvert As Boolean
lngHdc = CreateCompatibleDC(0)
If lngHdc = 0 Then
  GoTo Finally
End If
 
'Crée un bitmap vierge
With bmiBitmapInfo
  .biBitCount = 24
  .biCompression = BI_RGB
  .biPlanes = 1
  .biSize = Len(bmiBitmapInfo)
  .biHeight = lngHauteur
  .biWidth = lngLargeur
  .biSizeImage = ((((.biWidth * .biBitCount) + 31) \ 32) * 4 - _
    (((.biWidth * .biBitCount) + 7) \ 8)) * .biHeight
End With
lngHBmp = CreateDIBSection(lngHdc, bmiBitmapInfo, DIB_RGB_COLORS, _
  ByVal 0&, ByVal 0&, ByVal 0&)
If lngHBmp = 0 Then
  GoTo Finally
End If
If SelectObject(lngHdc, lngHBmp) = 0 Then
  GoTo Finally
End If
'Crée l'entête du fichier bmp
With bmfBitmapFileHeader
  .bfType = &H4D42&
  .bfOffBits = Len(bmfBitmapFileHeader) + Len(bmiBitmapInfo)
  .bfSize = (lngLargeur * 3 + (lngLargeur Mod 4)) * lngHauteur + 54
End With
'Lit les bits du bitmap et les places dans le tableau pixels
Dim test
test = ((lngLargeur + (lngLargeur Mod 4)) * lngHauteur)
ReDim pixels(1 To ((lngLargeur + (lngLargeur Mod 4)) * lngHauteur))
lngFnum = FreeFile
'Crée le fichier
Open strNomDuFichier For Binary As lngFnum
bolOuvert = True
'Ecrit l'entête
Put #lngFnum, , bmfBitmapFileHeader
'Ecrit les informations du bitmap
Put #lngFnum, , bmiBitmapInfo
'Ecrit les bits de l'image
Put #lngFnum, , pixels
Finally:
'Ferme le fichier si ouvert
If bolOuvert Then Close lngFnum
'Supprime les objets
If lngHBmp <> 0 Then DeleteObject lngHBmp
If lngHdc <> 0 Then DeleteDC lngHdc
End Function

ensuite tu telecharge le control dont je t'ai parlé précédement, tu l'ajout a ton projet (ctrl + t , controlbitmap) tu le pose sur ta feuille et tu rajoute le code suivant pour faire une copie d'une partie de l'image :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
    Dim Largeur As Single
    Dim Hauteur As Single
    Dim ImgPix() As Long
    Dim DepX As Single
    Dim DepY As Single
    Dim Original As String
    Dim Copie As String
    Dim BoucleX As Single
    Dim BoucleY As Single
 
    'taille de la partie a copier
    Largeur = 30
    Hauteur = 30
 
    'emplacement du coin superieur gauche de la partie a copier
    'coordonnée minimum (0,0)
 
    DepX = 264
    DepY = 159
 
    ReDim ImgPix(Largeur, Hauteur)
 
    'emplacement du fichier a créer
    Copie = "C:\test.bmp"
 
    'emplacemtn du fichier contenant toute l'image
    Original = "C:\monimage.bmp"
 
 
    On Error Resume Next
    Kill Copie
    On Error GoTo 0
 
    BmpCreate Copie, CLng(Largeur), CLng(Hauteur)
 
    BmpCtrl1.OpenBmp Original
 
    For BoucleX = 0 To Largeur - 1
    For BoucleY = 0 To Hauteur - 1
    ImgPix(BoucleX, BoucleY) = BmpCtrl1.GetPixColor(BoucleX + DepX, BoucleY + DepY)
    Next
    Next
    BmpCtrl1.CloseBmp
 
    BmpCtrl1.OpenBmp Copie
 
    For BoucleX = 0 To Largeur - 1
    For BoucleY = 0 To Hauteur - 1
    BmpCtrl1.SetPixLng BoucleX, BoucleY, ImgPix(BoucleX, BoucleY)
    Next
    Next
    BmpCtrl1.CloseBmp

a +

[popol666]

merci pour tout