Public Module GlassText Public Structure BITMAPINFO Public bmiHeader As BITMAPINFOHEADER Public bmiColors As RGBQUAD End Structure Public Structure BITMAPINFOHEADER Public biSize As Integer Public biWidth As Integer Public biHeight As Integer Public biPlanes As Short Public biBitCount As Short Public biCompression As Integer Public biSizeImage As Integer Public biXPelsPerMeter As Integer Public biYPelsPerMeter As Integer Public biClrUsed As Integer Public biClrImportant As Integer End Structure Public Structure DTTOPTS Public dwSize As UInteger Public dwFlags As UInteger Public crText As UInteger Public crBorder As UInteger Public crShadow As UInteger Public iTextShadowType As Integer Public ptShadowOffset As POINTAPI Public iBorderSize As Integer Public iFontPropId As Integer Public iColorPropId As Integer Public iStateId As Integer Public fApplyOverlay As Integer Public iGlowSize As Integer Public pfnDrawTextCallback As IntPtr Public lParam As Integer End Structure Public Structure RECT Public left As Integer Public top As Integer Public right As Integer Public bottom As Integer End Structure Public Structure RGBQUAD Public rgbBlue As Byte Public rgbGreen As Byte Public rgbRed As Byte Public rgbReserved As Byte End Structure Friend Const BI_RGB As Integer = 0 Friend Const DIB_RGB_COLORS As Integer = 0 Friend Const DT_CENTER As Integer = 1 Friend Const DTT_COMPOSITED As Integer = CInt((1 << 13)) Friend Const DTT_GLOWSIZE As Integer = CInt((1 << 11)) Friend Const DT_NOPREFIX As Integer = 2048 Friend Const DT_SINGLELINE As Integer = 32 Friend Const DT_VCENTER As Integer = 4 Friend Const SRCCOPY As Integer = 13369376 _ Public Function BitBlt(ByVal hdc As IntPtr, ByVal nXDest As Integer, ByVal nYDest As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal hdcSrc As IntPtr, ByVal nXSrc As Integer, ByVal nYSrc As Integer, ByVal dwRop As UInteger) As Boolean End Function _ Public Function CreateCompatibleDC(ByVal hDC As IntPtr) As IntPtr End Function _ Public Function CreateDIBSection(ByVal hdc As IntPtr, ByRef pbmi As BITMAPINFO, ByVal iUsage As UInteger, ByVal ppvBits As Integer, ByVal hSection As IntPtr, ByVal dwOffset As UInteger) As IntPtr End Function _ Public Function DeleteDC(ByVal hdc As IntPtr) As Boolean End Function _ Public Function DeleteObject(ByVal hObject As IntPtr) As Boolean End Function _ Public Function DrawThemeText(ByVal hTheme As IntPtr, ByVal hdc As IntPtr, ByVal iPartId As Integer, ByVal iStateId As Integer, ByVal text As String, ByVal iCharCount As Integer, ByVal dwFlags1 As Integer, ByVal dwFlags2 As Integer, ByRef pRect As RECT) As Integer End Function _ Public Function DrawThemeTextEx(ByVal hTheme As IntPtr, ByVal hdc As IntPtr, ByVal iPartId As Integer, ByVal iStateId As Integer, ByVal text As String, ByVal iCharCount As Integer, ByVal dwFlags As Integer, ByRef pRect As RECT, ByRef pOptions As DTTOPTS) As Integer End Function _ Public Sub DwmIsCompositionEnabled(ByRef enabledptr As Integer) End Sub _ Public Function GetDC(ByVal hdc As IntPtr) As IntPtr End Function _ Public Function ReleaseDC(ByVal hdc As IntPtr, ByVal state As Integer) As Integer End Function _ Public Function SaveDC(ByVal hdc As IntPtr) As Integer End Function _ Public Function SelectObject(ByVal hDC As IntPtr, ByVal hObject As IntPtr) As IntPtr End Function Public Sub DrawTextOnGlass(ByVal handle As IntPtr, ByVal text As String, ByVal font As Font, ByVal drawRectangle As Rectangle, ByVal glowSize As Integer) If IsCompositionEnabled() Then 'Temporary variables Dim bitmap As IntPtr Dim bitmapOld As IntPtr = IntPtr.Zero Dim destinationDC As IntPtr = GetDC(handle) Dim dib As New BITMAPINFO() Dim dttOpts As New DTTOPTS() Dim hFont As IntPtr = font.ToHfont() Dim logfnotOld As IntPtr Dim rectangle1 As New RECT() Dim rectangle2 As New RECT() Dim renderer As New System.Windows.Forms.VisualStyles.VisualStyleRenderer(System.Windows.Forms.VisualStyles.VisualStyleElement.Window.Caption.Active) Dim memoryDC As IntPtr = CreateCompatibleDC(destinationDC) Dim uFormat As Integer 'Set-up positioning rectangles With rectangle1 .left = drawRectangle.Left .right = drawRectangle.Right + 2 * glowSize .top = drawRectangle.Top .bottom = drawRectangle.Bottom + 2 * glowSize End With With rectangle2 .left = 0 .top = 0 .right = rectangle1.right - rectangle1.left .bottom = rectangle1.bottom - rectangle1.top End With With dib.bmiHeader .biHeight = -(rectangle1.bottom - rectangle1.top) .biWidth = rectangle1.right - rectangle1.left .biPlanes = 1 .biSize = Marshal.SizeOf(GetType(BITMAPINFOHEADER)) .biBitCount = 32 .biCompression = BI_RGB End With If Not SaveDC(memoryDC) = 0 Then bitmap = CreateDIBSection(memoryDC, dib, DIB_RGB_COLORS, 0, IntPtr.Zero, 0) If Not bitmap = IntPtr.Zero Then bitmapOld = SelectObject(memoryDC, bitmap) logfnotOld = SelectObject(memoryDC, hFont) Try With DTTOPTS .dwSize = CUInt(CInt(Marshal.SizeOf(GetType(DTTOPTS)))) .dwFlags = DTT_COMPOSITED Or DTT_GLOWSIZE .iGlowSize = glowSize End With DrawThemeTextEx(renderer.Handle, memoryDC, 0, 0, text, -1, uFormat, rectangle2, dttOpts) BitBlt(destinationDC, rectangle1.left, rectangle1.top, rectangle1.right - rectangle1.left, rectangle1.bottom - rectangle1.top, memoryDC, 0, 0, SRCCOPY) Catch exception As Exception MessageBox.Show("An exception in the MyContacts.Internal.Common.DrawTextOnGlass method occured:" & _doubleLine & exception.Message, "Error Drawing On Glass", MessageBoxButtons.OK, MessageBoxIcon.Error) End Try 'Unload objects SelectObject(memoryDC, bitmapOld) SelectObject(memoryDC, logfnotOld) DeleteObject(bitmap) DeleteObject(hFont) ReleaseDC(memoryDC, -1) DeleteDC(memoryDC) End If End If Else 'Draws standard text if Aero is turned off Control.FromHandle(handle).CreateGraphics.DrawString(text, font, Brushes.Black, drawRectangle) End If End Sub Friend Function IsCompositionEnabled() As Boolean If Environment.OSVersion.Version.Major < 6 Then Return False Else Dim compositionEnabled As Integer = 0 DwmIsCompositionEnabled(compositionEnabled) If compositionEnabled > 0 Then Return True Else Return False End If End If End Function End Module