Visual Basic Foro
Programación => Visual Basic 6 => Mensaje iniciado por: YAcosta en Agosto 22, 2013, 03:11:50 pm
-
Siempre he usado un formulario como splash donde pongo el logo de mi soft y este luego se va después de 3 segundos (como hacen muchos), este usa transparencia con la clase clsCDImage.cls.
Siempre me fue perfecto en WindowsXP pero ahora que estoy pasando el programa a Windows7 no me hace bien la transparencia.
Fíjense en WindowsXP:
(http://i.snag.gy/cMWYm.jpg)
Y el mismo en Windows7:
(http://i.snag.gy/FMrhA.jpg)
Y no entiendo porque. He revisado el codigo pero no logro captar donde puede estar el problema.
Aqui les paso el proyecto que use en este ejemplo.
FormularioTransparente (https://dl.dropboxusercontent.com/u/4052038/Otros/FormTransp.rar)
Ojala me puedan echar una manito.
P.D: Siempre me pasa que cuando decido alejarme de la programación me aprueban mas proyectos :-)
-
El .exe me lo freno el Antivirus >:(
-
No abras el exe, eso lo genere para hacer mis pruebas, abre el proyecto. Todos los antivirus chillan cuando entra un exe, incluso en mi maquina cuando lo pase de la maquina virtual el AVAST me salto pero eso lo hace siempre, no hay trauma.
EDITO: Pa que no halla terror quite el exe y volvi a subir el proyecto:
Proyecto (https://dl.dropboxusercontent.com/u/4052038/Otros/FormTransp.rar) (Es el mismo porque lo subi con el mismo nombre)
-
Hola Yvan, el motivo es porque usa un color del sistema para el color de fondo del el png (vbButtonFace) (ese un parámetro opcional de la función LoadPng) y luego al llamar MakeFormTransparent utilizas un color estático, entonces según como este configurado en la pc el color cambia, por supuesto XP pordefecto tiene uno y W7 tiene otro. asi que bien le puse un color gris para que no se noten mucho los pixeles aplha y quedaria asi.
Private Sub Form_Load()
Set cdImage = New clsCDImage
With cdImage
If .SelectedTypeImage = ARCHIVO_PNG Then
frmSplash.Picture = .LoadPng(App.Path & "\aaa.png", Me, &HC8D0D4)
End If
End With
Set cdImage = Nothing
Refresh
MakeFormTransparent Me, &HC8D0D4
End Sub
Más abajo te paso otra manera de hacerlo.
-
Hola, Cobein hace un tiempo había echo un modulo clase para hacer esto, pero no lo encontré, igualmente este código hace lo mismo, la diferencia con el modo anterior que estas usando, es que no muestra los pixeles que se ven en el contorno de la imagen, lo cual hace que se vea mas lindo. las contras, es que no podes poner un control sobre el form (almenos de forma sensilla) y la otra requiere XP en adelante.
En un modulo bas pone este codigo
Option Explicit
Public Declare Function ReleaseCapture Lib "user32" () 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
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32.dll" (ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, ByRef lplpVoid As Any, ByVal handle As Long, ByVal dw As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function SetWindowPos Lib "user32.dll" (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
Private Declare Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function UpdateLayeredWindow Lib "user32.dll" (ByVal hwnd As Long, ByVal hdcDst As Long, pptDst As Any, psize As Any, ByVal hdcSrc As Long, pptSrc As Any, ByVal crKey As Long, ByRef pblend As BLENDFUNCTION, ByVal dwFlags As Long) As Long
Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hdc As Long, graphics As Long) As Long
Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As Long) As Long
Private Declare Function GdipDrawImageRect Lib "gdiplus" (ByVal graphics As Long, ByVal image As Long, ByVal x As Single, ByVal y As Single, ByVal Width As Single, ByVal Height As Single) As Long
Private Declare Function GdipLoadImageFromFile Lib "gdiplus" (ByVal filename As String, image As Long) As Long
Private Declare Function GdipGetImageWidth Lib "gdiplus" (ByVal image As Long, Width As Long) As Long
Private Declare Function GdipGetImageHeight Lib "gdiplus" (ByVal image As Long, Height As Long) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As Long
Private Declare Function GdiplusStartup Lib "gdiplus" (gToken As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal gToken As Long)
Private Type BLENDFUNCTION
BlendOp As Byte
BlendFlags As Byte
SourceConstantAlpha As Byte
AlphaFormat As Byte
End Type
Private Type Size
cx As Long
cy As Long
End Type
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type BITMAPINFOHEADER
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
biClrUsed As Long
biClrImportant As Long
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors() As Long
End Type
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Const ULW_ALPHA As Long = &H2
Private Const DIB_RGB_COLORS As Long = 0
Private Const AC_SRC_ALPHA As Long = &H1
Private Const AC_SRC_OVER As Long = &H0
Private Const WS_EX_LAYERED As Long = &H80000
Private Const GWL_EXSTYLE As Long = -20
Private Const HWND_TOPMOST As Long = -1
Private Const SWP_NOMOVE As Long = &H2
Public Const HTCAPTION As Long = 2
Public Const WM_NCLBUTTONDOWN As Long = &HA1
Public Function SplashForm(Frm As Form, sImgPath As String) As Boolean
Dim GpInput As GdiplusStartupInput
Dim BI As BITMAPINFO
Dim hImage As Long
Dim hGraphics As Long
Dim SZ As Size
Dim PT As POINTAPI
Dim mDC As Long
Dim hBitmap As Long
Dim BF As BLENDFUNCTION
Dim gToken As Long
Dim OldhBitmap As Long
GpInput.GdiplusVersion = 1
If GdiplusStartup(gToken, GpInput) = 0 Then
If GdipLoadImageFromFile(StrConv(sImgPath, vbUnicode), hImage) = 0 Then
Call GdipGetImageWidth(hImage, SZ.cx)
Call GdipGetImageHeight(hImage, SZ.cy)
mDC = CreateCompatibleDC(Frm.hdc)
With BI.bmiHeader
.biSize = Len(BI.bmiHeader)
.biBitCount = 32
.biWidth = SZ.cx
.biHeight = SZ.cy
.biPlanes = 1
.biSizeImage = .biWidth * .biHeight * (.biBitCount / 8)
End With
hBitmap = CreateDIBSection(mDC, BI, DIB_RGB_COLORS, ByVal 0, 0, 0)
OldhBitmap = SelectObject(mDC, hBitmap)
Call GdipCreateFromHDC(mDC, hGraphics)
Call GdipDrawImageRect(hGraphics, hImage, 0, 0, SZ.cx, SZ.cy)
Call GdipDisposeImage(hImage)
Call GdipDeleteGraphics(hGraphics)
Call GdiplusShutdown(gToken)
Else
Call GdiplusShutdown(gToken)
MsgBox "Error al leer la imágen", vbCritical
Exit Function
End If
Else
MsgBox "Error al iniciar GDI+", vbCritical
Exit Function
End If
SetWindowLong Frm.hwnd, GWL_EXSTYLE, GetWindowLong(Frm.hwnd, GWL_EXSTYLE) Or WS_EX_LAYERED
SetWindowPos Frm.hwnd, HWND_TOPMOST, 0, 0, SZ.cx, SZ.cy, SWP_NOMOVE
With BF
.AlphaFormat = AC_SRC_ALPHA
.BlendOp = AC_SRC_OVER
.SourceConstantAlpha = 255
End With
SplashForm = UpdateLayeredWindow(Frm.hwnd, Frm.hdc, ByVal 0&, SZ, mDC, PT, 0, BF, ULW_ALPHA)
DeleteObject SelectObject(mDC, OldhBitmap)
DeleteDC mDC
End Function
y para probarlo en un formulario sin bordes
Option Explicit
Private Sub Form_Load()
Call SplashForm(Me, "C:\Users\Windows\Desktop\FormTransp\aaa.png")
End Sub
Private Sub Form_DblClick()
Unload Me
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Call ReleaseCapture
SendMessage Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
End Sub
-
Amigo muchisimas gracias, acabo de llegar a casa un poco molido asi que mañana temprano lo estoy implementando, muchismas gracias.
Abrazos.
-
Hola Yvan, solo entré para contestarte respecto a
P.D: Siempre me pasa que cuando decido alejarme de la programación me aprueban mas proyectos :-)
MALDITA LEY DE MURPHY
-
jajaj, cierto Pedro, esta es la segunda vez en la vida que me pasa, hace 10 años me iba a dedicar al video, estuve unos meses y empezaron a salir ventas, ahora me esta pasando casi lo mismo. Ya se entonces que hacer cuando me vaya mal jaja... Me dedicare al video para vender mas software... :-)
Leandro, la primera forma funciono perfecto. Voy a probar la segunda. Un abrazo.