Sub 初始化()
Dim Color_Num As Integer
Word.Text = GetSetting("PUPNAME", "APPNAME", "高亮显示_查找的内容", "[输入关键字]")
zt_B.Value = GetSetting("PUPNAME", "APPNAME", "高亮显示_字体加粗", True)
zt_I.Value = GetSetting("PUPNAME", "APPNAME", "高亮显示_字体倾斜", True)
zt_U.Value = GetSetting("PUPNAME", "APPNAME", "高亮显示_字体下划线", True)
zt_Fs.Text = GetSetting("PUPNAME", "APPNAME", "高亮显示_字体大小", 14)
ys_R.Value = GetSetting("PUPNAME", "APPNAME", "高亮显示_字体红色", True)
ys_G.Value = GetSetting("PUPNAME", "APPNAME", "高亮显示_字体绿色", False)
ys_B.Value = GetSetting("PUPNAME", "APPNAME", "高亮显示_字体蓝色", False)
ys_F.Value = GetSetting("PUPNAME", "APPNAME", "高亮显示_字体粉色", False)
ys_Bl.Value = GetSetting("PUPNAME", "APPNAME", "高亮显示_字体黑色", False)
'--------------------------------------------------
Dim arr, brr
arr = Array("[0-9]+", "[a-zA-Z]+", "[一-﨩]+", "[a-zA-Z]+")
Word.List = arr
brr = Array(9, 10, 11, 12, 14, 16, 18, 20, 24)
zt_Fs.List = brr
'--------------------------------------------------
End Sub
Private Sub CommandButton1_Click()
On Error GoTo line
Dim myRng As Range, q As Long, Rng As Range, myV$
Dim Start_Num%, Str_Len%
Dim F_size, F_style, F_Uline, F_Color
If Word = "" Then MsgBox "请先输入查找的关键字": Exit Sub
'--------------------------------------------------
Set regex1 = CreateObject("VBSCRIPT.REGEXP") 'RegEx为建立正则表达式
With regex1
.Global = True '设置全局可用
.Pattern = Word
End With
'--------------------------------------------------
If TypeName(Selection) <> "Range" Then MsgBox "请先选择需要标记的单元格": Exit Sub
'--------------------------------------------------
If Selection.Count = 1 Then
Set myRng = Intersect(Cells, ActiveSheet.UsedRange)
Else
Set myRng = Intersect(Selection, ActiveSheet.UsedRange)
End If
'--------------------------------------------------
If myRng Is Nothing Then MsgBox "当前选定单元格中没有内容": Exit Sub
F_size = Val(zt_Fs)
'--------------------------------------------------
If zt_B = True Then
If zt_I = True Then F_style = "加粗 倾斜" Else F_style = "加粗"
Else
If zt_I = True Then F_style = "倾斜" Else F_style = ""
End If
'--------------------------------------------------
If zt_U = True Then F_Uline = 2 Else F_Uline = 1 '下划线
'--------------------------------------------------
If ys_R = True Then
F_Color = vbRed
ElseIf ys_G = True Then
F_Color = vbGreen
ElseIf ys_B = True Then
F_Color = vbBlue
ElseIf ys_Bl = True Then
F_Color = vbBlack
ElseIf ys_F = True Then
F_Color = vbMagenta
End If
'--------------------------------------------------
Application.ScreenUpdating = False
For Each Rng In myRng
myV = Rng.Value
If regex1.test(myV) = True Then
Set c = regex1.Execute(myV)
q = q + 1
'--------------------------------------------------
With Rng
For j = 0 To c.Count - 1
Start_Num = c.Item(j).firstindex + 1
Str_Len = c.Item(j).Length
.Characters(Start:=Start_Num, Length:=Str_Len).Font.FontStyle = F_style '加粗与加倾斜
.Characters(Start:=Start_Num, Length:=Str_Len).Font.Underline = F_Uline '加下划线
.Characters(Start:=Start_Num, Length:=Str_Len).Font.Size = F_size
.Characters(Start:=Start_Num, Length:=Str_Len).Font.Color = F_Color '颜色
Next j
End With
'--------------------------------------------------
End If
Next
If q > 0 Then
ts = "共找到" & q & "条记录"
Else
ts = "未找到包含关键字的单元格"
End If
Application.ScreenUpdating = True
Exit Sub
line:
MsgBox Err.Description
End Sub
Private Sub Frame1_Click()
End Sub
Private Sub Frame2_Click()
End Sub
Private Sub ts_Click()
End Sub
Private Sub UserForm_Initialize()
Call 初始化
End Sub
Sub 保存结果()
SaveSetting "PUPNAME", "APPNAME", "高亮显示_查找的内容", Word.Text
SaveSetting "PUPNAME", "APPNAME", "高亮显示_字体加粗", zt_B.Value
SaveSetting "PUPNAME", "APPNAME", "高亮显示_字体倾斜", zt_I.Value
SaveSetting "PUPNAME", "APPNAME", "高亮显示_字体下划线", zt_U.Value
SaveSetting "PUPNAME", "APPNAME", "高亮显示_字体大小", zt_Fs.Text
SaveSetting "PUPNAME", "APPNAME", "高亮显示_字体红色", ys_R.Value
SaveSetting "PUPNAME", "APPNAME", "高亮显示_字体绿色", ys_G.Value
SaveSetting "PUPNAME", "APPNAME", "高亮显示_字体蓝色", ys_B.Value
SaveSetting "PUPNAME", "APPNAME", "高亮显示_字体粉色", ys_F.Value
SaveSetting "PUPNAME", "APPNAME", "高亮显示_字体黑色", ys_Bl.Value
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Call 保存结果
End Sub
Private Sub Word_Change()
End Sub
Private Sub Word_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Word = ""
End Sub