效果图如下：
源代码如下:
'*********************************************************************************************************************************************
'重画DataGrid列样式，显示网站类型，链接
'*********************************************************************************************************************************************
Public Class FiveColumn_Style2
Inherits DataGridColumnStyle
Private xMargin As Integer = 2
Private yMargin As Integer = 2
Private CurrentRow As Integer = -1 '用于datagrid_mousemove事件中，引起label的更新
''''''''''''需要的控件
Private WithEvents m_Label As LinkLabel '显示链接
'Private WithEvents Pic_Favorite As PictureBox '显示是否加入过收藏夹
'Private WithEvents Pic_State As PictureBox '显示是否打得开
Private WithEvents Pic_Analize As PictureBox
''''''''''''需要的图片
Private Image_Favorite_true As Image
Private Image_Favorite_false As Image
Private Image_State_true As Image
Private Image_State_false As Image
Private Image_State_unknow As Image
Private Image_Analize_true As Image
Private Image_Analize_false As Image
Public WriteOnly Property SetPath_Favorite_true() As String
Set(ByVal Path As String)
''读取图片
Image_Favorite_true = Image.FromFile(Path)
End Set
End Property
Public WriteOnly Property SetPath_Favorite_false() As String
Set(ByVal Path As String)
Image_Favorite_false = Image.FromFile(Path)
End Set
End Property
Public WriteOnly Property SetPath_State_true() As String
Set(ByVal Value As String)
Image_State_true = Image.FromFile(Value)
End Set
End Property
Public WriteOnly Property SetPath_State_false() As String
Set(ByVal Value As String)
Image_State_false = Image.FromFile(Value)
End Set
End Property
Public WriteOnly Property SetPath_State_unknow() As String
Set(ByVal Value As String)
Image_State_unknow = Image.FromFile(Value)
End Set
End Property
Public WriteOnly Property SetPath_Analize_true() As String
Set(ByVal Value As String)
Image_Analize_true = Image.FromFile(Value)
End Set
End Property
Public WriteOnly Property SetPath_Analize_false() As String
Set(ByVal Value As String)
Image_Analize_false = Image.FromFile(Value)
End Set
End Property
'需要的文本提示
Private ServerToolTip As ToolTip '显示服务器信息
Private TopicToolTip As ToolTip '摘要信息
'Private ContentToolTip As ToolTip '内容信息
'提示文本
Private m_tipstr As String = ""
Private WithEvents m_datagrid As DataGrid
'Private m_CurrentRow As Integer = -1 '用于datagrid_mouseup事件中，引起选中行后变色
Private ImagePath As String = Application.StartupPath
'显示结果分析
Private WithEvents m_tootip As Form2
'设置当前用户点击时Datagird的current
Private Sub SetCurrentRowNum(ByVal Value As Integer)
Me.CurrentRow = Value
If Me.CurrentRow < 0 Then
m_Label.Visible = False
Me.Pic_Analize.Visible = False
End If
End Sub
'初始化
Sub New()
Me.CurrentRow = -1
m_Label = New LinkLabel()
m_Label.Font = New Font("宋体", 9, FontStyle.Regular)
m_Label.Text = ""
m_Label.Visible = False
m_Label.TextAlign = ContentAlignment.TopLeft
m_Label.Height = 10
Me.Pic_Analize = New PictureBox()
Pic_Analize.SizeMode = PictureBoxSizeMode.StretchImage
Pic_Analize.Cursor = Cursors.Hand
Pic_Analize.Size = Me.imagesize
Me.Pic_Analize.Visible = False
ServerToolTip = New ToolTip()
TopicToolTip = New ToolTip()
'm_tootip = New Form2()
End Sub
'当点击了链节后，打开url
Private Sub Label_LinkClicked(ByVal sender As Object, ByVal e As System.Windows.Forms.LinkLabelLinkClickedEventArgs) Handles m_Label.LinkClicked
Dim myproc As System.Diagnostics.Process
myproc = New System.Diagnostics.Process()
myproc.Start("IExplore.exe", m_Label.Tag)
End Sub
'------------------------------------------------------
'从 DataGridColumnStyle类继承下来的方法
'------------------------------------------------------
Protected Overloads Overrides Sub Abort(ByVal RowNum As Integer)
End Sub
' 接受改变
Protected Overloads Overrides Function Commit(ByVal DataSource As CurrencyManager, _
ByVal RowNum As Integer) As Boolean
End Function
' 移开聚焦
Protected Overloads Overrides Sub ConcedeFocus()
End Sub
' 编辑单元格
Protected Overloads Overrides Sub Edit(ByVal Source As CurrencyManager, _
ByVal Rownum As Integer, _
ByVal Bounds As Rectangle, _
ByVal [ReadOnly] As Boolean, _
ByVal InstantText As String, _
ByVal CellIsVisible As Boolean)
End Sub
Protected Overloads Overrides Function GetMinimumHeight() As Integer
End Function
Protected Overloads Overrides Function GetPreferredHeight(ByVal g As Graphics, _
ByVal Value As Object) As Integer
Dim NewLineIndex As Integer = 0
Dim NewLines As Integer = 0
Try
Dim ValueString As String = Me.GetText(Value)
Do
While NewLineIndex <> -1
NewLineIndex = ValueString.IndexOf("r/n", NewLineIndex + 1)
NewLines += 1
End While
Loop
Catch es As Exception
End Try
Return FontHeight * NewLines + yMargin
End Function
Protected Overloads Overrides Function GetPreferredSize(ByVal g As Graphics, _
ByVal Value As Object) As Size
Dim Extents As Size
Try
Extents = System.Drawing.Size.Ceiling(g.MeasureString(GetText(Value), _
Me.DataGridTableStyle.DataGrid.Font))
Extents.Width += xMargin * 2 + DataGridTableGridLineWidth
Extents.Height += yMargin
Catch es As Exception
End Try
Return Extents
End Function
Protected Overloads Overrides Sub Paint(ByVal g As Graphics, _
ByVal Bounds As Rectangle, _
ByVal Source As CurrencyManager, _
ByVal RowNum As Integer)
Paint(g, Bounds, Source, RowNum, False)
End Sub
'和单元格底部的距离
Private Const botton As Integer = 2
'三个小图标的间隔
Private Const intnear As Integer = 3
'图像的大小
Private imagesize As New Size(13, 13)
'文本分几行显示
Private Const RowDisplay As Integer = 3
'对文本分行
Private Function TextMuiltilize(ByVal str As String, ByRef g As Graphics) As String
If g Is Nothing Then Exit Function
If str = "" Then Exit Function
Dim newstr As String
Dim tmpStr As String
' assume we are using same fonts
Dim font As System.Drawing.Font = New Font("宋体", 9)
Dim i As Integer = 0
' we want to measure the width of string byte by byte in case we found
' double bytes characters. If we find it has reached the right bounds, we
' append a line break
Do While str.Length > 0
Do
If str.Length <= 0 Then
Exit Do
End If
If g.MeasureString(tmpStr & Left(str, 1), font).Width >= (Me.Width - 1) Then
Exit Do
End If
tmpStr = tmpStr & Left(str, 1)
str = str.Substring(1)
Loop
If newstr = "" Then
newstr = tmpStr
Else
newstr = newstr & vbCrLf & tmpStr
End If
i = i + 1
If i >= RowDisplay Then
'if there is a fouth line, we move two characters away and put ...
If str.Length > 0 Then
str = Right(tmpStr, 2) & str
newstr = Left(newstr, Len(newstr) - 3) & "..."
End If
Exit Do
End If
tmpStr = ""
Loop
Return newstr
End Function
Private Structure Range_Str
Public Range As CharacterRange
Public Str As String
End Structure
'关键字变色
Private Sub PaintKeyWord(ByVal newStr As String, ByVal keyword As String, ByVal Bounds As Rectangle, ByVal RowNum As Integer, ByVal dbrush As Brush, ByRef g As Graphics)
If newStr = "" Then Exit Sub
Try
'保存charactarrange和其中的字符
Dim CharRangeList As ArrayList = CreatCRange(newStr, keyword)
Dim i As Integer
Dim count As Integer
If CharRangeList.Count > 32 Then
count = 32
Else
count = CharRangeList.Count
End If
'把arraylist中的Range赋予array
Dim CRangeArray(count - 1) As CharacterRange
For i = 0 To count - 1
CRangeArray(i) = CType(CharRangeList(i), Range_Str).Range
Next
'字符串格式
Dim stringFormat As New StringFormat
stringFormat.SetMeasurableCharacterRanges(CRangeArray)
stringFormat.Alignment = StringAlignment.Near
stringFormat.LineAlignment = StringAlignment.Near
'stringFormat.FormatFlags = StringFormatFlags.MeasureTrailingSpaces
'定义字体
Dim font As System.Drawing.Font = New Font("宋体", 9)
'取得newstr的大小
Dim newstrsize As SizeF = g.MeasureString(newStr, font)
'取得newstr所在的bounds
Dim boundsf As New RectangleF(Bounds.X + xMargin, Bounds.Y + yMargin, newstrsize.Width, newstrsize.Height)
'通过此方法生成关于各个CharacterRange在bounds上的Region
Dim stringRegions() As Region = g.MeasureCharacterRanges(newStr, font, boundsf, stringFormat)
'根据每个相关关键字字符串的bounds,画成红色
For i = 0 To stringRegions.Length - 1
Dim measureRect As RectangleF = stringRegions(i).GetBounds(g)
Dim m_size As SizeF = g.MeasureString(CType(CharRangeList(i), Range_Str).Str, font)
Dim MymeasureRect As New RectangleF(measureRect.X - 1, measureRect.Y, m_size.Width - m_size.Width * 30 / 100, m_size.Height - m_size.Height * 20 / 100)
If Me.m_datagrid.CurrentRowIndex = RowNum Then
g.FillRectangle(dbrush, MymeasureRect)
Else
g.FillRectangle(Brushes.White, MymeasureRect)
End If
g.DrawString(CType(CharRangeList(i), Range_Str).Str, font, Brushes.Red, MymeasureRect.X - xMargin, MymeasureRect.Y)
Next
Catch e As System.Exception
Trace.WriteLine("ERROR AT KEYWORD RED " & e.ToString)
End Try
End Sub
Private Function CreatCRange(ByVal OriStr As String, ByVal Keyword As String) As ArrayList
Dim myRangeArray As New ArrayList()
If OriStr = "" Then
Return myRangeArray
End If
'扫描文本，看其每一字符是否存在于关键在中间,if exit then add Range_Str structure into arraylist to return
Dim i As Integer
For i = 0 To OriStr.Length - 1
If Keyword.ToLower.IndexOf(OriStr.Chars(i).ToString.ToLower) >= 0 Then
Dim R_S As New Range_Str()
R_S.Range = New CharacterRange(i, 1)
R_S.Str = OriStr.Chars(i)
myRangeArray.Add(R_S)
End If
Next
Return myRangeArray
End Function
'url与三个图标之间的间隔
Private Const UrlNear As Integer = 35
Private Const AnalizeNum As Integer = 5
'重画的主要函数
Protected Overloads Overrides Sub Paint(ByVal g As Graphics, _
ByVal Bounds As Rectangle, _
ByVal Source As CurrencyManager, _
ByVal RowNum As Integer, _
ByVal AlignToRight As Boolean)
'画背景
Dim dbrush As Brush = New SolidBrush(System.Drawing.Color.FromArgb(CType(230, Byte), CType(236, Byte), CType(238, Byte)))
Dim m_CurrentRow As Integer = Me.m_datagrid.CurrentRowIndex
If m_CurrentRow = RowNum Then
g.FillRectangle(dbrush, Bounds)
Else
g.FillRectangle(Brushes.White, Bounds)
End If
'定义字体
Dim font As System.Drawing.Font = New Font("宋体", 9)
'得到绑定的文本并区分
Dim Text As String = GetText(GetColumnValueAtRow(Source, RowNum)).Replace(vbLf, "")
Dim str() As String = Microsoft.VisualBasic.Split(Text, "$@")
'title和url必须有
Dim keyword As String = str(0).Trim ' 关键字
Dim Url As String '链接
If str.Length > 1 Then
Url = str(1).Trim
End If
Dim Content As String '内容
If str.Length > 2 Then
Content = str(2).Trim
End If
Dim State As Integer = 0
Dim Server As String = ""
Dim Modifed As String = ""
Dim AnalizeInfo As String = ""
Dim BoolFavorite As Integer = 0
'对可能存在的文本赋值
If str.Length > 3 Then
If Char.IsDigit(str(3).Trim) Then
State = str(3).Trim
Else
State = 0
End If
End If
If str.Length > 4 Then
Server = str(4).Trim
End If
If str.Length > 5 Then
Modifed = str(5).Trim
End If
If str.Length > 6 Then
AnalizeInfo = str(6).Trim
End If
If str.Length > 7 Then
If str(7).Trim = "" Then
BoolFavorite = 0
Else
BoolFavorite = str(7).Trim
End If
End If
'计算url的大小
Dim TextSize As SizeF = g.MeasureString(Url, New Font("宋体", 9))
'设置各自的位置
''url
Dim point_url As New Point(Bounds.X + Me.xMargin, Bounds.Y + Bounds.Height - Me.botton - TextSize.Height)
''content
Dim point_content As New Point(Bounds.X + Me.xMargin, Bounds.Y + Me.yMargin)
''Favorite
Dim point_favorite As New Point(Bounds.X + Bounds.Width - 3 * (intnear + imagesize.Width), Bounds.Y + Bounds.Height - imagesize.Height - Me.botton)
'’State
Dim point_state As New Point(Bounds.X + Bounds.Width - 2 * (intnear + imagesize.Width), Bounds.Y + Bounds.Height - imagesize.Height - Me.botton)
''Analize
Dim point_analize As New Point(Bounds.X + Bounds.Width - (intnear + imagesize.Width), Bounds.Y + Bounds.Height - imagesize.Height - Me.botton)
Dim newstr As String = TextMuiltilize(Content, g)
'画内容
g.DrawString(newstr, font, Brushes.Black, Bounds.X + Me.xMargin, Bounds.Y + Me.yMargin)
'画关键字
Me.PaintKeyWord(newstr, keyword, Bounds, RowNum, dbrush, g)
'当不是选中行时，画image
Dim lineFont As New Font("宋体", 9, FontStyle.Underline)
'画url
'如果url太长了
Dim NewUrl As String
Dim Url_Width As Integer = (Me.Width - 3 * (Me.intnear + Me.imagesize.Width) - UrlNear)
If g.MeasureString(Url, font).Width > Url_Width Then
Dim layoutSize As New SizeF(Url_Width, TextSize.Height)
Dim newStringFormat As New StringFormat()
' Measure string.
'取得bounds内的字符个数
Dim charactersFitted As Integer
'取得bounds内的字符行数
Dim linesFilled As Integer
Dim stringSize As SizeF = g.MeasureString(Url, font, layoutSize, newStringFormat, charactersFitted, linesFilled)
NewUrl = Url.Substring(0, charactersFitted) & "..."
Else
NewUrl = Url
End If
Dim url_format As New StringFormat()
url_format.HotkeyPrefix = Drawing.Text.HotkeyPrefix.Show
g.DrawString(NewUrl, lineFont, Brushes.Blue, point_url.X, point_url.Y, url_format)
'画结果分析
If AnalizeInfo.Length > AnalizeNum Then
' g.DrawImage(Me.Image_Analize_false, point_analize.X, point_analize.Y, imagesize.Width, imagesize.Height)
'Else
g.DrawImage(Me.Image_Analize_true, point_analize.X, point_analize.Y, imagesize.Width, imagesize.Height)
End If
'画state
If State = 0 Then
g.DrawImage(Me.Image_State_false, point_state.X, point_state.Y, imagesize.Width, imagesize.Height)
ElseIf State = 1 Then
g.DrawImage(Me.Image_State_true, point_state.X, point_state.Y, imagesize.Width, imagesize.Height)
Else
g.DrawImage(Me.Image_State_unknow, point_state.X, point_state.Y, imagesize.Width, imagesize.Height)
End If
'画favorite
If BoolFavorite = 0 Then
'g.DrawImage(Me.Image_Favorite_false, point_favorite.X, point_favorite.Y, imagesize.Width, imagesize.Height)
Else
g.DrawImage(Me.Image_Favorite_true, point_favorite.X, point_favorite.Y, imagesize.Width, imagesize.Height)
End If
'如果此行为当前行，需要显示linklabel,和三个picturebox
If CurrentRow = RowNum Then
'如果是选中行，需要改变背景色
If m_CurrentRow = RowNum Then
m_Label.BackColor = System.Drawing.Color.FromArgb(CType(230, Byte), CType(236, Byte), CType(238, Byte))
Else
m_Label.BackColor = Color.White
End If
'
'为linklabel设置bounds
m_Label.Tag = Url
m_Label.Text = NewUrl
'设置label显示的位置和大小
Dim UrlSize As SizeF = g.MeasureString(NewUrl, New Font("宋体", 9))
m_Label.SetBounds(point_url.X, point_url.Y, UrlSize.Width + 2, UrlSize.Height)
m_Label.Visible = True
''设置能否打开picture控件的bounds
'''打不开
If State = 0 Then
ServerToolTip.RemoveAll()
Else
Me.m_tipstr = "服务器类型：" & Server & vbCrLf & "最后更新时间：" & Modifed
ServerToolTip.SetToolTip(m_Label, Me.m_tipstr)
End If
'设置结果分析picturebox的bounds
'没有结果
'如果没有做页面分析则不显示图片
If AnalizeInfo.Length > AnalizeNum Then
Me.Pic_Analize.Image = Me.Image_Analize_true
Me.Pic_Analize.Enabled = True
Me.Pic_Analize.Tag = AnalizeInfo
Me.m_tipstr = "查看摘要"
TopicToolTip.SetToolTip(Pic_Analize, Me.m_tipstr)
Me.Pic_Analize.Visible = True
Else
Me.Pic_Analize.Visible = False
End If
Me.Pic_Analize.SetBounds(point_analize.X, point_analize.Y, imagesize.Width, imagesize.Height)
End If
'如果label所在位置不是当前行，就不要显示label
If m_datagrid.HitTest(m_Label.Location).Row <> CurrentRow Then
m_Label.Visible = False
Me.Pic_Analize.Visible = False
End If
End Sub
Protected Overloads Sub Paint(ByVal g As Graphics, _
ByVal Bounds As Rectangle, _
ByVal Source As CurrencyManager, _
ByVal RowNum As Integer, _
ByVal BackBrush As Brush, _
ByVal ForeBrush As Brush, _
ByVal AlignToRight As Boolean)
Paint(g, Bounds, Source, RowNum, False)
End Sub
Protected Overloads Overrides Sub SetDataGridInColumn(ByVal Value As DataGrid)
MyBase.SetDataGridInColumn(Value)
'加入linklabel作为datagrid的子控件
Value.Controls.Add(m_Label)
Value.Controls.Add(Me.Pic_Analize)
'Value.Controls.Add(Me.Pic_State)
'引用datagrid
Me.m_datagrid = Value
End Sub
Protected Overloads Overrides Sub UpdateUI(ByVal Source As CurrencyManager, _
ByVal RowNum As Integer, ByVal InstantText As String)
End Sub
Private ReadOnly Property DataGridTableGridLineWidth() As Integer
Get
If Me.DataGridTableStyle.GridLineStyle = DataGridLineStyle.Solid Then
Return 1
Else
Return 0
End If
End Get
End Property
'得到绑定的数据源的某列的某行的文本
Private Function GetText(ByVal Value As Object) As String
If Value Is System.DBNull.Value Then Return NullText
If Not Value Is Nothing Then
Return Value.ToString
Else
Return String.Empty
End If
End Function
'纪录前次的行值
Private oldrownum As Integer = -1
'在mousemove事件中引发当前行的paint，和old行的paint
Private Sub m_datagrid_MouseMove(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles m_datagrid.MouseMove
'如果激活的窗体不是住窗体，不要动
If Not (Form.ActiveForm Is m_datagrid.FindForm) Then
Exit Sub
End If
'得到鼠标位置的row和column值
Dim hittest As DataGrid.HitTestInfo = m_datagrid.HitTest(m_datagrid.PointToClient(m_datagrid.MousePosition))
'设置当前行
Me.SetCurrentRowNum(hittest.Row)
End Sub
'当点击在label上时，也需要变色
Private Sub Label_MouseDown(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles m_Label.MouseDown, Pic_Analize.MouseDown
Dim hittest As DataGrid.HitTestInfo = m_datagrid.HitTest(m_datagrid.PointToClient(m_datagrid.MousePosition))
If hittest.Row >= 0 Then
Me.m_datagrid.CurrentRowIndex = hittest.Row
End If
'刷新整个grid，---------------------保留，可以改成刷新单元格
m_datagrid.Refresh()
End Sub
Private Sub m_datagrid_DataSourceChanged(ByVal sender As Object, ByVal e As System.EventArgs) Handles m_datagrid.DataSourceChanged
m_Label.Visible = False
Me.Pic_Analize.Visible = False
End Sub
Private Sub m_tootip_Deactivate(ByVal sender As Object, ByVal e As System.EventArgs) Handles m_tootip.Deactivate
If Not (m_tootip.IsDisposed) Then
m_tootip.Close()
End If
Me.m_Label.FindForm.Activate()
m_datagrid.Focus()
End Sub
Private Sub FiveColumn_Style2_WidthChanged(ByVal sender As Object, ByVal e As System.EventArgs) Handles MyBase.WidthChanged
Me.m_Label.Visible = False
Me.Pic_Analize.Visible = False
End Sub
Private Sub Pic_Analize_MouseEnter(ByVal sender As Object, ByVal e As System.EventArgs) Handles Pic_Analize.MouseEnter
If IsNothing(m_tootip) Then
ElseIf m_tootip.IsDisposed Then
Else
Exit Sub
End If
m_tootip = New Form2()
Dim PicLocate As Point = New Point(m_datagrid.MousePosition.X + Pic_Analize.Width, m_datagrid.MousePosition.Y + Pic_Analize.Height)
m_tootip.Location = New Point(PicLocate.X - m_tootip.Width, PicLocate.Y - m_tootip.Height)
m_tootip.SetText = Pic_Analize.Tag
m_tootip.Show()
AddHandler m_tootip.PctBack.MouseLeave, AddressOf m_tootip_MouseLeave
End Sub
Private Sub m_tootip_MouseLeave(ByVal sender As Object, ByVal e As System.EventArgs) 'Handles m_tootip.MouseLeave
Dim rect As Rectangle = (New Rectangle(m_tootip.Location, m_tootip.Size))
If rect.Contains(m_datagrid.MousePosition) Then
'donothing
Else
If Not (m_tootip.IsDisposed) Then
m_tootip.Close()
End If
End If
Me.m_Label.FindForm.Activate()
m_datagrid.Focus()
End Sub
End Class
随后有测试程序代码。。。
795
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
