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
| Option Explicit
'**** pour réaliser la Form suivant l'image chargé dans sa propriété Picture ****
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SetWindowRgn Lib "User32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Const RGN_OR = 2
'fonction beaucoup plus rapide que Point et Step de VB
Private Declare Function GetPixel Lib "gdi32" ( _
ByVal hdc As Long, _
ByVal X As Long, _
ByVal Y As Long) As Long
Dim StartX As Long, StartY As Long
Dim NewLeft As Long, NewTop As Long
Private Sub Form_Load()
Me.ScaleMode = vbPixels: Picture1.ScaleMode = vbPixels
Picture1.AutoRedraw = True: Picture1.AutoSize = True
Picture1.Picture = LoadPicture(App.Path & "\Compos4.bmp") '***************** mettre le nom de ton fichier ***************
DecoupePicture Picture1
End Sub
Sub DecoupePicture(ThePict As PictureBox)
'procedure pour créer une forme non standard de Picture1
Dim lngColor As Long
lngColor = GetPixel(ThePict.hdc, 0, 0) 'couleur du pixel en haut à gauche de l'image, couleur devant être transparente
'le code suivant n'est pas de moi mais d'avigeilpro, merci a lui
'l'original ce trouve sur DVP a l'adresse
'http://www.developpez.net/forums/showpost.php?p=2252020&postcount=4
Dim lngX As Long, lngY As Long
Dim lngYDeb As Long
Dim lngYFin As Long
Dim hRgn As Long, hRgnTemp As Long
Dim lngDummy As Long
Dim bStat As Boolean
DoEvents
For lngX = 0 To ThePict.ScaleWidth - 1 'balayage de chaque pixels en largeur
bStat = False
For lngY = 0 To ThePict.ScaleHeight - 1 'balayage de chaque pixels en hauteur
If bStat Then
If GetPixel(ThePict.hdc, lngX, lngY) = lngColor Or _
lngY = ThePict.ScaleHeight Then
lngYFin = lngY
If hRgn = 0 Then
hRgn = CreateRectRgn(lngX, lngYDeb, lngX + 1, lngYFin)
Else
hRgnTemp = CreateRectRgn(lngX, lngYDeb, lngX + 1, lngYFin)
lngDummy = CombineRgn(hRgn, hRgn, hRgnTemp, RGN_OR)
DeleteObject hRgnTemp
End If
bStat = False
End If
Else
If GetPixel(ThePict.hdc, lngX, lngY) <> lngColor Then
lngYDeb = lngY
lngYFin = lngY
bStat = True
End If
End If
Next
Next
DoEvents
lngDummy = SetWindowRgn(ThePict.hWnd, hRgn, True) 'affectation de la construction a la Form
lngDummy = DeleteObject(hRgn)
End Sub |
Partager