Soyez le premier à donner votre avis sur cette source.
Vue 4 031 fois - Téléchargée 265 fois
désolé pour le module: le voila . Option Explicit Type POINTAPI X As Long Y As Long End Type Declare Function GetCursorPos Lib "USER32" (lpPoint As POINTAPI) As Long 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 Const RGN_OR = 2 Declare Function GetDesktopWindow Lib "USER32" () 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 Declare Sub ReleaseCapture Lib "USER32" () Private Declare Function SendMessage Lib "USER32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Long) As Long Dim son As Integer Declare Function GetDC Lib "USER32" (ByVal hwnd As Long) As Long Declare Function ReleaseDC Lib "USER32" (ByVal hwnd As Long, ByVal hDC As Long) As Long Declare Function BitBlt Lib "GDI32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) As Long Public Const SRCCOPY = &HCC0020 Public Const SRCERASE = &H440328 Public Const SRCINVERT = &H660046 Public Const SRCAND = &H8800C6 Public Const SRCPAINT = &HEE0086 Public Const WHITENESS = &HFF0062 Public Const PATCOPY = &HF00021 Public Const PATPAINT = &HFB0A09 Public Const PATINVERT = &H5A0049 Public Const BLACKONWHITE = 1 Public Const MERGECOPY = &HC000CA Public Const MERGEPAINT = &HBB0226 Public Const DSTINVERT = &H550009 Global iRecursion As Boolean Global tColor As Long Declare Function sndPlaySound Lib "WINMM.DLL" Alias "sndPlaySoundA" _ (lpszSoundName As Any, ByVal uFlags As Long) As Long Global SoundBuffer() As Byte Global Const SND_ASYNC = &H1 ' Jouer de façon asynchrone. Global Const SND_NODEFAULT = &H2 ' Ne pas utiliser le son par défaut. Global Const SND_MEMORY = &H4 ' lpszSoundName pointe vers un fichier en mémoire. Global Const SND_LOOP = &H8 Public Sub MakeTranslucent(Who As Form, Optional tColor As Long) On Local Error Resume Next Dim HW As Long Dim HA As Long Dim iLeft As Integer Dim iTop As Integer Dim iWidth As Integer Dim iHeight As Integer If IsMissing(tColor) Or tColor = 0 Then tColor = RGB(255, 255, 255) End If Who.AutoRedraw = True Who.Hide DoEvents HW = GetDesktopWindow() HA = GetDC(HW) iLeft = Who.Left / Screen.TwipsPerPixelX iTop = Who.Top / Screen.TwipsPerPixelY '+ 25 If using a form With a titlebar (border)... iWidth = Who.ScaleWidth iHeight = Who.ScaleHeight Call BitBlt(Who.hDC, 0, 0, iWidth, iHeight, HA, iLeft, iTop, SRCCOPY) 'iLeft + 4 If using a form With a titlebar (border)... Who.Picture = Who.Image Who.Show Call ReleaseDC(HW, HA) Who.DrawMode = 9 Who.ForeColor = tColor Who.Line (0, 0)-(iWidth, iHeight), , BF Who.AutoRedraw = False End Sub Public Function MakeForm(frm As Form, pic As PictureBox) Dim iX As Long, iY As Long Dim hRgn As Long, hRgnTemp As Long Dim lngDummy As Long frm.Width = frm.ScaleX(pic.Width, vbPixels, vbTwips) frm.Height = frm.ScaleY(pic.Height, vbPixels, vbTwips) DoEvents For iX = 0 To pic.ScaleWidth For iY = 0 To pic.ScaleHeight If pic.Point(iX, iY) <> vbWhite Then If hRgn = 0 Then hRgn = CreateRectRgn(iX, iY, iX + 1, iY + 1) Else hRgnTemp = CreateRectRgn(iX, iY, iX + 1, iY + 1) lngDummy = CombineRgn(hRgn, hRgn, hRgnTemp, RGN_OR) DeleteObject hRgnTemp End If End If Next Next Dim lngTH As Long, lngB As Long lngDummy = SetWindowRgn(frm.hwnd, hRgn, True) DoEvents lngDummy = DeleteObject(hRgn) End Function Public Function MoveForm(frm As Form) ReleaseCapture SendMessage frm.hwnd, &HA1, 2, 0& End Function
Option Explicit
Private Declare Sub releaseCapture Lib "user32" Alias "ReleaseCapture" ()
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Sub MakeTranslucent(theform As Form)
releaseCapture
Call SendMessage(theform.hwnd, &HA1, 2, 0&)
End Sub
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.