Imports System
Imports System.Runtime.InteropServices
Imports System.Drawing
Namespace ZBobb
'/ <summary>
'/ Win32 support code.
'/ (C) 2003 Bob Bradley / (e-mail address removed)
'/ </summary>
Public Class win32
Public Const WM_MOUSEMOVE As Integer = &H200
Public Const WM_LBUTTONDOWN As Integer = &H201
Public Const WM_LBUTTONUP As Integer = &H202
Public Const WM_RBUTTONDOWN As Integer = &H204
Public Const WM_LBUTTONDBLCLK As Integer = &H203
Public Const WM_MOUSELEAVE As Integer = &H2A3
Public Const WM_PAINT As Integer = &HF
Public Const WM_ERASEBKGND As Integer = &H14
Public Const WM_PRINT As Integer = &H317
'const int EN_HSCROLL = 0x0601;
'const int EN_VSCROLL = 0x0602;
Public Const WM_HSCROLL As Integer = &H114
Public Const WM_VSCROLL As Integer = &H115
Public Const EM_GETSEL As Integer = &HB0
Public Const EM_LINEINDEX As Integer = &HBB
Public Const EM_LINEFROMCHAR As Integer = &HC9
Public Const EM_POSFROMCHAR As Integer = &HD6
Public Declare Function PostMessage Lib "USER32.DLL" Alias
"PostMessage" (ByVal hwnd As IntPtr, ByVal msg As System.UInt32, ByVal
wParam As IntPtr, ByVal lParam As IntPtr) As Boolean 'ToDo: Unsigned
Integers not supported
'
' BOOL PostMessage( HWND hWnd,
' UINT Msg,
' WPARAM wParam,
' LPARAM lParam
' );
'
' Put this declaration in your class //IntPtr
Public Declare Function SendMessage Lib "USER32.DLL" Alias
"SendMessage" (ByVal hwnd As IntPtr, ByVal msg As Integer, ByVal wParam As
IntPtr, ByVal lParam As IntPtr) As Integer
Public Declare Function GetCaretBlinkTime Lib "USER32.DLL" Alias
"GetCaretBlinkTime" () As System.UInt32 'ToDo: Unsigned Integers not
supported
Private Const WM_PRINTCLIENT As Integer = &H318
Private Const PRF_CHECKVISIBLE As Long = &H1L
Private Const PRF_NONCLIENT As Long = &H2L
Private Const PRF_CLIENT As Long = &H4L
Private Const PRF_ERASEBKGND As Long = &H8L
Private Const PRF_CHILDREN As Long = &H10L
Private Const PRF_OWNED As Long = &H20L
' Will clean this up later doing something like this
' enum CaptureOptions : long
' {
' PRF_CHECKVISIBLE= 0x00000001L,
' PRF_NONCLIENT = 0x00000002L,
' PRF_CLIENT = 0x00000004L,
' PRF_ERASEBKGND = 0x00000008L,
' PRF_CHILDREN = 0x00000010L,
' PRF_OWNED = 0x00000020L
' }
'
Public Shared Function CaptureWindow(control As
System.Windows.Forms.Control, ByRef bitmap As System.Drawing.Bitmap) As
Boolean
'This function captures the contents of a window or control
Dim g2 As Graphics = Graphics.FromImage(bitmap)
'PRF_CHILDREN // PRF_NONCLIENT
Dim meint As Integer = CInt(PRF_CLIENT Or PRF_ERASEBKGND) '|
PRF_OWNED ); // );
Dim meptr As New System.IntPtr(meint)
Dim hdc As System.IntPtr = g2.GetHdc()
win32.SendMessage(control.Handle, win32.WM_PRINT, hdc, meptr)
g2.ReleaseHdc(hdc)
g2.Dispose()
Return True
End Function 'CaptureWindow
End Class 'win32
End Namespace 'ZBobb
Imports System
Imports System.Collections
Imports System.ComponentModel
Imports System.Drawing
Imports System.Data
Imports System.Windows.Forms
Imports System.Drawing.Imaging
Namespace ZBobb
'/ <summary>
'/ AlphaBlendTextBox: A .Net textbox that can be translucent to the
background.
'/ (C) 2003 Bob Bradley / (e-mail address removed)
'/ </summary>
'/
Public Class AlphaBlendTextBox
Inherits System.Windows.Forms.TextBox
#Region "private variables"
Private myPictureBox As uPictureBox
Private myUpToDate As Boolean = False
Private myCaretUpToDate As Boolean = False
Private myBitmap As Bitmap
Private myAlphaBitmap As Bitmap
Private myFontHeight As Integer = 10
Private myTimer1 As System.Windows.Forms.Timer
Private myCaretState As Boolean = True
Private myPaintedFirstTime As Boolean = False
Private myBackColor As Color = Color.White
Private myBackAlpha As Integer = 10
'/ <summary>
'/ Required designer variable.
'/ </summary>
Private components As System.ComponentModel.Container = Nothing
#End Region
#Region "public methods and overrides"
Public Sub New()
' This call is required by the Windows.Forms Form Designer.
InitializeComponent()
' TODO: Add any initialization after the InitializeComponent
call
Me.BackColor = myBackColor
Me.SetStyle(ControlStyles.UserPaint, False)
Me.SetStyle(ControlStyles.AllPaintingInWmPaint, True)
Me.SetStyle(ControlStyles.DoubleBuffer, True)
myPictureBox = New uPictureBox()
Me.Controls.Add(myPictureBox)
myPictureBox.Dock = DockStyle.Fill
End Sub 'New
Protected Overrides Sub OnResize(ByVal e As EventArgs)
MyBase.OnResize(e)
Me.myBitmap = New Bitmap(Me.ClientRectangle.Width,
Me.ClientRectangle.Height) '(this.Width,this.Height);
Me.myAlphaBitmap = New Bitmap(Me.ClientRectangle.Width,
Me.ClientRectangle.Height) '(this.Width,this.Height);
myUpToDate = False
Me.Invalidate()
End Sub 'OnResize
'Some of these should be moved to the WndProc later
Protected Overrides Sub OnKeyDown(ByVal e As KeyEventArgs)
MyBase.OnKeyDown(e)
myUpToDate = False
Me.Invalidate()
End Sub 'OnKeyDown
Protected Overrides Sub OnKeyUp(ByVal e As KeyEventArgs)
MyBase.OnKeyUp(e)
myUpToDate = False
Me.Invalidate()
End Sub 'OnKeyUp
Protected Overrides Sub OnKeyPress(ByVal e As KeyPressEventArgs)
MyBase.OnKeyPress(e)
myUpToDate = False
Me.Invalidate()
End Sub 'OnKeyPress
Protected Overrides Sub OnMouseUp(ByVal e As MouseEventArgs)
MyBase.OnMouseUp(e)
Me.Invalidate()
End Sub 'OnMouseUp
Protected Overrides Sub OnGiveFeedback(ByVal gfbevent As
GiveFeedbackEventArgs)
MyBase.OnGiveFeedback(gfbevent)
myUpToDate = False
Me.Invalidate()
End Sub 'OnGiveFeedback
Protected Overrides Sub OnMouseLeave(ByVal e As EventArgs)
'found this code to find the current cursor location
'at
http://www.syncfusion.com/FAQ/WinForms/FAQ_c50c.asp#q597q
Dim ptCursor As Point = Cursor.Position
Dim f As Form = Me.FindForm()
ptCursor = f.PointToClient(ptCursor)
If Not Me.Bounds.Contains(ptCursor) Then
MyBase.OnMouseLeave(e)
End If
End Sub 'OnMouseLeave
Protected Overrides Sub OnChangeUICues(ByVal e As UICuesEventArgs)
MyBase.OnChangeUICues(e)
myUpToDate = False
Me.Invalidate()
End Sub 'OnChangeUICues
'--
Protected Overrides Sub OnGotFocus(ByVal e As EventArgs)
MyBase.OnGotFocus(e)
myCaretUpToDate = False
myUpToDate = False
Me.Invalidate()
myTimer1 = New System.Windows.Forms.Timer(Me.components)
myTimer1.Interval = CInt(win32.GetCaretBlinkTime()) ' usually
around 500;
AddHandler myTimer1.Tick, AddressOf myTimer1_Tick
myTimer1.Enabled = True
End Sub 'OnGotFocus
Protected Overrides Sub OnLostFocus(ByVal e As EventArgs)
MyBase.OnLostFocus(e)
myCaretUpToDate = False
myUpToDate = False
Me.Invalidate()
myTimer1.Dispose()
End Sub 'OnLostFocus
'--
Protected Overrides Sub OnFontChanged(ByVal e As EventArgs)
If Me.myPaintedFirstTime Then
Me.SetStyle(ControlStyles.UserPaint, False)
End If
MyBase.OnFontChanged(e)
If Me.myPaintedFirstTime Then
Me.SetStyle(ControlStyles.UserPaint, True)
End If
myFontHeight = GetFontHeight()
myUpToDate = False
Me.Invalidate()
End Sub 'OnFontChanged
Protected Overrides Sub OnTextChanged(ByVal e As EventArgs)
MyBase.OnTextChanged(e)
myUpToDate = False
Me.Invalidate()
End Sub 'OnTextChanged
Protected Overrides Sub WndProc(ByRef m As Message)
MyBase.WndProc(m)
' need to rewrite as a big switch
If m.Msg = win32.WM_PAINT Then
myPaintedFirstTime = True
If Not myUpToDate OrElse Not myCaretUpToDate Then
GetBitmaps()
End If
myUpToDate = True
myCaretUpToDate = True
If Not (myPictureBox.Image Is Nothing) Then
myPictureBox.Image.Dispose()
End If
myPictureBox.Image = CType(myAlphaBitmap.Clone(), Image)
ElseIf m.Msg = win32.WM_HSCROLL OrElse m.Msg = win32.WM_VSCROLL
Then
myUpToDate = False
Me.Invalidate()
ElseIf m.Msg = win32.WM_LBUTTONDOWN OrElse m.Msg =
win32.WM_RBUTTONDOWN OrElse m.Msg = win32.WM_LBUTTONDBLCLK Then
' || m.Msg == win32.WM_MOUSELEAVE ///****
myUpToDate = False
Me.Invalidate()
ElseIf m.Msg = win32.WM_MOUSEMOVE Then
If m.WParam.ToInt32() <> 0 Then 'shift key or other buttons
myUpToDate = False
Me.Invalidate()
End If
End If
End Sub 'WndProc
'System.Diagnostics.Debug.WriteLine("Pro: " + m.Msg.ToString("X"));
'/ <summary>
'/ Clean up any resources being used.
'/ </summary>
Protected Overrides Sub Dispose(ByVal disposing As Boolean)
If disposing Then
'this.BackColor = Color.Pink;
If Not (components Is Nothing) Then
components.Dispose()
End If
End If
MyBase.Dispose(disposing)
End Sub 'Dispose
#End Region
#Region "public property overrides"
Public Shadows Property BorderStyle() As BorderStyle
Get
Return MyBase.BorderStyle
End Get
Set(ByVal value As BorderStyle)
If Me.myPaintedFirstTime Then
Me.SetStyle(ControlStyles.UserPaint, False)
End If
MyBase.BorderStyle = value
If Me.myPaintedFirstTime Then
Me.SetStyle(ControlStyles.UserPaint, True)
End If
Me.myBitmap = Nothing
Me.myAlphaBitmap = Nothing
myUpToDate = False
Me.Invalidate()
End Set
End Property
Public Shadows Property BackColor() As Color
Get
Return Color.FromArgb(MyBase.BackColor.R,
MyBase.BackColor.G, MyBase.BackColor.B)
End Get
Set(ByVal value As Color)
myBackColor = value
MyBase.BackColor = value
myUpToDate = False
End Set
End Property
Public Overrides Property Multiline() As Boolean
Get
Return MyBase.Multiline
End Get
Set(ByVal value As Boolean)
If Me.myPaintedFirstTime Then
Me.SetStyle(ControlStyles.UserPaint, False)
End If
MyBase.Multiline = value
If Me.myPaintedFirstTime Then
Me.SetStyle(ControlStyles.UserPaint, True)
End If
Me.myBitmap = Nothing
Me.myAlphaBitmap = Nothing
myUpToDate = False
Me.Invalidate()
End Set
End Property
#End Region
#Region "private functions and classes"
Private Function GetFontHeight() As Integer
Dim g As Graphics = Me.CreateGraphics()
Dim sf_font As SizeF = g.MeasureString("X", Me.Font)
g.Dispose()
Return CInt(sf_font.Height)
End Function 'GetFontHeight
Private Sub GetBitmaps()
If myBitmap Is Nothing OrElse myAlphaBitmap Is Nothing OrElse
myBitmap.Width <> Width OrElse myBitmap.Height <> Height OrElse
myAlphaBitmap.Width <> Width OrElse myAlphaBitmap.Height <> Height Then
myBitmap = Nothing
myAlphaBitmap = Nothing
End If
If myBitmap Is Nothing Then
myBitmap = New Bitmap(Me.ClientRectangle.Width,
Me.ClientRectangle.Height) '(Width,Height);
myUpToDate = False
End If
If Not myUpToDate Then
'Capture the TextBox control window
Me.SetStyle(ControlStyles.UserPaint, False)
win32.CaptureWindow(Me, myBitmap)
Me.SetStyle(ControlStyles.UserPaint, True)
Me.SetStyle(ControlStyles.SupportsTransparentBackColor,
True)
Me.BackColor = Color.FromArgb(myBackAlpha, myBackColor)
End If
'--
Dim r2 As New Rectangle(0, 0, Me.ClientRectangle.Width,
Me.ClientRectangle.Height)
Dim tempImageAttr As New ImageAttributes()
'Found the color map code in the MS Help
Dim tempColorMap(0) As ColorMap
tempColorMap(0) = New ColorMap()
tempColorMap(0).OldColor = Color.FromArgb(255, myBackColor)
tempColorMap(0).NewColor = Color.FromArgb(myBackAlpha,
myBackColor)
tempImageAttr.SetRemapTable(tempColorMap)
If Not (myAlphaBitmap Is Nothing) Then
myAlphaBitmap.Dispose()
End If
myAlphaBitmap = New Bitmap(Me.ClientRectangle.Width,
Me.ClientRectangle.Height) '(Width,Height);
Dim tempGraphics1 As Graphics =
Graphics.FromImage(myAlphaBitmap)
tempGraphics1.DrawImage(myBitmap, r2, 0, 0,
Me.ClientRectangle.Width, Me.ClientRectangle.Height, GraphicsUnit.Pixel,
tempImageAttr)
tempGraphics1.Dispose()
'----
If Me.Focused AndAlso Me.SelectionLength = 0 Then
Dim tempGraphics2 As Graphics =
Graphics.FromImage(myAlphaBitmap)
If myCaretState Then
'Draw the caret
Dim caret As Point = Me.findCaret()
Dim p As New Pen(Me.ForeColor, 3)
tempGraphics2.DrawLine(p, caret.X, caret.Y + 0, caret.X,
caret.Y + myFontHeight)
tempGraphics2.Dispose()
End If
End If
End Sub 'GetBitmaps
Private Function findCaret() As Point
' Find the caret translated from code at
' *
http://www.vb-helper.com/howto_track_textbox_caret.html
' *
' * and
' *
' *
http://www.microbion.co.uk/developers/csharp/textpos2.htm
' *
' * Changed to EM_POSFROMCHAR
' *
' * This code still needs to be cleaned up and debugged
' *
Dim pointCaret As New Point(0)
Dim i_char_loc As Integer = Me.SelectionStart
Dim pi_char_loc As New IntPtr(i_char_loc)
Dim i_point As Integer = win32.SendMessage(Me.Handle,
win32.EM_POSFROMCHAR, pi_char_loc, IntPtr.Zero)
pointCaret = New Point(i_point)
If i_char_loc = 0 Then
pointCaret = New Point(0)
ElseIf i_char_loc >= Me.Text.Length Then
pi_char_loc = New IntPtr(i_char_loc - 1)
i_point = win32.SendMessage(Me.Handle, win32.EM_POSFROMCHAR,
pi_char_loc, IntPtr.Zero)
pointCaret = New Point(i_point)
Dim g As Graphics = Me.CreateGraphics()
Dim t1 As String = Me.Text.Substring(Me.Text.Length - 1, 1)
+ "X"
Dim sizet1 As SizeF = g.MeasureString(t1, Me.Font)
Dim sizex As SizeF = g.MeasureString("X", Me.Font)
g.Dispose()
Dim xoffset As Integer = CInt(sizet1.Width - sizex.Width)
pointCaret.X = pointCaret.X + xoffset
If i_char_loc = Me.Text.Length Then
Dim slast As String = Me.Text.Substring([Text].Length -
1, 1)
If slast = ControlChars.Lf Then
pointCaret.X = 1
pointCaret.Y = pointCaret.Y + myFontHeight
End If
End If
End If
Return pointCaret
End Function 'findCaret
Private Sub myTimer1_Tick(ByVal sender As Object, ByVal e As
EventArgs)
'Timer used to turn caret on and off for focused control
myCaretState = Not myCaretState
myCaretUpToDate = False
Me.Invalidate()
End Sub 'myTimer1_Tick
Private Class uPictureBox
Inherits PictureBox
Public Sub New()
Me.SetStyle(ControlStyles.Selectable, False)
Me.SetStyle(ControlStyles.UserPaint, True)
Me.SetStyle(ControlStyles.AllPaintingInWmPaint, True)
Me.SetStyle(ControlStyles.DoubleBuffer, True)
Me.Cursor = Nothing
Me.Enabled = True
Me.SizeMode = PictureBoxSizeMode.Normal
End Sub 'New
'uPictureBox
Protected Overrides Sub WndProc(ByRef m As Message)
If m.Msg = win32.WM_LBUTTONDOWN OrElse m.Msg =
win32.WM_RBUTTONDOWN OrElse m.Msg = win32.WM_LBUTTONDBLCLK OrElse m.Msg =
win32.WM_MOUSELEAVE OrElse m.Msg = win32.WM_MOUSEMOVE Then
'Send the above messages back to the parent control
win32.PostMessage(Me.Parent.Handle, CType(m.Msg,
System.UInt32), m.WParam, m.LParam) 'ToDo: Unsigned Integers not supported
ElseIf m.Msg = win32.WM_LBUTTONUP Then
'?? for selects and such
Me.Parent.Invalidate()
End If
MyBase.WndProc(m)
End Sub 'WndProc
End Class 'uPictureBox
' End uPictureBox Class
#End Region
#Region "Component Designer generated code"
'/ <summary>
'/ Required method for Designer support - do not modify
'/ the contents of this method with the code editor.
'/ </summary>
Private Sub InitializeComponent()
End Sub 'InitializeComponent
#End Region
#Region "New Public Properties"
<Category("Appearance"), Description("The alpha value used to blend
the control's background. Valid values are 0 through 255."),
Browsable(True),
DesignerSerializationVisibility(DesignerSerializationVisibility.Visible)> _
Public Property BackAlpha() As Integer
Get
Return myBackAlpha
End Get
Set(ByVal value As Integer)
Dim v As Integer = value
If v > 255 Then
v = 255
End If
myBackAlpha = v
myUpToDate = False
Invalidate()
End Set
End Property
#End Region
End Class 'AlphaBlendTextBox
End Namespace 'ZBobb
' End AlphaTextBox Class
' End namespace ZBobb
'----
If they tell me it can't be done, I just do it until I can do