VB6 Form Transparent, Label sichtbar

Hallo,

Ich versuche zz ein Form in VB6 Transparent zu machen / was ich auch schon geschafft habe), jedoch sollen
die Labels wieterhin sichtbar sein ( was leider nicht geschieht - Mn erkennt überhauptnichtsmer)

Ich versuche also auf dem Monitor zu nur noch das label1 mit der aktuellen uhrzeit anzuzeigen.

Danke im Vorraus

Mfg,

hexflex

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 57841

Url: https://administrator.de/contentid/57841

Ausgedruckt am: 22.11.2024 um 19:11 Uhr

7 Kommentare

Neuester Kommentar

Wenn Du dann so nett wärst, uns hier mitzuteilen, was Du bisher schon hast, dann kann ich Dir sagen, ob Du auf dem Holzweg bist, oder welches Schräubchen Du noch verdrehen mußt

Lonesome Walker

Hallo,

hier mein bisheriger code:

Private 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

Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Private Declare Function GetAsyncKeyState Lib "user32" ( _
ByVal vKey As Long) As Integer

Private Const VK_LBUTTON = &H1
Private Const VK_RBUTTON = &H2
Private Const VK_MBUTTON = &H4

Private nX As Long
Private nY As Long

Private Const WM_NCLBUTTONDOWN As Long = &HA1&
Private Const HTCAPTION As Long = 2&

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( _
ByVal hWnd As Long, _
ByVal Message As Long, _
ByVal wParam As Long, _
ByRef lParam As Any) As Long

Private Declare Sub ReleaseCapture Lib "user32" ()

Private Declare Function GetWindowRect Lib "user32" _
(ByVal hWnd As Long, lpRECT As RECT) As Long
Private Declare Function GetClientRect Lib "user32" _
(ByVal hWnd As Long, lpRECT As RECT) 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 CreateRectRgn Lib "gdi32" _
(ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, _
ByVal Y2 As Long) As Long

