Accueil > > > TRANSPARENCE VIA BIDOUILLES POUR WIN9X
TRANSPARENCE VIA BIDOUILLES POUR WIN9X
Information sur la source
Description
Bon je tiens a le preciser td suite, ceci est une grosse bidouille mais ki marche a merveille ! En gros cele permet de faire des OSD (ou tout autre application que vous pourrez realiser avec) semis transparents ... le principe: - creer une image de fond en damier gris en blanc. sachant bien sur que la couleur blanche sera la couleur transparente; donc si damier 1 carré sur 2 alors transparent a 50% ! plus il y aura de blanc plus ca sera transparent :) - mettre en transparent ce blanc (image + form) et c tout ! rien de plus dur que cela ! bonne bidouille koi mais ca marche :) a 50% de transparence ca va c correct pas trop aliasé mais + ou - alors il faut trouver un systeme de lissage ou je ne c koi car ca pixelise a mort :) Pour les grincheux les critiques inutiles ne sont pas forcements les biens venues mais bon vive la liberte dexpression ... :)
Source
- '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
-
-
'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
Conclusion
Pour les feneant ya un zip (oui je sais kil y en a :)) avec un exemple sympa d'un OSD nvo de volume :)
Bien a vous. @++++ Christophe.
Sources du même auteur
Sources de la même categorie
Commentaires et avis
|
Derniers Blogs
[DIVERS] SUIVRE VOS SéRIES PRéFéRéS SUR LA TOILE[DIVERS] SUIVRE VOS SéRIES PRéFéRéS SUR LA TOILE par orion
Comme de nombreux geek, je suis un grand amateur de série TV et je rate régulièrement des épisodes de mes séries préférés. Une solution s'offre à vous avec ce merveilleux site : Tv Gorge - www.tvgorge.com Moteur de recherche à l'appui, vous pouvez ...
Cliquez pour lire la suite de l'article par orion TECHDAYS PARIS 2010 : LA BI DANS SHAREPOINT 2010TECHDAYS PARIS 2010 : LA BI DANS SHAREPOINT 2010 par ROMELARD Fabrice
Animé par: Vincent Bellet et Baptiste Giraudier La BI dans SharePoint 2010, Les nouveaux services d'application dans SP2010 et SQL Server Reporting services 2008 R2. La BI dans SharePoint est généralisée pour tous afin de permettre à tous les coll...
Cliquez pour lire la suite de l'article par ROMELARD Fabrice TECHDAYS PARIS 2010 : PLAN DE MIGRATION VERS SHAREPOINT 2010TECHDAYS PARIS 2010 : PLAN DE MIGRATION VERS SHAREPOINT 2010 par ROMELARD Fabrice
Animé par: Arnault Nouvel et Antoine Dongois Le processus à prendre : Apprendre (découvrir la plateforme) Préparer (documenter l'historique et choisir la méthode de MAJ) Test (Test de MAJ) Implémenter (Effectuer la MAJ) Valid...
Cliquez pour lire la suite de l'article par ROMELARD Fabrice TECHDAYS PARIS 2010 : LA PLEINIèRE DU SECOND JOURTECHDAYS PARIS 2010 : LA PLEINIèRE DU SECOND JOUR par ROMELARD Fabrice
Après un retour sur l'histoire des TechDays de Paris et le fait que ce soit le plus gros event MS au monde (du fait de sa gratuité), le président de MS France (Eric Boustoullier) a fait une présentation de la vision Microsoft pour les années à venir...
Cliquez pour lire la suite de l'article par ROMELARD Fabrice
Forum
RE : TEMPS REEL RE : TEMPS REEL par ucfoutu
Cliquez pour lire la suite par ucfoutu
Logiciels
DB-MAIN (9.1.0)DB-MAIN (9.1.0)DB-MAIN is a data-modeling and data-architecture tool. It is designed to help developers and anal... Cliquez pour télécharger DB-MAIN Xilisoft DPG Convertisseur (5.1.37.0120)XILISOFT DPG CONVERTISSEUR (5.1.37.0120)Xilisoft DPG Convertisseur offre aux fans de Nintendo DS une bonne solution leur permettant de dé... Cliquez pour télécharger Xilisoft DPG Convertisseur GraphicsGale (2.01.01)GRAPHICSGALE (2.01.01)GraphicsGale est un logiciel de PixelArt avec de nombreuse fonctionnalités permettant de réalisé ... Cliquez pour télécharger GraphicsGale Architecte 3D (Platinum 2010)ARCHITECTE 3D (PLATINUM 2010)Architecte 3D Platinium vous permet de concevoir facilement les plans votre future maison, de l'é... Cliquez pour télécharger Architecte 3D TeamViewer 5 (TeamViewer 5)TEAMVIEWER 5 (TEAMVIEWER 5)Dépanner un ami,expliquer une manipulation devient un jeu d'enfant.
Prise en main d'un autre ord... Cliquez pour télécharger TeamViewer 5
|