|
|
- 模块：Ribbon_载入
- Public rib As IRibbonUI '声明一个公共变量，IRibbonUI代表一个Ribbon类的对象实例
- Sub RibbonUI_OnLoad(ribbon As IRibbonUI) '此过程将在启动工作簿时执行，作用是将工能区对象Ribbon赋予变量rib，即载入缓存中，供其它代码随时调用
- '将IRibbonUI类赋予变量rib，从而载入缓存供以后调用
- Set rib = ribbon
- 'rib.ActivateTab "鼠标移动而着色" '方法1：打开文件时激活指定的选项卡
- Application.SendKeys "%Y{RETURN}" '方法2：打开文件时激活指定的选项卡
- Application.SendKeys "{NUMLOCK}"
- End Sub
- 模块：鼠标移动而着色
- 'VBA中主要需着色和关闭着色两个过程,为了方便,以及避免破坏Execl自带的复制与剪切功能,需要更多Sub和Function过程
- '声明关于鼠标坐标相关的变量
- '复制对象"的自定义函数
- '以下代码主要用于从剪贴板中获取复制或剪切的单元格地址,使用了较多的API函数
- '由于剪贴板取出的地址是R1C1样式,所以利用自定义函数RCTransition将它转换成A1样式,否则会出错
- Private Declare Function GlobalLock Lib "kernel32" (ByVal ClipContent As Long) As Long
- Private Declare Function GlobalUnlock Lib "kernel32" (ByVal ClipContent As Long) As Long
- Private Declare Function GlobalSize Lib "kernel32" (ByVal ClipContent As Long) As Long
- Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
- Private Declare Function CloseClipboard Lib "user32" () As Long
- Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
- Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
- '声明关于鼠标坐目标相关变量
- Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
- Type POINTAPI
- x As Long
- Y As Long
- End Type
- Dim 坐标 As POINTAPI
- '声明颜色选择器的相关变量
- Private Type ChooseColor
- lStructSize As Long
- hwndOwner As Long
- hInstance As Long
- rgbResult As Long
- lpCustColors As String
- Flags As Long
- lCustData As Long
- lpfnHook As Long
- lpTemplateName As String
- End Type
- ''API函数ChooseColor调用Windows系统的颜色对话框
- Private Declare Function ChooseColorAPI Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As ChooseColor) As Long
- Dim CustomColors() As Byte
- '声明其它变量
- Dim 原单元格 As Range, 关闭 As Boolean, 当前单元格 As Range, 着色方式 As String
- '主体程序：对鼠标移过的行或列进行着色
- Sub MouseColor(Str As String)
- '获取颜色
- Dim ChColor As ChooseColor, CustColor(16) As Long, ReturnCol As Long, rng As Range, CutOrCopy As Integer
- ChColor.lStructSize = Len(ChColor)
- ChColor.hInstance = 1
- ChColor.lpCustColors = StrConv(CustomColors, vbUnicode)
- ChColor.Flags = 0
- ReturnCol = ChooseColorAPI(ChColor)
- If ReturnCol <> 0 Then col = ChColor.rgbResult Else Exit Sub
- 关闭 = False '将False赋值给变量"关闭"
- Do '循环执行过程
- If 关闭 = True Then Exit Do '如果变量"关闭"为True就停止循环
- GetCursorPos 坐标 '获取鼠目标坐标体
- On Error Resume Next '遇到错误时继续执行下面的语句
- Set 当前单元格 = ActiveWindow.RangeFromPoint(坐标.x, 坐标.Y) '根据鼠目标坐标得到鼠标指针下的单元格的地址
- If 当前单元格 Is Nothing Then '如果鼠标指针下不是单元格
- [ColorCells].FormatConditions.Delete '删除名称为ColorCells的区域的条件格式
- ActiveWorkbook.Names("ColorCells").Delete '删除名称ColorCells
- Else
- If 当前单元格.Address <> 原单元格.Address Then '如果当前鼠标指针下的单元格与记录的上一个地址不等时
- [ColorCells].FormatConditions.Delete '删除条件格式
- If Str = "A" Then '如果菜单按钮是第一个(行着色)
- '将当前行中可见区域命名为"ColorCells"。需要注意一点：Range 部分是为了得到可见区域,而不需要把整行都添加颜色,那样会浪费内存
- Intersect(当前单元格.EntireRow, Range(当前单元格.EntireRow.Cells(1), ActiveWindow.VisibleRange)).name = "ColorCells"
- ElseIf Str = "B" Then '如果菜单按钮是第一个(列着色)
- Intersect(当前单元格.EntireColumn, Range(当前单元格.EntireColumn.Cells(1), ActiveWindow.VisibleRange)).name = "ColorCells"
- Else '否则将当前行或当前列的可见区域命名为"ColorCells"
- Intersect(Union(当前单元格.EntireColumn, 当前单元格.EntireRow), Range([A1], ActiveWindow.VisibleRange)).name = "ColorCells"
- End If
- '如果剪切模式为True,那么调用过程"复制对象",且将复制的对象赋值给变量rng
- If Application.CutCopyMode Then Set rng = 复制对象 Else Set rng = Nothing
- CutOrCopy = Application.CutCopyMode '记录当前的剪切模式
- With [ColorCells].FormatConditions '引用名称"ColorCells"所代表的区域的条件格式
- .Delete '删除条件格式
- .Add xlExpression, , "TRUE" '添加条件格式
- .Item(1).Interior.Color = col '设置条件格式的颜色
- End With
- If CutOrCopy = xlCopy Then rng.Copy 'If当前的剪切模式为复制状态,则复制rng区域
- If CutOrCopy = xlCut Then rng.Cut 'If当前的剪切模式为剪切状态,则剪切rng区域
- End If
- Set 原单元格 = 当前单元格 '将变量"当前单元格"赋值给变量"原单元格"
- End If
- DoEvents '转交控制权,此处的目的是释放内存,否则一旦执行后,就再也不能执行其它任何工作了
- Loop
- End Sub
- Public Function 复制对象() As Range '---"复制对象"的自定义函数
- Dim Myarr() As Byte, ClipContent, nClipsize, lpData As Long, sSource, sTemp() As String
- Dim 工作簿, 工作表, 单元格 As String
- On Error GoTo Err '遇到错误时,跳转到Err：标签处
- OpenClipboard 0& '打开剪贴板
- ClipContent = GetClipboardData(49154) '获取剪贴板的数据,49154在此处代表剪贴板中有Range对象
- If CBool(ClipContent) Then '如果有数据
- '获取数据
- nClipsize = GlobalSize(ClipContent)
- lpData = GlobalLock(ClipContent) '锁定内存中指定的内存块,并返回一个地址值
- If lpData <> 0 Then
- ReDim Myarr(0 To nClipsize - 1) As Byte
- CopyMemory Myarr(0), ByVal lpData, nClipsize '将数据复制到数组变量中
- sSource = StrConv(Myarr, vbUnicode) '得到一个包括工作簿路径的单元格对象地址(R1C1格式)
- sTemp = Split(sSource, Chr(0)) '从sSource中获取工作簿、工作表、单元格地址部分字符串,删除其它字符
- '获取工作薄名称
- If InStr(sTemp(1), "") Then 工作簿 = Mid(sTemp(1), InStrRev(sTemp(1), "") + 1) Else 工作薄 = sTemp(1)
- '获取工作表名称
- 工作表 = Left(sTemp(2), InStr(sTemp(2), "!") - 1)
- '获取单元格地址
- 单元格 = RCTransition(Mid(sTemp(2), InStr(sTemp(2), "!") + 1))
- Set 复制对象 = Workbooks(工作簿).Sheets(工作表).Range(单元格) '引用转换后的详细地址(该地址由剪贴板获取)
- End If
- GlobalUnlock ClipContent '解除锁定的内存块
- Else
- Set 复制对象 = Nothing
- End If
- CloseClipboard '关闭剪贴板
- Err:
- End Function
- '将A1C1形式的引用转换成A1形式的引用,例如：将"R2C1"转换成"$A$2"；"R2C2:R10C3"转换成"$B$2:$C$10"
- Function RCTransition(ByVal rangeAdd As String) As String 'A1C1的引用转换成A1引用
- If InStr(rangeAdd, ":") Then '如果地址中有":"字符时
- '则将冒号":"前后的字符串分两次转换再串联起来
- RCTransition = RCTransition(Split(rangeAdd, ":")(0)) & ":" & RCTransition(Split(rangeAdd, ":")(1))
- Else '否则将R1C1模式的单元格地址转换成A1引用样式
- RCTransition = Application.ConvertFormula(rangeAdd, xlR1C1, xlA1)
- End If
- End Function
- Sub Mouse(control As IRibbonControl) '与三个菜单相关联的Sub过程
- 着色方式 = control.Id '获取当前单击的按钮的ID
- Call MouseColor(着色方式) '调用同一个过程,但是由于ID不同,所以会执行不同的代码
- End Sub
- Sub CloseCol(control As IRibbonControl, pressed As Boolean) '单击第四个菜单时执行的过程,用于关闭或重启着色
- '如果按钮呈按下状态,则将变量赋值为True,否则再次调用过程MouseColor
- On Error Resume Next '遇到错误时继续执行下面的语句
- If pressed Then 关闭 = True Else If Len(着色方式) > 0 Then Call MouseColor(着色方式)
- [ColorCells].FormatConditions.Delete '删除名称为ColorCells的区域的条件格式
- ActiveWorkbook.Names("ColorCells").Delete '删除名称ColorCells
- End Sub
- '以上代码有五个重点：
- '1、获取鼠标指针的坐标
- '由于需要鼠标指针移到哪里,哪一行或哪一列就要突出显示,所以需要用代码获取鼠目标屏幕位置.VBA自身没有任何方法获取此坐标值,
- '所以调用API中的GetCursorPos函数来取得鼠标指针的X和Y的坐标值,然后配合RangeFromPoint方法取得该坐标下的单元格地址。
- '2、创建颜色对话框
- '用VBA开发一个颜色对话框比较复杂,所以本例通过API函数ChooseColor调用Windows系统的颜色对话框,
- '提供给用户自定义颜色的选项,会更具人性化。
- '3、条件格式
- '突出显示一个区域,最方便的是采用颜色格式,根据按钮的ID决定对行还是对列突出显示,或是行列同时突出显示,
- '为了方便,将需要突出显示的区域命名为一个名称"ColorCells",后续只需要通过[ColorCells]调用该区域即可,
- '由于鼠标不停移动,所以南要随时更新亲名称和条件格式,采用Do Loop循环语句反复运行,直到条件"关闭"值为True时才停止。
- '在对任意单元格添加条件格式前,需要删除上一次的条件格式。
- '4、区域范围
- '由于条件格式的范围越大,占用内存越多,所以采用ActiveWindow.VisibleRange属性限制只对当前窗口中的可见区域生效,在屏幕以外的区域将自动略过.
- '虽然使用代码"Intersect(当前单元格.EntircColumn,ActiveWindow.VisibleRange)"也可以将范围限制在当前行的可见区域,
- '不过当用户使用冻结空格功能后,就会出现问题。对它做了进一步限制,防止出现BUG。
- '5、复制与剪切
- '当使用着色工具后,系统的复制和剪切功能将全部失效,为了杜绝此问题,需要配全"复制对象"的自定义函数应用
|
评分
-
1
查看全部评分
-
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2018-5-4 18:37
楼主