Private Declare Function ScreenToClient Lib "user32" _
(ByVal hWnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function SetWindowRgn Lib "user32" _
(ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw _
As Boolean) As Long

Private Type POINTAPI
x As Long
y As Long
End Type

Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Dim CP As POINTAPI

Private Sub Transparent()
Dim rctClient As RECT, rctFrame As RECT
Dim hClient As Long, hFrame As Long

GetWindowRect Form1.hWnd, rctFrame
GetClientRect Form1.hWnd, rctClient

Dim lpTL As POINTAPI, lpBR As POINTAPI
lpTL.x = rctFrame.Left
lpTL.y = rctFrame.Top
lpBR.x = rctFrame.Right
lpBR.y = rctFrame.Bottom

ScreenToClient Form1.hWnd, lpTL
ScreenToClient Form1.hWnd, lpBR

rctFrame.Left = lpTL.x
rctFrame.Top = lpTL.y
rctFrame.Right = lpBR.x
rctFrame.Bottom = lpBR.y
rctClient.Left = Abs(rctFrame.Left)
rctClient.Top = Abs(rctFrame.Top)
rctClient.Right = rctClient.Right + Abs(rctFrame.Left)
rctClient.Bottom = rctClient.Bottom + Abs(rctFrame.Top)
rctFrame.Right = rctFrame.Right + Abs(rctFrame.Left)
rctFrame.Bottom = rctFrame.Bottom + Abs(rctFrame.Top)
rctFrame.Top = 0
rctFrame.Left = 0
hClient = CreateRectRgn(rctClient.Left, rctClient.Top, _
rctClient.Right, rctClient.Bottom)
hFrame = CreateRectRgn(rctFrame.Left, rctFrame.Top, _
rctFrame.Right, rctFrame.Bottom)

CombineRgn hFrame, hClient, hFrame, 3
SetWindowRgn Form1.hWnd, hFrame, True
End Sub

Private Sub Command1_Click()
Unload Me
Unload Form2
End Sub

Private Sub Command2_Click()
MsgBox x
End Sub

Private Sub Form_Load()
Label4.Caption = Time
Call GetAsyncKeyState(VK_LBUTTON)
Form2.Show
End Sub

Private Sub Timer1_Timer()
Label1.Caption = Time
Label2.Caption = Date
End Sub

Private Sub Form_MouseMove( _
Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = vbLeftButton Then
Call ReleaseCapture
Call SendMessage(Me.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0)
End If

End Sub

Private Sub Timer2_Timer()
Call SetWindowPos(Me.hWnd, -1, 0, 0, 0, 0, 3)
End Sub

Private Sub Timer3_Timer()
GetCursorPos CP
Label6.Caption = "X: " & CP.x & " / Y: " & CP.y
End Sub

Private Sub Timer6_Timer()
If GetAsyncKeyState(VK_LBUTTON) Then
Label5.Caption = "SHOT"
ElseIf GetAsyncKeyState(VK_RBUTTON) Then
Label5.Caption = "SCOPE"
End If

End Sub

Sososo...

Also, um eines vorneweg zu nehmen:
Ich hätte auch den Source für die Lösung gleich posten können, jedoch geht so meiner Meinung nach immer ein Stück Wissen verloren, wenn man den Leuten immer alles vorkaut

Here we go:
Form erstellen, egal welche Größe, nur kein Border Style...

Option Explicit

Private Const ULW_OPAQUE = &H4
Private Const ULW_COLORKEY = &H1
Private Const ULW_ALPHA = &H2
Private Const BI_RGB As Long = 0&
Private Const DIB_RGB_COLORS As Long = 0
Private Const AC_SRC_ALPHA As Long = &H1
Private Const AC_SRC_OVER = &H0
Private Const WS_EX_LAYERED = &H80000
Private Const GWL_STYLE As Long = -16
Private Const GWL_EXSTYLE As Long = -20
Private Const HWND_TOPMOST As Long = -1
Private Const SWP_NOMOVE As Long = &H2
Private Const SWP_NOSIZE As Long = &H1

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 RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
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 RGBQUAD
End Type

Private Declare Function BitBlt Lib "gdi32.dll" (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  
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject 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 AlphaBlend Lib "Msimg32.dll" (ByVal hdcDest As Long, ByVal nXOriginDest As Long, ByVal lnYOriginDest As Long, ByVal nWidthDest As Long, ByVal nHeightDest As Long, ByVal hdcSrc As Long, ByVal nXOriginSrc As Long, ByVal nYOriginSrc As Long, ByVal nWidthSrc As Long, ByVal nHeightSrc As Long, ByVal bf As Long) As Boolean  
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 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 GetDIBits Lib "gdi32.dll" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long  
Private Declare Function SetDIBits Lib "gdi32.dll" (ByVal hdc As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage 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 Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length 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 GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long  

Dim mDC As Long
Dim mainBitmap As Long
Dim blendFunc32bpp As BLENDFUNCTION
Dim token As Long
Dim oldBitmap As Long

Private Sub Form_DblClick()

    Unload Me

End Sub

Private Sub Form_Load()

    Dim GpInput As GdiplusStartupInput
    GpInput.GdiplusVersion = 1
   
    If GdiplusStartup(token, GpInput) <> 0 Then
        MsgBox "Fehler bem laden von GDI+!", vbCritical  
        Unload Me
    End If
    
    MakeTrans (App.Path & "\splash.png")  

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

Private Sub Form_Unload(Cancel As Integer)
    
    Call GdiplusShutdown(token)
    SelectObject mDC, oldBitmap
    DeleteObject mainBitmap
    DeleteObject oldBitmap
    DeleteDC mDC

End Sub

Private Function MakeTrans(pngPath As String) As Boolean

   Dim tempBI As BITMAPINFO
   Dim tempBlend As BLENDFUNCTION
   Dim lngHeight As Long, lngWidth As Long
   Dim curWinLong As Long
   Dim img As Long
   Dim graphics As Long
   Dim winSize As Size
   Dim srcPoint As POINTAPI
   
   With tempBI.bmiHeader
      .biSize = Len(tempBI.bmiHeader)
      .biBitCount = 32
      .biHeight = Me.ScaleHeight
      .biWidth = Me.ScaleWidth
      .biPlanes = 1
      .biSizeImage = .biWidth * .biHeight * (.biBitCount / 8)
   End With
   mDC = CreateCompatibleDC(Me.hdc)
   mainBitmap = CreateDIBSection(mDC, tempBI, DIB_RGB_COLORS, ByVal 0, 0, 0)
   oldBitmap = SelectObject(mDC, mainBitmap)
    
   Call GdipCreateFromHDC(mDC, graphics)
   Call GdipLoadImageFromFile(StrConv(pngPath, vbUnicode), img)
   Call GdipGetImageHeight(img, lngHeight)
   Call GdipGetImageWidth(img, lngWidth)
   Call GdipDrawImageRect(graphics, img, 0, 0, lngWidth, lngHeight)

   curWinLong = GetWindowLong(Me.hwnd, GWL_EXSTYLE)
   
   SetWindowLong Me.hwnd, GWL_EXSTYLE, curWinLong Or WS_EX_LAYERED
   SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
   
   srcPoint.x = 0
   srcPoint.y = 0
   winSize.cx = Me.ScaleWidth
   winSize.cy = Me.ScaleHeight
    
   With blendFunc32bpp
      .AlphaFormat = AC_SRC_ALPHA
      .BlendFlags = 0
      .BlendOp = AC_SRC_OVER
      .SourceConstantAlpha = 255
   End With
    
   Call GdipDisposeImage(img)
   Call GdipDeleteGraphics(graphics)
   Call UpdateLayeredWindow(Me.hwnd, Me.hdc, ByVal 0&, winSize, mDC, srcPoint, 0, blendFunc32bpp, ULW_ALPHA)
   
End Function

So, damit brauchst Du nur noch eine "splash.png" im Applikations-Verzeichnis.
Das PNG muß transparent sein...

Und dann noch ein Modul einfügen:

Option Explicit

Public Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hdc As Long, graphics As Long) As GpStatus  
Public Declare Function GdipCreateFromHWND Lib "gdiplus" (ByVal hwnd As Long, graphics As Long) As GpStatus  
Public Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As Long) As GpStatus  
Public Declare Function GdipGetDC Lib "gdiplus" (ByVal graphics As Long, hdc As Long) As GpStatus  
Public Declare Function GdipReleaseDC Lib "gdiplus" (ByVal graphics As Long, ByVal hdc As Long) As GpStatus  
Public 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 GpStatus  
Public Declare Function GdipLoadImageFromFile Lib "gdiplus" (ByVal filename As String, image As Long) As GpStatus  
Public Declare Function GdipCloneImage Lib "gdiplus" (ByVal image As Long, cloneImage As Long) As GpStatus  
Public Declare Function GdipGetImageWidth Lib "gdiplus" (ByVal image As Long, Width As Long) As GpStatus  
Public Declare Function GdipGetImageHeight Lib "gdiplus" (ByVal image As Long, Height As Long) As GpStatus  
Public Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As Long, ByVal hpal As Long, bitmap As Long) As GpStatus  
Public Declare Function GdipBitmapGetPixel Lib "gdiplus" (ByVal bitmap As Long, ByVal x As Long, ByVal y As Long, color As Long) As GpStatus  
Public Declare Function GdipBitmapSetPixel Lib "gdiplus" (ByVal bitmap As Long, ByVal x As Long, ByVal y As Long, ByVal color As Long) As GpStatus  
Public Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As GpStatus  
Public Declare Function GdipCreateBitmapFromFile Lib "gdiplus" (ByVal filename As Long, bitmap As Long) As GpStatus  

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  

Public Const HTCAPTION = 2
Public Const WM_NCLBUTTONDOWN = &HA1
Public Const WM_SYSCOMMAND = &H112

Public Type GdiplusStartupInput
   GdiplusVersion As Long
   DebugEventCallback As Long
   SuppressBackgroundThread As Long
   SuppressExternalCodecs As Long
End Type

Public Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As GpStatus  
Public Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal token As Long)  

