聚光灯效果
大多数人想要自己做聚光灯首先想到的是条件格式，条件格式有很多弊端，第一点对Excel的撤回功能有影响,第二点只对单个工作簿有作用,每次新的工作簿就没用了.第三点影响工作簿原有的格式.今天介绍两种完美聚光灯的方案
VBA完美聚光灯
原理:条件格式(不同于一般的条件格式)
优点:不会影响excel的撤回功能,不影响工作簿
代码:
thisworkbook中的代码
Private Sub Workbook_Open()
SetForm.Show 0
End Sub
'在sheet激活时，创建条件格式规则
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Call CreateFmt
End Sub
'在sheet取消激活时，删除vbaSetForm的条件规则
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
Call DelActSheetFmt
End Sub
'在选择cell时，SetForm所在行列的条件底色
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Call Highlight
End Sub
'在工作簿关闭前，删除vba创建的条件格式
Private Sub Workbook_BeforeClose(cancel As Boolean)
Call DelAllFmt
End Sub窗体
Private Sub UserForm_Initialize()
InitColor = RGB(255, 213, 151)
SelectStyle = "底色"
Me.style.Value = SelectStyle
Me.choice.BackColor = InitColor
Me.style.AddItem "底色"
Me.style.AddItem "边框"
Me.style.AddItem "关闭"
End Sub
Private Sub UserForm_Activate()
Application.ScreenUpdating = False
Dim fmt As FormatCondition
For Each Sh In Worksheets
'For Each fmt In ActiveSheet.Cells.FormatConditions
For Each fmt In Sh.Cells.FormatConditions
If fmt.Formula1 = "=OR(CELL(""row"")=ROW(), CELL(""col"")=COLUMN())" Then fmt.Delete: Exit For
Next fmt
Next Sh
Application.ScreenUpdating = False
End Sub
Private Sub style_Change()
'SelectStyle = SetForm.style.Value
'TargetColor = SetForm.choice.BackColor
TargetColor = SetForm.choice.BackColor
SelectStyle = SetForm.style.Value
End Sub
Private Sub choice_Click()
Call call_tsb
SetForm.choice.BackColor = TargetColor
End Sub
Private Sub ok_Click()
TargetColor = SetForm.choice.BackColor
SelectStyle = SetForm.style.Value
'SetForm.Hide
Unload SetForm
End Sub
Private Sub cancel_Click()
InitColor = RGB(255, 213, 151)
SelectStyle = "底色"
Me.style.Value = SelectStyle
Me.choice.BackColor = InitColor
End Sub
Private Sub UserForm_Terminate()
TargetColor = SetForm.choice.BackColor
SelectStyle = SetForm.style.Value
'ActiveWorkbook.RefreshAll
If SelectStyle = "关闭" Then
Else
Cells.FormatConditions.Add Type:=xlExpression, Formula1:="=OR(CELL(""row"")=ROW(), CELL(""col"")=COLUMN())"
End If
End Sub
模块:
Option Explicit
Public TargetColor, InitColor, SelectStyle
Sub call_tsb()
Dim oWB As Workbook
Dim iColor
Set oWB = Excel.ThisWorkbook
'将调色板SetForm为默认的
oWB.ResetColors
Dim oDialog As Dialog
Set oDialog = Excel.Application.Dialogs(xlDialogEditColor)
'show方法后一定要输入一个数值参数,才能打开xlDialogEditColor对话框
'该数值可以是1-56之间的任意整数
If oDialog.Show(1) = True Then
'获取选择的颜色
iColor = oWB.Colors(1)
'SetForm单元格的填充色
'oWB.Worksheets(1).Range("a1").Interior.Color = iColor
TargetColor = iColor
'SetForm.CommandButton1.BackColor = TargetColor
End If
End Sub
Sub showset()
SetForm.Show 0
End Sub
Sub DelActSheetFmt()
Dim fmt As FormatCondition
For Each fmt In ActiveSheet.Cells.FormatConditions
If fmt.Formula1 = "=OR(CELL(""row"")=ROW(), CELL(""col"")=COLUMN())" Then fmt.Delete: Exit For
Next fmt
End Sub
Sub DelAllFmt()
Application.ScreenUpdating = False
Dim fmt As FormatCondition
Dim Sh As Worksheet
For Each Sh In Worksheets
'For Each fmt In ActiveSheet.Cells.FormatConditions
For Each fmt In Sh.Cells.FormatConditions
If fmt.Formula1 = "=OR(CELL(""row"")=ROW(), CELL(""col"")=COLUMN())" Then fmt.Delete: Exit For
Next fmt
Next Sh
Application.ScreenUpdating = False
End Sub
Sub Highlight()
Application.ScreenUpdating = False
Dim fmt As FormatCondition
For Each fmt In ActiveSheet.Cells.FormatConditions
'Select Case Sheets("SetForm").Range("B3")
Select Case SelectStyle
Case Is = "底色"
'SetForm底色
'fmt.Interior.Color = Sheets("SetForm").Range("B2").Interior.Color: Exit For
fmt.Interior.Color = TargetColor: Exit For
Case Is = "边框"
'SetForm边框色
'fmt.Borders.Color = Sheets("SetForm").Range("B2").Interior.Color: Exit For
fmt.Borders.Color = TargetColor: Exit For
Case Is = "关闭"
'不高亮显示
End Select
Next fmt
Application.ScreenUpdating = False
End Sub
Sub CreateFmt()
If SelectStyle = "关闭" Then
Else
Cells.FormatConditions.Add Type:=xlExpression, Formula1:="=OR(CELL(""row"")=ROW(), CELL(""col"")=COLUMN())"
End If
End Sub
vb.net完美聚光灯
原理:透明窗体绘制聚光灯形状
优点:不会影响excel的撤回功能,不影响工作簿,每个工作簿都生效
代码:
module1
Imports System.Diagnostics
Imports System.Windows.Forms
Imports System.Windows.Media.Media3D
Imports Microsoft.Office.Interop.Excel
Module Module1
Public xlapp As Excel.Application = Globals.ThisAddIn.Application
Public lightup As Boolean
Public f As Object
Public rngkj As Range '记录选中单元格区域
Public rect_top, rect_left, rect_botton, rect_right As Integer 'excel7rect尺寸
Public blackrect1, blackrect2, blackrect3, blackrect4 As RECT '除选中部分外的4个绘图矩形
Public PPI, ppi_x, ppi_y, ppi_gdt, ppi_d As Long 'ppi_x, ppi_y分别为屏幕水平和垂直像素ppi_gdt为滚动条像素
Public blahand1, blahand2, blahand3, blahand4 As Long '4个绘图区域句柄
Public cs As Integer = 0 '垂直扫描遍数
Public iZoom As Long, lft As Long, tp As Long, wd As Long, ht As Long, zdhh As Long, zdlh As Long
Public UserOption As Int16 = 3 '聚光灯形状选项
'Public jgdcolor As Object = System.Drawing.Color.Yellow '初始颜色为淡黄色
Public transparency As Int16 = 2 '聚光灯形状选项
Public jgdc As Int16 = 1 '聚光灯颜色选项
'//函数//
Function CheckZoom(ByVal Wn As Window) As Boolean
CheckZoom = (Wn.Zoom Mod 100 <> 0)
End Function
Const SW_HIDE = 0
Const SW_SHOWNOACTIVATE = 4
Const SW_SHOW = 5
Const WM_CLOSE = &H10
Const GWL_STYLE = (-16)
Const GWL_EXSTYLE = (-20)
Const WS_BORDER = &H800000
Const WS_CAPTION = &HC00000 ' WS_BORDER Or WS_DLGFRAME
Const WS_CHILD = &H40000000
Const WS_EX_TOOLWINDOW = &H80&
Const WS_EX_TRANSPARENT As Long = &H20&
Const WS_EX_LAYERED = &H80000
Const LWA_ALPHA = &H2
Const LWA_COLORKEY = &H1
Const RGN_AND = 1
Const RGN_OR = 2
Const RGN_XOR = 3
'hWndInsertAfter 参数可选值:
Const HWND_TOP = 0 '在前面}
Const HWND_BOTTOM = 1 '在后面}
Const HWND_TOPMOST = -1 '在前面, 位于任何顶部窗口的前面}
Const HWND_NOTOPMOST = -2 '在前面, 位于其他顶部窗口的后面}
'uFlags 参数可选值:
Public Const SWP_NOSIZE = &H1 '忽略 cxcy, 保持大小
Public Const SWP_NOMOVE = &H2 '忽略 XY, 不改变位置
Public Const SWP_NOZORDER = &H4 '忽略 hWndInsertAfter, 保持 Z 顺序
Public Const SWP_NOREDRAW = &H8 '不重绘
Public Const SWP_NOACTIVATE = &H10 '不激活
Public Const SWP_FRAMECHANGED = &H20 '强制发送 WM_NCCALCSIZE 消息, 一般只是在改变大小时才发送此消息
Public Const SWP_SHOWWINDOW = &H40 '显示窗口
Public Const SWP_HIDEWINDOW = &H80 '隐藏窗口
Public Const SWP_NOCOPYBITS = &H100 '丢弃客户区
Public Const SWP_NOOWNERZORDER = &H200 '忽略 hWndInsertAfter, 不改变 Z 序列的所有者
Public Const SWP_NOSENDCHANGING = &H400 '不发出 WM_WINDOWPOSCHANGING 消息
Const SWP_DRAWFRAME = SWP_FRAMECHANGED '画边框
Const SWP_NOREPOSITION = SWP_NOOWNERZORDER
Const SWP_DEFERERASE = &H2000 '防止产生 WM_SYNCPAINT 消息
Const SWP_ASYNCWINDOWPOS = &H4000 '若调用进程不拥有窗口, 系统会向拥有窗口的线程发出需求
Const WM_SETFOCUS = &H7
Const LOGPIXELSX = 88
Declare Function GetDC Lib "user32" (ByVal hwnd As Integer) As Integer
Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Integer, ByVal hdc As Integer) As Integer
Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Integer, ByVal nIndex As Integer) As Integer
Declare Function IsWindow Lib "user32" (ByVal hwnd As Integer) As Boolean
Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Integer) As Boolean
Declare Function ShowWindow Lib "user32" (ByVal hwnd As Integer, ByVal nCmdShow As Integer) As Integer
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Integer
Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWndParent As Integer, ByVal hwndChildAfter As Integer, ByVal lpszClass As String, ByVal lpszWindow As String) As Integer
Declare Function GetWindowlongPtr Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Integer, ByVal nIndex As Integer) As Integer
Declare Function SetWindowlongPtr Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Integer, ByVal nIndex As Integer, ByVal dwNewinteger As Integer) As Integer
Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Integer, ByVal crKey As Integer, ByVal bAlpha As Byte, ByVal dwFlags As Integer) As Integer
Structure RECT
Dim Left As Integer
Dim Top As Integer
Dim Right As Integer
Dim Bottom As Integer
End Structure
Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Integer, ByRef lpRect As RECT) As Integer
Declare Function GetClientRect Lib "user32" (ByVal hwnd As Integer, ByRef lpRect As RECT) As Integer
'Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Integer, ByVal Y1 As Integer, ByVal X2 As Integer, ByVal Y2 As Integer) As Integer
Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Integer, ByVal Y1 As Integer, ByVal X2 As Integer, ByVal Y2 As Integer) As Integer
Declare Function CreateRectRgnIndirect Lib "gdi32" (ByRef lpRect As RECT) As Integer
Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Integer, ByVal hSrcRgn1 As Integer, ByVal hSrcRgn2 As Integer, ByVal nCombineMode As Integer) As Integer
Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Integer) As Integer
Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Integer, ByVal hRgn As Integer, ByVal bRedraw As Integer) As Integer
Declare Function OffsetRgn Lib "gdi32" (ByVal hRgn As Integer, ByVal x As Integer, ByVal y As Integer) As Integer
Declare Function MoveWindow Lib "user32" (ByVal hwnd As Integer, ByVal x As Integer, ByVal y As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal bRepaint As Integer) As Integer
Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Integer, ByVal hWndInsertAfter As Integer, ByVal x As Integer, ByVal y As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal wFlags As Integer) As Integer
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, ByVal lParam As String) As Integer
' Declare Function MessageBoxTimeout Lib "user32" Alias "MessageBoxTimeoutA" (ByVal hwnd As Integer, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As VbMsgBoxStyle, ByVal wlange As Integer, ByVal dwTimeout As Integer) As Integer
Public lHwndLight As Integer
Public lRgn As Integer, lHwndExcel7 As Integer, lRgnintersect As Integer
Public oXl7Rect As RECT, oFstPnRect As RECT, oRect As RECT
Function pt2px(ByVal x As Single)
pt2px = xlapp.WorksheetFunction.Round(xlapp.WorksheetFunction.Round(x * PPI / 72, 0) * 100 / 100, 0)
End Function
'//过程//
Sub ReloadMarkerlights()
Dim f As Form1 = New Form1
f.Show()
f.Hide() '不让看到最小化的窗体
f.Timer1.Enabled = True '开始时钟
ChangeWindowStyle()
LightShine() ' ReloadMarkerlights
End Sub
Sub ReloadMarkerlights2()
Dim f As Form1 = New Form1
f.Show()
f.Timer1.Enabled = True '开始时钟
ChangeWindowStyle()
LightShine() ' ReloadMarkerlights
f.Hide() '不让看到最小化的窗体
End Sub
Function ActiveWindowProtected() As Boolean
If xlapp.Version >= "14" Then
If xlapp.ProtectedViewWindows.Count > 0 Then
ActiveWindowProtected = xlapp.ActiveWindow.Caption = xlapp.ActiveProtectedViewWindow.Caption
End If
End If
End Function
Sub GetPPI() '获取分辨率
Dim hdc As Integer
hdc = GetDC(0&)
PPI = GetDeviceCaps(hdc, LOGPIXELSX)
ReleaseDC(0&, hdc)
End Sub
Sub ChangeWindowStyle() '修改窗体样式：无边框透明、鼠标可穿透
Dim lStyle As Integer, ExStyle As Integer
If IsWindow(lHwndLight) Then
lStyle = GetWindowlongPtr(lHwndLight, GWL_STYLE) '获取其原有的风格(理解为“基本风格”，包含：对边框标题滚动条的设置）
lStyle = lStyle And Not WS_BORDER And Not WS_CAPTION Or WS_CHILD '预设新样式属性值：无边框无标题'Or WS_CHILD
SetWindowlongPtr(lHwndLight, GWL_STYLE, lStyle) '按新样式属性值设置窗口属性
End If
ExStyle = GetWindowlongPtr(lHwndLight, GWL_EXSTYLE) '获取其原有的扩展风格
ExStyle = ExStyle Or WS_EX_LAYERED Or WS_EX_TRANSPARENT Or WS_EX_TOOLWINDOW '添加扩展风格：1（图形）层叠的2(对鼠标）透明的 3工具窗口式的（插件一般要设为工具窗口以使其图标不在任务栏中显示）
SetWindowlongPtr(lHwndLight, GWL_EXSTYLE, ExStyle) '设置窗口的扩展风格
'SetwindowLong之后， 必须用SetwindowPos等才能使窗口显示出来。在使用SetWindowLong改变窗体样式以后，要紧临着使用SetWindowPos来设置窗体大小；
SetLayeredWindowAttributes(lHwndLight, 0, 25.5 * transparency, LWA_ALPHA)
'设置alpha通道的透明度（0至255之间为0时，完全透明，为255为完全不透明)
End Sub
Sub LightShine()
Dim ret As Integer
Dim LightRect As RECT
If PPI = 0 Then GetPPI()
getExcel7Rect()
'不能让用户误选择太多行或太多列,不超过10行5列
If xlapp.ActiveWindow.RangeSelection.Areas(1).Rows.Count > 10 Or xlapp.ActiveWindow.RangeSelection.Areas(1).Columns.Count > 10 Then
Try
ShowWindow(lHwndLight, SW_HIDE)
Catch ex As Exception
End Try
Exit Sub
Else
rngkj = xlapp.ActiveWindow.RangeSelection.Areas(1)
End If
''判断工作表中是否有图形或是页面视图模式
If xlapp.ActiveSheet.Shapes.Count > 0 Or xlapp.ActiveWindow.View = XlWindowView.xlPageLayoutView Then '如果有图形或是页面视图模式
GetLightRgn(rngkj) '当前选中的区域传给慢速3条线绘图过程
Else '如果没有有图形或不是页面视图模式,当前选中的区域传给快速1条线绘图过程
GetLightRgn2(rngkj) '当前选中的区域传给快速1条线绘图过程
End If
With oXl7Rect
MoveWindow(lHwndLight, .Left - 3, .Top - 3, .Right - .Left + 6, .Bottom - .Top + 6, True)
'// 修改聚光灯窗体的大小位置覆盖Excel7窗口。
GetWindowRect(lHwndLight, LightRect)
ret = OffsetRgn(lRgn, -LightRect.Left, -LightRect.Top)
ret = SetWindowRgn(lHwndLight, lRgn, True)
'//实现聚光灯的具体样式
DeleteObject(lRgn)
End With
'======================================
ret = SetWindowPos(lHwndLight, 0, 0, 0, 0, 0, SWP_NOACTIVATE Or SWP_SHOWWINDOW Or SWP_NOSIZE Or SWP_NOMOVE) '此句的效果等同于下一句ShowWindow命令的效果
'初始化绘图尺寸,为了移动窗口时跟着移动
rect_top = oXl7Rect.Top
rect_left = oXl7Rect.Left
rect_botton = oXl7Rect.Bottom
rect_right = oXl7Rect.Right
End Sub
Sub getExcel7Rect() '获取Excel7窗口的位置尺寸信息
'Dim lHwndXlMain As Integer
Dim lHwndXlDesk As Integer, lhwndHscrBar As Integer, lhwndVscrBar As Integer
Dim oHScrBarRect As RECT, oVScrBarRect As RECT
Dim oRngVsbl 'cel As Range,
Dim pn As Pane
lHwndXlDesk = FindWindowEx(xlapp.Hwnd, 0&, "XLDESK", vbNullString)
lHwndExcel7 = FindWindowEx(lHwndXlDesk, 0&, "EXCEL7", vbNullString)
'------------------------------WPS中使用此程序-------------------------------------------
'GetWindowRect(lHwndExcel7, oXl7Rect) '把excel7的尺寸放入oXLExcel7（较为通用的）
'------------------------------WPS中使用此程序-------------------------------------------
'------------------------------WPS中没有滚动条句柄,以下代码在WPS中不可用-------------------------------------------
lhwndHscrBar = FindWindowEx(lHwndExcel7, 0&, "NUIScrollbar", "水平") '水平滚动条的句柄
lhwndVscrBar = FindWindowEx(lHwndExcel7, 0&, "NUIScrollbar", "垂直") '垂直滚动条的句柄
With xlapp.ActiveWindow
If .Split Then
If .SplitRow Then
lhwndVscrBar = FindWindowEx(lHwndExcel7, lhwndVscrBar, "NUIScrollbar", "垂直") '垂直滚动条的句柄
End If
If .SplitColumn Then
lhwndHscrBar = FindWindowEx(lHwndExcel7, lhwndHscrBar, "NUIScrollbar", "水平") '垂直滚动条的句柄
End If
End If
GetWindowRect(lhwndHscrBar, oHScrBarRect) '竖直滚动条尺寸放入oHScrBarRect
GetWindowRect（lhwndVscrBar, oVScrBarRect） '垂直滚动条尺寸放入oVScrBarRect
If .DisplayHorizontalScrollBar Or .DisplayWorkbookTabs Then
oXl7Rect.Bottom = oVScrBarRect.Bottom
End If
If .DisplayVerticalScrollBar Then
oXl7Rect.Right = oHScrBarRect.Right - 2
End If
pn = .Panes(1)
oRngVsbl = pn.VisibleRange.Cells(1)
oXl7Rect.Left = pn.PointsToScreenPixelsX(0) + pt2px(oRngVsbl.Left)
oXl7Rect.Top = pn.PointsToScreenPixelsY(0) + pt2px(oRngVsbl.Top)
oFstPnRect.Left = oXl7Rect.Left
oFstPnRect.Top = oXl7Rect.Top
oRngVsbl = pn.VisibleRange
If .SplitRow Then
oFstPnRect.Bottom = oVScrBarRect.Top
If .FreezePanes Then
oRngVsbl = oRngVsbl.Cells(1).Offset(.SplitRow - 1)
oFstPnRect.Bottom = .PointsToScreenPixelsY(0) + pt2px(oRngVsbl.Top + oRngVsbl.Height)
End If
Else
oFstPnRect.Bottom = oVScrBarRect.Bottom
End If
If .SplitColumn Then
oFstPnRect.Right = oHScrBarRect.Left
If .FreezePanes Then
oRngVsbl = oRngVsbl.Cells(1).Offset(, .SplitColumn - 1)
oFstPnRect.Right = .PointsToScreenPixelsX(0) + pt2px(oRngVsbl.Left + oRngVsbl.Width)
End If
Else
oFstPnRect.Right = oHScrBarRect.Right
End If
End With
'------------------------------WPS中没有滚动条句柄,以下代码在WPS中不可用-------------------------------------------
If IsWindowVisible(lHwndXlDesk) = False Then
Try
ShowWindow(lHwndLight, SW_HIDE)
Exit Sub
Catch ex As Exception
End Try
End If
ppi_y = SystemInformation.PrimaryMonitorSize.Height * 0.0325 * (xlapp.ActiveWindow.Zoom / 100) + 25 '25为误差
ppi_x = SystemInformation.PrimaryMonitorSize.Width * 0.038 * (xlapp.ActiveWindow.Zoom / 100) + 25
ppi_gdt = SystemInformation.PrimaryMonitorSize.Width * 0.0147 + 25
ppi_d = SystemInformation.PrimaryMonitorSize.Height * 0.02864 + 25
End Sub
Sub GetLightRgn(ByVal Target As Range)
On Error Resume Next
Dim lHRgn As Integer, lVRgn As Integer
Dim oPnRect As RECT
Dim Wn As Window
Dim oRange As Range, oRng As Range
Dim pn As Pane
Dim i&, j&
Dim oRngVsbl As Range
Dim tmp As Object
'-------------------------绘图矩形初始化
blackrect1.Top = 0
blackrect1.Bottom = 0
blackrect1.Left = 0
blackrect1.Right = 0
blackrect2.Top = 0
blackrect2.Bottom = 0
blackrect2.Left = 0
blackrect2.Right = 0
blackrect3.Top = 0
blackrect3.Bottom = 0
blackrect3.Left = 0
blackrect3.Right = 0
blackrect4.Top = 0
blackrect4.Bottom = 0
blackrect4.Left = 0
blackrect4.Right = 0
'----------------------------------------
Wn = xlapp.ActiveWindow
iZoom = Wn.Zoom '视图比例赋值
pn = Wn.ActivePane
oRngVsbl = pn.VisibleRange.Cells(1)
Select Case UserOption
Case 1
oRange = Target.EntireRow
Case 2
oRange = Target.EntireColumn
Case 3
oRange = xlapp.Union(Target.EntireRow, Target.EntireRow) '活动单元格整行整列组成的十字区域
End Select
lRgn = CreateRectRgn(0, 0, 0, 0)
oRange = Target
For j = 1 To Wn.Panes.Count
pn = Wn.Panes(j)
With pn
oRngVsbl = pn.VisibleRange
oRng = xlapp.Intersect(oRngVsbl, xlapp.Selection)
On Error GoTo 0
If Not oRng Is Nothing Then
If xlapp.ActiveWindow.Split = True Then '如果是拆分窗口状态
'横条
If xlapp.ActiveWindow.Zoom <> 100 Then xlapp.ActiveWindow.Zoom = 100
oRect.Left = oXl7Rect.Left
oRect.Right = oXl7Rect.Right
oRect.Top = pn.PointsToScreenPixelsY(0) + pt2px(oRng.Rows(1).Top)
oRect.Bottom = pn.PointsToScreenPixelsY(0) + pt2px(oRng.Rows(oRng.Rows.Count).Top) + pt2px(oRng.Rows(oRng.Rows.Count).Height)
If oRect.Top < oXl7Rect.Top Then oRect.Top = oXl7Rect.Top
If oRect.Bottom > oXl7Rect.Bottom Then oRect.Bottom = oXl7Rect.Bottom
lHRgn = CreateRectRgnIndirect(oRect)
blackrect1.Top = oXl7Rect.Top '除去选中部分
blackrect1.Bottom = oRect.Top
blackrect2.Top = oRect.Bottom
blackrect2.Bottom = oXl7Rect.Bottom
blackrect3.Top = oRect.Top
blackrect3.Bottom = oRect.Bottom
blackrect4.Top = oRect.Top
blackrect4.Bottom = oRect.Bottom
'---------------------------------------
'竖条
oRect.Top = oXl7Rect.Top
oRect.Bottom = oXl7Rect.Bottom
oRect.Left = pn.PointsToScreenPixelsX(0) + pt2px(oRng.Cells(1).Left)
oRect.Right = pn.PointsToScreenPixelsX(0) + pt2px(oRng.Columns(oRng.Columns.Count).Left) + pt2px(oRng.Columns(oRng.Columns.Count).Width)
If oRect.Left < oXl7Rect.Left Then oRect.Left = oXl7Rect.Left
If oRect.Right > oXl7Rect.Right Then oRect.Right = oXl7Rect.Right
lVRgn = CreateRectRgnIndirect(oRect)
blackrect1.Left = oRect.Left '除去选中部分
blackrect1.Right = oRect.Right
blackrect2.Left = oRect.Left
blackrect2.Right = oRect.Right
blackrect3.Left = oXl7Rect.Left
blackrect3.Right = oRect.Left
blackrect4.Left = oRect.Right
blackrect4.Right = oXl7Rect.Right
Else '如果不是拆分窗口状态
Dim m_iSelectionRow As Long, m_iSelectionRowsCount As Long
Dim m_iSelectionColumn As Long, m_iSelectionColumnsCount As Long
m_iSelectionColumn = oRng.Column
m_iSelectionColumnsCount = oRng.Columns.Count
m_iSelectionRow = xlapp.Application.Selection.Cells(1).Row
m_iSelectionRowsCount = xlapp.Application.Selection.Rows.count
Dim fw As Long
Dim rng As Object, n As Long, k As Integer
Dim iLeft As Long, iRight As Long, x As Long, y As Long
If UserOption <> 2 Then
oRect.Left = oXl7Rect.Left
oRect.Right = oXl7Rect.Right
oRect.Top = oXl7Rect.Top
oRect.Bottom = oXl7Rect.Bottom
iLeft = oXl7Rect.Left
iRight = oXl7Rect.Right
x = (iLeft + iRight) / 2
On Error Resume Next
cs = 0 '查找次数初始为0
oRect.Top = oXl7Rect.Top
Do
oRect.Top = oRect.Top + 2
rng = (Wn.RangeFromPoint(x, oRect.Top))
If rng Is Nothing Then oRect.Top = oRect.Top + 2
n = rng.Row
If (m_iSelectionRow = n) Then
oRect.Bottom = oRect.Top
If n = pn.VisibleRange.Cells(1).Row Then
Dim k9, k10 As Integer
k10 = oRect.Top
Do
k10 = k10 + 1
rng = (Wn.RangeFromPoint(x, k10))
If (rng Is Nothing) Then Exit Do
If TypeName(rng) <> "Range" Then Exit Do
k9 = k9 + 1
If k9 > 1000 Then Exit Do
Loop While (rng.Row <= n)
oRect.Top = k10 - pt2px(xlapp.Application.Selection.Rows(1).Height)
Else
Dim ss, st As Long
Do
oRect.Top = oRect.Top - 1
ss = oRect.Top
rng = (Wn.RangeFromPoint(x, ss)) '原版ss是oRect.Top,改成这样是为了页面布局模式
If TypeName(rng) <> "Range" Then
oRect.Top = ss
Exit Do
End If
If (rng Is Nothing) Then Exit Do
Dim k1 As Integer '防止死循环，如果找了5000次都未找到提结束
k1 = k1 + 1
If k1 > 5000 Then Exit Do
Loop While (rng.Row >= n)
End If
Dim bb As Long
Do
oRect.Bottom = oRect.Bottom + 1
bb = oRect.Bottom
rng = (Wn.RangeFromPoint(x, bb))
If TypeName(rng) <> "Range" Then '循环到图片区域时
oRect.Bottom = oRect.Top + pt2px(xlapp.Selection.height)
Exit Do
End If
If (rng Is Nothing) Then Exit Do
Dim k2 As Integer '防止死循环，如果找了5000次都未找到提结束
k2 = k2 + 1
If k2 > 5000 Then Exit Do
Loop While (rng.Row <= m_iSelectionRow + m_iSelectionRowsCount - 1)
Exit Do '找到了就结束DO
End If
If oRect.Top > oXl7Rect.Bottom Then '中间从头找到尾一遍后
If cs = 0 Then
x = oXl7Rect.Left + ppi_x '跳到屏幕左边查找
cs = cs + 1
oRect.Top = oXl7Rect.Top
ElseIf cs = 1 Then
x = oXl7Rect.Right - ppi_gdt ''跳到屏幕右边再找一遍
oRect.Top = oXl7Rect.Top
End If
End If
fw = fw + 1
If fw > 10000 Then '防止死循环，如果找了10000次都未找到提结束
Exit Do
End If
Loop
0:
If oRect.Top < oXl7Rect.Top Then oRect.Top = oXl7Rect.Top
If oRect.Bottom > oXl7Rect.Bottom Then oRect.Bottom = oXl7Rect.Bottom
lHRgn = CreateRectRgnIndirect(oRect)
blackrect1.Top = oXl7Rect.Top '除去选中部分
blackrect1.Bottom = oRect.Top
blackrect2.Top = oRect.Bottom
blackrect2.Bottom = oXl7Rect.Bottom
blackrect3.Top = oRect.Top
blackrect3.Bottom = oRect.Bottom
blackrect4.Top = oRect.Top
blackrect4.Bottom = oRect.Bottom
End If
'--------------------------------------------------------------------------
'横向------------------------------------
Dim wd, clfw, n1 As Long
If UserOption <> 1 Then
oRect.Top = oXl7Rect.Top
oRect.Bottom = oXl7Rect.Bottom
oRect.Left = oXl7Rect.Left
oRect.Right = oXl7Rect.Right
iLeft = oXl7Rect.Top
iRight = oXl7Rect.Bottom
y = (iLeft + iRight) / 2
On Error Resume Next
cs = 0 '查找次数初始为0
oRect.Left = oXl7Rect.Left
Do
oRect.Left = oRect.Left + 2 '2个像点2个像点地查找
rng = (Wn.RangeFromPoint(oRect.Left, y))
If rng Is Nothing Then oRect.Left = oRect.Left + 2
n1 = rng.Column
If (m_iSelectionColumn = n1) Then
oRect.Right = oRect.Left
If n1 = pn.VisibleRange.Cells(1).Column Then
Dim cl9, cl10 As Integer
cl10 = oRect.Left
Do
cl10 = cl10 + 1
rng = (Wn.RangeFromPoint(cl10, y))
If (rng Is Nothing) Then Exit Do
If TypeName(rng) <> "Range" Then Exit Do
cl9 = cl9 + 1
If cl9 > 1000 Then Exit Do
Loop While (rng.Column <= n1)
oRect.Left = cl10 - pt2px(xlapp.Application.Selection.Columns(1).Width)
Else
Dim clss, clst As Long
Do
oRect.Left = oRect.Left - 1
clss = oRect.Left
rng = (Wn.RangeFromPoint(clss, y))
If TypeName(rng) <> "Range" Then
oRect.Left = clss
Exit Do
End If
If (rng Is Nothing) Then Exit Do
Dim clk1 As Integer '防止死循环，如果找了5000次都未找到提结束
clk1 = clk1 + 1
If clk1 > 5000 Then Exit Do
Loop While (rng.Column >= n1)
End If
Dim clbb As Long
Do
oRect.Right = oRect.Right + 1
clbb = oRect.Right
rng = (Wn.RangeFromPoint(clbb, y))
If TypeName(rng) <> "Range" Then '循环到图片区域时
oRect.Right = oRect.Left + pt2px(xlapp.Selection.Width)
Exit Do
End If
If (rng Is Nothing) Then Exit Do
Dim clk2 As Integer '防止死循环，如果找了5000次都未找到提结束
clk2 = clk2 + 1
If clk2 > 5000 Then Exit Do
Loop While (rng.Column <= m_iSelectionColumn + m_iSelectionColumnsCount - 1)
Exit Do '找到了就结束DO
End If
If oRect.Left > oXl7Rect.Right Then '中间从头找到尾一遍后
If cs = 0 Then
y = oXl7Rect.Top + ppi_y '跳到屏幕上边查找
cs = cs + 1
oRect.Left = oXl7Rect.Left
ElseIf cs = 1 Then
y = oXl7Rect.Bottom - ppi_d ''跳到屏幕下边再找一遍
oRect.Left = oXl7Rect.Left
End If
End If
clfw = clfw + 1
If clfw > 10000 Then '防止死循环，如果找了5000次都未找到提结束
Exit Do
End If
Loop
If oRect.Left < oXl7Rect.Left Then oRect.Left = oXl7Rect.Left
If oRect.Right > oXl7Rect.Right Then oRect.Right = oXl7Rect.Right
lVRgn = CreateRectRgnIndirect(oRect)
blackrect1.Left = oRect.Left '除去选中部分
blackrect1.Right = oRect.Right
blackrect2.Left = oRect.Left
blackrect2.Right = oRect.Right
blackrect3.Left = oXl7Rect.Left
blackrect3.Right = oRect.Left
blackrect4.Left = oRect.Right
blackrect4.Right = oXl7Rect.Right
End If
End If
End If
blahand1 = CreateRectRgnIndirect(blackrect1) '除去选中部分生成4个面域
blahand2 = CreateRectRgnIndirect(blackrect2)
blahand3 = CreateRectRgnIndirect(blackrect3)
blahand4 = CreateRectRgnIndirect(blackrect4)
CombineRgn(lRgn, lRgn, blahand1, RGN_OR)
DeleteObject(blahand1)
CombineRgn(lRgn, lRgn, blahand2, RGN_OR)
DeleteObject(blahand2)
CombineRgn(lRgn, lRgn, blahand3, RGN_OR)
DeleteObject(blahand3)
CombineRgn(lRgn, lRgn, blahand4, RGN_OR)
DeleteObject(blahand4)
'坐标参数归0
lft = 0
tp = 0
wd = 0
ht = 0
'CombineRgn(lRgn, lRgn, lHRgn, RGN_OR)
'DeleteObject(lHRgn)
'CombineRgn(lRgn, lRgn, lVRgn, RGN_OR)
'DeleteObject(lVRgn)
End With
Next
End Sub
Sub GetLightRgn2(ByVal Target As Range) '绘制灯光图 2,界面没有图形遮挡,中间1条线快速定位选中单元格法
On Error Resume Next
Dim lHRgn As Integer, lVRgn As Integer
Dim oPnRect As RECT
Dim Wn As Window
Dim oRange As Range, oRng As Range
Dim pn As Pane
Dim i&, j&
Dim oRngVsbl As Range
Dim tmp As Object
'-------------------------绘图矩形初始化
blackrect1.Top = 0
blackrect1.Bottom = 0
blackrect1.Left = 0
blackrect1.Right = 0
blackrect2.Top = 0
blackrect2.Bottom = 0
blackrect2.Left = 0
blackrect2.Right = 0
blackrect3.Top = 0
blackrect3.Bottom = 0
blackrect3.Left = 0
blackrect3.Right = 0
blackrect4.Top = 0
blackrect4.Bottom = 0
blackrect4.Left = 0
blackrect4.Right = 0
'----------------------------------------
Wn = xlapp.ActiveWindow
iZoom = Wn.Zoom '视图比例赋值
pn = Wn.ActivePane
oRngVsbl = pn.VisibleRange.Cells(1)
Select Case UserOption
Case 1
oRange = Target.EntireRow
Case 2
oRange = Target.EntireColumn
Case 3
oRange = xlapp.Union(Target.EntireRow, Target.EntireRow) '活动单元格整行整列组成的十字区域
End Select
lRgn = CreateRectRgn(0, 0, 0, 0)
oRange = Target
For j = 1 To Wn.Panes.Count
pn = Wn.Panes(j)
With pn
oRngVsbl = pn.VisibleRange
oRng = xlapp.Intersect(oRngVsbl, oRange)
Dim m_iSelectionRow As Long, m_iSelectionRowsCount As Long
Dim m_iSelectionColumn As Long, m_iSelectionColumnsCount As Long
If oRng Is Nothing Then
Exit Sub
End If
m_iSelectionColumn = oRng.Column
m_iSelectionColumnsCount = oRng.Columns.Count
m_iSelectionRow = xlapp.Application.Selection.Cells(1).Row
m_iSelectionRowsCount = xlapp.Application.Selection.Rows.count
Dim fw As Long
Dim rng As Object, n As Long, k As Integer
Dim iLeft As Long, iRight As Long, x As Long, y As Long
On Error Resume Next
If Not oRng Is Nothing Then
If xlapp.ActiveWindow.Split = True Then '如果是拆分窗口状态,缩放比例须为100
If xlapp.ActiveWindow.Zoom <> 100 Then xlapp.ActiveWindow.Zoom = 100
'横条
oRect.Left = oXl7Rect.Left
oRect.Right = oXl7Rect.Right
oRect.Top = pn.PointsToScreenPixelsY(0) + pt2px(oRng.Rows(1).Top)
oRect.Bottom = pn.PointsToScreenPixelsY(0) + pt2px(oRng.Rows(oRng.Rows.Count).Top) + pt2px(oRng.Rows(oRng.Rows.Count).Height)
If oRect.Top < oXl7Rect.Top Then oRect.Top = oXl7Rect.Top
If oRect.Bottom > oXl7Rect.Bottom Then oRect.Bottom = oXl7Rect.Bottom
lHRgn = CreateRectRgnIndirect(oRect)
blackrect1.Top = oXl7Rect.Top '除去选中部分
blackrect1.Bottom = oRect.Top
blackrect2.Top = oRect.Bottom
blackrect2.Bottom = oXl7Rect.Bottom
blackrect3.Top = oRect.Top
blackrect3.Bottom = oRect.Bottom
blackrect4.Top = oRect.Top
blackrect4.Bottom = oRect.Bottom
'----------------------------------------------------
'竖条
oRect.Top = oXl7Rect.Top
oRect.Bottom = oXl7Rect.Bottom
oRect.Left = pn.PointsToScreenPixelsX(0) + pt2px(oRng.Cells(1).Left)
oRect.Right = pn.PointsToScreenPixelsX(0) + pt2px(oRng.Columns(oRng.Columns.Count).Left) + pt2px(oRng.Columns(oRng.Columns.Count).Width)
If oRect.Left < oXl7Rect.Left Then oRect.Left = oXl7Rect.Left
If oRect.Right > oXl7Rect.Right Then oRect.Right = oXl7Rect.Right
lVRgn = CreateRectRgnIndirect(oRect)
blackrect1.Left = oRect.Left '除去选中部分
blackrect1.Right = oRect.Right
blackrect2.Left = oRect.Left
blackrect2.Right = oRect.Right
blackrect3.Left = oXl7Rect.Left
blackrect3.Right = oRect.Left
blackrect4.Left = oRect.Right
blackrect4.Right = oXl7Rect.Right
Else '如果不是拆分窗口状态
If UserOption <> 4 Then
'Debug.WriteLine("非2")
oRect.Left = oXl7Rect.Left 'oRect为绘图矩形,oXl7Rect为工作区矩形
oRect.Right = oXl7Rect.Right
oRect.Top = oXl7Rect.Top
oRect.Bottom = oXl7Rect.Bottom
iLeft = oRect.Top '纵向二分法搜索开始
iRight = oRect.Bottom
x = (oRect.Left + oRect.Right) / 2
On Error Resume Next
'------------------------------------------------
Do
oRect.Top = (iLeft + iRight) / 2
rng = (xlapp.ActiveWindow.RangeFromPoint(x, oRect.Top))
If (rng Is Nothing Or iLeft = iRight) Then Exit Sub
n = rng.Row
If (m_iSelectionRow < n) Then
iRight = iRight - 5 '- 5
'iRight = oRect.Top '- 10
ElseIf (m_iSelectionRow > n) Then
iLeft = iLeft + 5 '+ 5
'iLeft = oRect.Top '+ 10
ElseIf (m_iSelectionRow = n) Then
oRect.Bottom = oRect.Top
'--------------------------------------------------------
If n = pn.VisibleRange.Cells(1).Row Then '第1行的计算
Dim k9, k10 As Integer
k10 = oRect.Top
Do
k10 = k10 + 1
rng = (Wn.RangeFromPoint(x, k10))
If (rng Is Nothing) Then Exit Do
k9 = k9 + 1
If k9 > 1000 Then Exit Do
Loop While (rng.Row <= n)
oRect.Top = k10 - pt2px(xlapp.Application.Selection.Rows(1).Height)
Else
Do
oRect.Top = oRect.Top - 1
rng = (xlapp.ActiveWindow.RangeFromPoint(x, oRect.Top))
If (rng Is Nothing) Then Exit Do
Loop While (rng.Row >= m_iSelectionRow)
1:
oRect.Top = oRect.Top
End If
'-----------------------------------------------------
Dim cr = pn.VisibleRange.Cells.Count
If n = pn.VisibleRange.Cells(cr).Row Then '最后一行的计算
oRect.Bottom = oRect.Top + pt2px(xlapp.Application.Selection.Height)
Exit Do
Else
Do
oRect.Bottom = oRect.Bottom + 1
rng = (xlapp.ActiveWindow.RangeFromPoint(x, oRect.Bottom))
If (rng Is Nothing) Then Exit Sub
Loop While (rng.Row <= m_iSelectionRow + m_iSelectionRowsCount - 1)
Exit Do
End If
End If
Loop
If oRect.Top < oXl7Rect.Top Then oRect.Top = oXl7Rect.Top
If oRect.Bottom > oXl7Rect.Bottom Then oRect.Bottom = oXl7Rect.Bottom
lHRgn = CreateRectRgnIndirect(oRect)
'1,2,3,4,对应上下左右
blackrect1.Top = oXl7Rect.Top '除去选中部分
blackrect1.Bottom = oRect.Top
blackrect2.Top = oRect.Bottom
blackrect2.Bottom = oXl7Rect.Bottom
blackrect3.Top = oRect.Top
blackrect3.Bottom = oRect.Bottom
blackrect4.Top = oRect.Top
blackrect4.Bottom = oRect.Bottom
End If
'----------------------------------横向
Dim wd As Long
If UserOption <> 4 Then
'Debug.WriteLine("非1")
oRect.Top = oXl7Rect.Top
oRect.Bottom = oXl7Rect.Bottom
oRect.Left = oXl7Rect.Left
oRect.Right = oXl7Rect.Right
'横向二分法搜索
iLeft = oRect.Left
iRight = oRect.Right
y = (oRect.Top + oRect.Bottom) / 2
On Error Resume Next
Do
oRect.Left = (iLeft + iRight) / 2
rng = (xlapp.ActiveWindow.RangeFromPoint(oRect.Left, y))
If (rng Is Nothing Or iLeft = iRight) Then Exit Sub
n = rng.Column
If (m_iSelectionColumn < n) Then
iRight = iRight - 5 '- 5
ElseIf (m_iSelectionColumn > n) Then
iLeft = iLeft + 5 '+ 5
ElseIf (m_iSelectionColumn = n) Then
oRect.Right = oRect.Left
If n = xlapp.ActiveWindow.ActivePane.VisibleRange.Cells(1).Column Then '第一列处理
Dim lk1, lk2 As Integer
lk1 = oRect.Left
Do
lk1 = lk1 + 1
rng = (xlapp.ActiveWindow.RangeFromPoint(lk1, y))
If TypeName(rng) <> "Range" Then Exit Do
If (rng Is Nothing) Then Exit Do
lk2 = lk2 + 1
If lk2 > 1000 Then Exit Do
Loop While (rng.Column <= n)
oRect.Left = lk2 - (pt2px(xlapp.Application.Selection.Columns(1).Width) - 50)
Else '非第一列
Do
oRect.Left = oRect.Left - 1
rng = (xlapp.ActiveWindow.RangeFromPoint(oRect.Left, y))
If (rng Is Nothing) Then Exit Sub
Loop While (rng.Column >= m_iSelectionColumn)
End If
Dim cr1 = pn.VisibleRange.Cells.Count
If n = pn.VisibleRange.Cells(cr1).Column Then '最后一列的处理
oRect.Right = oRect.Left + pt2px(xlapp.Application.Selection.Width)
Exit Do
Else '非最后一列
Do
oRect.Right = oRect.Right + 1
rng = (xlapp.ActiveWindow.RangeFromPoint(oRect.Right, y))
If TypeName(rng) <> "Range" Then Exit Do
If (rng Is Nothing) Then Exit Do
Loop While (rng.Column <= m_iSelectionColumn + m_iSelectionColumnsCount - 1)
End If
Exit Do
End If
Loop
If oRect.Left < oXl7Rect.Left Then oRect.Left = oXl7Rect.Left
If oRect.Right > oXl7Rect.Right Then oRect.Right = oXl7Rect.Right
lVRgn = CreateRectRgnIndirect(oRect)
blackrect1.Left = oRect.Left '除去选中部分
blackrect1.Right = oRect.Right
blackrect2.Left = oRect.Left
blackrect2.Right = oRect.Right
blackrect3.Left = oXl7Rect.Left
blackrect3.Right = oRect.Left
blackrect4.Left = oRect.Right
blackrect4.Right = oXl7Rect.Right
End If
End If
End If
If UserOption <> 1 Then
blahand1 = CreateRectRgnIndirect(blackrect1) '除去选中部分生成4个面域
blahand2 = CreateRectRgnIndirect(blackrect2)
End If
If UserOption <> 2 Then
blahand3 = CreateRectRgnIndirect(blackrect3)
blahand4 = CreateRectRgnIndirect(blackrect4)
End If
CombineRgn(lRgn, lRgn, blahand1, RGN_OR)
DeleteObject(blahand1)
CombineRgn(lRgn, lRgn, blahand2, RGN_OR)
DeleteObject(blahand2)
CombineRgn(lRgn, lRgn, blahand3, RGN_OR)
DeleteObject(blahand3)
CombineRgn(lRgn, lRgn, blahand4, RGN_OR)
DeleteObject(blahand4)
'坐标参数归0
lft = 0
tp = 0
wd = 0
ht = 0
'CombineRgn(lRgn, lRgn, lHRgn, RGN_OR)
'DeleteObject(lHRgn)
'CombineRgn(lRgn, lRgn, lVRgn, RGN_OR)
'DeleteObject(lVRgn)
End With
Next
End Sub
End Module
thisaddin
Private Sub Application_WindowResize(Wb As Workbook, Wn As Window) Handles Application.WindowResize
If spotlight = True Then
LightShine()
End If
End Sub
Const SW_HIDE = 0
Private Sub Application_WindowDeactivate(Wb As Workbook, Wn As Window) Handles Application.WindowDeactivate
'MsgBox("66666")
If IsWindow(lHwndLight) Then
'f.hide()
Try
ShowWindow(lHwndLight, SW_HIDE)
Catch ex As Exception
End Try
End If
End Sub
Private Sub Application_SheetSelectionChange(Sh As Object, Target As Range) Handles Application.SheetSelectionChange
'Dim sheet As Excel.Worksheet = Globals.ThisAddIn.Application.ActiveSheet
'sheet.Cells.FormatConditions.Add(Type:=XlFormatConditionType.xlExpression, Formula1:="=OR(CELL(""row"")=ROW(), CELL(""col"")=COLUMN())")
'For Each fmt As FormatCondition In sheet.Cells.FormatConditions
' fmt.Interior.Color = Color.FromArgb(255, 255, 0)
'Next
If spotlight = True Then
LightShine()
End If
End SubRibbon按钮调用
Public Sub Spotlight_click(ctrl As Office.IRibbonControl, pressed As Boolean)
If pressed = True Then
WriteJson("spotlight", pressed)
Globals.ThisAddIn.spotlight = True
If CheckZoom(xlapp.ActiveWindow) Then Exit Sub '比例不是100%，直接退出
If ActiveWindowProtected() Then Exit Sub
Call ReloadMarkerlights()
Else
WriteJson("spotlight", pressed)
Globals.ThisAddIn.spotlight = False
spotform.Timer1.Enabled = False
Try
ShowWindow(lHwndLight, SW_HIDE)
Catch ex As Exception
End Try
End If
End SubRibbon按钮设置xml
<group id="group3" label="视图" visible="true">
<splitButton id="splitButtonB" size="large" visible="true">
<toggleButton id="splitbuttonB1" label="聚光灯" image="灯泡" enabled="true" getPressed="Spotlight_getPressed" onAction="Spotlight_click" supertip="设置"/>
<menu id="menuB1" itemSize="normal" visible="true" enabled="true" keytip="D">
<menu label="形状" id="menuBA1" image="形状1" >
<button id="menuBA1-1" label="十字" onAction="Spotlight_1" image="形状1" />
<button id="menuBA1-2" label="一行" onAction="Spotlight_2" image="形状2" />
<button id="menuBA1-3" label="竖列" onAction="Spotlight_3" image="形状3" />
</menu>
<menu label="颜色" id="menuBB1" image="色彩" >
<button id="menuBB1-1" label="Light" onAction="Spotlight_C1" image="颜色1" />
<button id="menuBB1-2" label="CadetBlue" onAction="Spotlight_C2" image="颜色2" />
<button id="menuBB1-3" label="Yellow" onAction="Spotlight_C3" image="颜色3" />
</menu>
<menu label="透明度" id="menuBC1" image="透明度" >
<button id="menuBC1-1" label="40%" onAction="Spotlight_T1" image="透明度" />
<button id="menuBC1-2" label="30%" onAction="Spotlight_T2" image="透明度" />
<button id="menuBC1-3" label="20%" onAction="Spotlight_T3" image="透明度" />
</menu>
</menu>
</splitButton>
</group>最终效果:
这样就实现了完美聚光灯的功能,每个工作簿打开即用.
如果觉得实现起来太麻烦,实例在下面:
标签：oXl7Rect,VBA,Bottom,Top,vb,oRect,Integer,net,Left From： https://blog.csdn.net/nianfen/article/details/143811561