0/5 (9 avis)
Vue 4 909 fois - Téléchargée 415 fois
'Dans un form mettre une picturebox nommée Picture1 'mettre le scalemode sur PIXEL pour la form et la picturebox (Picture1) 'mettre un timer intervale 1000 et enabled=false 'et mettre ce code Dim wr(11) Dim a As Integer Private Sub Form_Load() 'affichage du pointeur de la souris (sablier) Screen.MousePointer = 11 DoEvents 'positionnement de la fenetre Me.Top = 2000 Me.Left = 1000 DoEvents 'chargement des differentes region pour chaque image (transparence) For a = 0 To 10 'vide la picturebox Picture1.Picture = Nothing 'charge la picturebox avec un bitmap mit en ressource Picture1.Picture = LoadResPicture(101 + a, vbResBitmap) 'creer la region en transparence suivant la couleur de masque (ici 255,255,255 cad blanc) wr(a) = MakeRegion(Picture1, "255,255,255") Next a 'charge une image temporaire Picture1.Picture = LoadResPicture(101, vbResBitmap) 'mets en transparence la form suivant les zone de transparences definits par limage temporaire SetWindowRgn Me.hwnd, wr(0), True a = 0 Timer1.Enabled = True Screen.MousePointer = 0 'mets la form au premier plan RendreFormTjsVisible Me End Sub Private Sub Timer1_Timer() If a > 11 Then a = 0 Picture1.Picture = Nothing Picture1.Picture = LoadResPicture(101 + a, vbResBitmap) a = a + 1 If Me.Visible = False Then Me.Visible = True End Sub '---------------------------- 'dans un module mettre le code ci-dessous '############# ------- 'un de mes nombreux modules à tout faire :) '############# ------- Public Type IconeTray cbSize As Long 'Taille de l'icône (en octets) hwnd As Long 'Handle de la fenêtre chargée de recevoir les messages envoyés lors des évènements sur l'icône (clics, doubles-clics...) uID As Long 'Identificateur de l'icône uFlags As Long uCallbackMessage As Long 'Messages à renvoyer hIcon As Long 'Handle de l'icône szTip As String * 64 'Texte à mettre dans la bulle d'aide End Type Public IconeT As IconeTray Public Const AJOUT = &H0 Public Const MODIF = &H1 Public Const SUPPRIME = &H2 Public Const MouseMove = &H200 Public Const MESSAGE = &H1 Public Const Icone = &H2 Public Const TIP = &H4 Public Const DOUBLE_CLICK_GAUCHE = &H203 Public Const BOUTON_GAUCHE_POUSSE = &H201 Public Const BOUTON_GAUCHE_LEVE = &H202 Public Const DOUBLE_CLICK_DROIT = &H206 Public Const BOUTON_DROIT_POUSSE = &H204 Public Const BOUTON_DROIT_LEVE = &H205 Public Limage As Integer Public Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As IconeTray) As Boolean Public Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long Public Declare Function SetWindowRgn Lib "USER32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long Public Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Public Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long Public Declare Function ReleaseCapture Lib "USER32" () As Long Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Public 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 Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As POINTAPI, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long Public Declare Function SetWindowPos Lib "USER32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long Public Const SWP_NOSIZE = &H1 Public Const SWP_NOMOVE = &H2 Public Const HWND_TOPMOST = -1 Public Const HWND_NOTOPMOST = -2 Public Const WM_NCLBUTTONDOWN = &HA1 Public Const HTCAPTION = 2 Public Const RGN_OR = 2 Public Const WINDING = 2 Public Const ALTERNATE = 1 Public Type POINTAPI x As Long y As Long End Type Private Declare Function SystemParametersInfo Lib "USER32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long Private Const SPI_SETDESKWALLPAPER = 20 Private Const SPIF_SENDWININICHANGE = &H2 Private Const SPIF_UPDATEINIFILE = &H1 Public Function ChangeWallpaper(sFichier As String) Dim lgRep As Long lgRep = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, sFichier, SPIF_SENDWININICHANGE Or SPIF_UPDATEINIFILE) End Function Public Function MakeRegion(picSkin As PictureBox, mSk As String) As Long Dim x As Long, y As Long, StartLineX As Long Dim FullRegion As Long, LineRegion As Long Dim TransparentColor As Long Dim InFirstRegion As Boolean Dim InLine As Boolean Dim hdc As Long Dim picWidth As Long Dim picHeight As Long hdc = picSkin.hdc picWidth = picSkin.ScaleWidth picHeight = picSkin.ScaleHeight InFirstRegion = True: InLine = False x = y = StartLineX = 0 TransparentColor = RGB(CInt(Mid$(mSk, 1, 3)), CInt(Mid$(mSk, 5, 3)), CInt(Mid$(mSk, 9, 3))) For y = 0 To picHeight - 1 For x = 0 To picWidth - 1 If GetPixel(hdc, x, y) = TransparentColor Or x = picWidth Then If InLine Then InLine = False LineRegion = CreateRectRgn(StartLineX, y, x, y + 1) If InFirstRegion Then FullRegion = LineRegion InFirstRegion = False Else CombineRgn FullRegion, FullRegion, LineRegion, RGN_OR DeleteObject LineRegion End If End If Else If Not InLine Then InLine = True StartLineX = x End If End If Next Next MakeRegion = FullRegion End Function Public Sub RendreFormTjsVisible(MonForm As Object) SetWindowPos MonForm.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE End Sub Public Sub RendreFormTjsNONVisible(MonForm As Object) SetWindowPos MonForm.hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE End Sub '--------------------------------- 'ensuite mettre 11 images dans un fichier ressource (101 a 112) en bitmap avec un fond en damier blanc et la couleur de votre choix (blanc pour les parties transparentes
25 avril 2003 à 11:20
Et puis nous sommes ici pour apprendre !!! Non ?
25 avril 2003 à 11:18
http://www.vbfrance.com/article.aspx?Val=8554
En quelques lignes de codes... ;)
25 avril 2003 à 09:39
25 avril 2003 à 09:39
25 avril 2003 à 09:12
j'en ai d'ailleur posté une il y a + d'un an. donc refai pas les chose ki existent ça sert à rien. inove mon garçon. parce ke la seule différence c'est le quadrillage. pa terible comme modif
bonne continuation 24K
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.