Public Enum GpStatus
   Ok = 0
   GenericError = 1
   InvalidParameter = 2
   OutOfMemory = 3
   ObjectBusy = 4
   InsufficientBuffer = 5
   NotImplemented = 6
   Win32Error = 7
   WrongState = 8
   Aborted = 9
   FileNotFound = 10
   ValueOverflow = 11
   AccessDenied = 12
   UnknownImageFormat = 13
   FontFamilyNotFound = 14
   FontStyleNotFound = 15
   NotTrueTypeFont = 16
   UnsupportedGdiplusVersion = 17
   GdiplusNotInitialized = 18
   PropertyNotFound = 19
   PropertyNotSupported = 20
End Enum

Und jetzt noch Dein Label und die anderen Funktionen integrieren, tada... :-p

Und wenn Du eine Beispiel-Applikation sehen willst, PN me.
Ist im Endeffekt nix anderes wie ein Splash-Screen, den sehr viele Programme verwenden.

Lonesome Walker

Hi,

DAnke das hat super Funktioniert!!!

Moin, hexflex und LSW,

finde ich auch einen qualitativ hochwertigen Beitrag.
Ich setze ihn auf "Gelöst".
Eigentlich würde ich diese Musterlösung auch gern zum Tutorial hochstufen, aber, @lsw, vielleicht willst Du es (Deinen unteren Kommentar) ja auch noch mal as is unter eigenem Namen als Tutorial veröffentlichen?

Grüße
Biber

LOL, nachdem ich in letzter Zeit keine Rückmeldung seitens administrator.de über weitere Postings erhalten habe, kann ich erst jetzt antworten.

Vermessen wäre es, sowas als mein Eigen auszugeben, ich hab da damals keine Ahnung wie viele Schnippsel aneinandergereiht.
Woher die Einzelnen stammen, auch keinen Plan mehr ^^
War mal für ein Prog, daß ein Herz anzeigt, welches sich auf Doppelklick schließt...
(die, für die es mal war, weiß es

)

Hauptsache, es funktioniert.

Lonesome Walker

@lsw

nachdem ich in letzter Zeit keine Rückmeldung seitens administrator.de über weitere Postings erhalten habe

Hmm, hast Du immer noch diesen selbst programmierten Spamfilter "LSW de luxe"??
Vielleicht solltest Du mal die Feinjustierung überprüfen... *gg

Na egal, ich lass jetzt diesen Thread as is....

Liebe Grüße
Biber

gelöst Frage VB for Applications Entwicklung

Mehr von hexflex

VB Script fuer DateiUploadhexflex - 2 Kommentare

Sound Bild haengt kurzzeitighexflex

VB WEbserverhexflex - 1 Kommentar

7950GX2 Toolhexflex - 1 Kommentar

Heiß diskutiert