ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH云课堂-专业的职场技能充电站 Excel转在线管理系统,怎么做看这里 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 高效办公必会的Office实战技巧 免费下载Excel行业应用视频
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
楼主: stanleypan

模仿XColor 功能的加载宏!

  [复制链接]

TA的精华主题

TA的得分主题

发表于 2005-8-24 02:12 | 显示全部楼层

因为我是设计好给别人用的,所以用dll不方便,最好是用vba代码.

麻烦帮我看看怎么改,多谢~~~

TA的精华主题

TA的得分主题

 楼主| 发表于 2005-8-24 11:49 | 显示全部楼层

全部注释掉,只留下:

'Row rc.Left = 0 + DefaultWindowFrameWidth rc.Right = rc.Left + ActiveWindow.UsableWidth * lngLogPixelsX / 72 rc.Top = mTop - MyTop rc.Bottom = mBottom - MyTop

Rectangle hdc, rc.Left, rc.Top, rc.Right, rc.Bottom

Call RestoreDC(hdc, -1) '-1时恢复以前的内容'恢复DC设备 ReleaseDC Hwnd, hdc '删除窗口设备句柄,释放资源 DeleteObject brush

TA的精华主题

TA的得分主题

发表于 2005-8-24 13:15 | 显示全部楼层

不好意思,我还是不明白版版所说的全部注释掉是指哪里注释掉.下面是起作用工作表的全部代码, 您到底是指具体哪里注释掉啊?不是说只保留粗体的部分吧?那前面怎么定义?

Option Explicit Dim c As clsXcolor Dim myRect As RECT Dim DesktopRect As RECT Dim rc As RECT Dim MyTop, MyLeft As Integer Dim T, L As Long Dim lnghDC As Long Dim lngLogPixelsX As Long Dim Hwnd, brush As Long

Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim hdc As Long '注意它的位置,它在Worksheet_SelectionChange这一Module里和外对应的不一样

Set c = New clsXcolor c.WindowStyle = vbGreenStyle ' vbXPStyle

lnghDC = GetDC(0) lngLogPixelsX = GetDeviceCaps(GetDC(0), LOGPIXELSX) '// note '获得鼠标所在的窗口句柄 'GetCursorPos CursorPos 'HWND = WindowFromPoint(CursorPos.x, CursorPos.Y) Dim HWND1 As Long, hWndDesk As Long, hWndWin As Long Dim HwdDesktop As Long HWND1 = FindWindow("XLMAIN", Application.Caption) hWndDesk = FindWindowEx(HWND1, 0&, "XLDESK", vbNullString) Hwnd = FindWindowEx(hWndDesk, 0&, "EXCEL7", vbNullString) 'Excel 主窗体

'hwnd = FindWindow("XLMAIN", Application.Caption) GetWindowRect Hwnd, myRect 'OffsetRect myRect, -myRect.Left, -myRect.Top MyLeft = myRect.Left MyTop = myRect.Top Debug.Print myRect.Left Debug.Print myRect.Right Debug.Print myRect.Top Debug.Print myRect.Bottom

HwdDesktop = GetDesktopWindow() GetWindowRect HwdDesktop, DesktopRect

Dim HorizonPixels, VerticalPixels As Single HorizonPixels = DesktopRect.Right - DesktopRect.Left VerticalPixels = DesktopRect.Bottom - DesktopRect.Top

If hdc = 0 Then hdc = GetWindowDC(Hwnd) '给出窗口的设备名 DC GetWindowRect Hwnd, rc '给出窗口矩形 'OffsetRect rc, -rc.Left, -rc.Top Debug.Print rc.Left Debug.Print rc.Right Debug.Print rc.Top Debug.Print rc.Bottom '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' On Error Resume Next Dim lngCurPos As POINTAPI Dim mTop As Long, mLeft As Long, mRight As Long, mBottom As Long Dim x As Long, y As Long, x1 As Long, y1 As Long, x2 As Long, y2 As Long

If ClientToScreen(Hwnd, lngCurPos) = 0 Then Exit Sub 'ScreenToClient的作用是把屏幕中的坐标转换为客户区的坐标(关于什么是客户区,请参考前面的文章)。 'hwnd是客户区对象的句柄,而lpPoint则是已经存放着屏幕坐标的POINTAPI类型,执行该函数后, 'lpPoint的内容将被转换为客户区坐标值? ' ClientToScreen HWND, CursorPos 'ClientToScreen HWND, Point 'CursorPos ClientToScreen Hwnd, lngCurPos

GetCursorPos lngCurPos For y = lngCurPos.y To 0 Step -1 If ActiveWindow.RangeFromPoint(lngCurPos.x, y).Address <> Target.Address Then mTop = y - 1 Exit For End If Next y

For y1 = lngCurPos.y To VerticalPixels If ActiveWindow.RangeFromPoint(lngCurPos.x, y1).Address <> Target.Address Then mBottom = y1 - 1 Exit For End If Next y1

For x = lngCurPos.x To 0 Step -1 If ActiveWindow.RangeFromPoint(x, lngCurPos.y).Address <> Target.Address Then mLeft = x - 1 Exit For End If Next x

For x1 = lngCurPos.x To HorizonPixels If ActiveWindow.RangeFromPoint(x1, lngCurPos.y).Address <> Target.Address Then mRight = x1 - 1 Exit For End If Next x1 Debug.Print "Top:is:" & mTop & ";" & "Left:is:" & mLeft & ";" & _ "Right:is:" & mRight & ";" & "Bottom: is:" & mBottom & "."

If Target.Areas.Count > 1 Then Exit Sub End If Dim I As Long

I = InStr(1, Target.Address, ":") If I > 0 Then Exit Sub End If 'Column rc.Left = mLeft - MyLeft + 1 rc.Right = rc.Left + Target.Width * ActiveWindow.Zoom / 100 * lngLogPixelsX / 72 rc.Top = DefaultWindowFrameHeight rc.Bottom = rc.Top + ActiveWindow.UsableHeight * lngLogPixelsX / 72

' 'Cells ' rc.Left = mLeft - MyLeft ' rc.Right = rc.Left + Target.Width * ActiveWindow.Zoom / 100 * lngLogPixelsX / 72 ' rc.Top = mTop - MyTop ' rc.Bottom = mBottom - MyTop

'Row ' rc.Left = 0 + DefaultWindowFrameWidth ' rc.Right = rc.Left + ActiveWindow.UsableWidth * lngLogPixelsX / 72 ' rc.Top = mTop - MyTop ' rc.Bottom = mBottom - MyTop

Debug.Print rc.Right Debug.Print rc.Left Debug.Print rc.Top Debug.Print rc.Bottom 'UpdateWindow HWND

' OleTranslateColor Colors.crSelBack, 0&, Colors.crSelBack Application.ScreenUpdating = True

brush = CreateSolidBrush(Colors.crSelBack) '创建蓝色画刷 (&HFF0000) ' Dim hPen As Long ' '用指定的样式、宽度和颜色创建一个画笔 -> PS_SOLID 代表直线 'hPen = CreatePen(PS_SOLID, 1&, Colors.crSelBack)'(&HFF0000) '创建蓝色画笔 ' Call SelectObject(hdc, hPen) '指定画笔'将画笔选入设备场景 Call SelectObject(hdc, brush) 'SetBkMode hdc, TRANSPARENT

SetROP2 hdc, 10 '10 '9 ' R2_NOT '设置DC的颜色,备以后移去时使用 '建立画笔14 '设置xor作图模式

Call SaveDC(hdc) '保存画笔和刷子 ' Call SelectObject(hdc, hPen) '设置新笔 Call SelectObject(hdc, brush) '设备空刷子

'DrawFrame hdc, rc, Colors.crSelBorder ' crBorder Rectangle hdc, rc.Left, rc.Top, rc.Right, rc.Bottom 'UpdateWindow HWND

'Row rc.Left = 0 + DefaultWindowFrameWidth rc.Right = rc.Left + ActiveWindow.UsableWidth * lngLogPixelsX / 72 rc.Top = mTop - MyTop rc.Bottom = mBottom - MyTop

Rectangle hdc, rc.Left, rc.Top, rc.Right, rc.Bottom

Call RestoreDC(hdc, -1) '-1时恢复以前的内容'恢复DC设备 ReleaseDC Hwnd, hdc '删除窗口设备句柄,释放资源 DeleteObject brush 'DeleteObject ll_Pen

End Sub

TA的精华主题

TA的得分主题

发表于 2005-8-24 13:20 | 显示全部楼层

我就把

'Column 'rc.Left = mLeft - MyLeft + 1 'rc.Right = rc.Left + Target.Width * ActiveWindow.Zoom / 100 * lngLogPixelsX / 72 ' rc.Top = DefaultWindowFrameHeight ' rc.Bottom = rc.Top + ActiveWindow.UsableHeight * lngLogPixelsX / 72

注释掉,结果成这样:

模仿XColor 功能的加载宏!

模仿XColor 功能的加载宏!

TA的精华主题

TA的得分主题

发表于 2005-8-24 13:30 | 显示全部楼层

我自己乱改了下,把

'Column rc.Left = mLeft - MyLeft + 888 rc.Right = rc.Left + Target.Width * ActiveWindow.Zoom / 100 * lngLogPixelsX / 72 rc.Top = DefaultWindowFrameHeight rc.Bottom = rc.Top + ActiveWindow.UsableHeight * lngLogPixelsX / 72

里面的第一行 Myleft+1,我把1改成个很大的数,比如888,好像竖条就消失了.就是不懂这样改对程序有什么影响?

版版能不能麻烦把改好的程序代码贴上来?只要行,不用列的

多谢~~~~

TA的精华主题

TA的得分主题

 楼主| 发表于 2005-8-24 16:02 | 显示全部楼层

Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim hdc As Long '注意它的位置,它在Worksheet_SelectionChange这一Module里和外对应的不一样

Set c = New clsXcolor c.WindowStyle = vbGreenStyle ' vbXPStyle

lnghDC = GetDC(0) lngLogPixelsX = GetDeviceCaps(GetDC(0), LOGPIXELSX) '// note '获得鼠标所在的窗口句柄 'GetCursorPos CursorPos 'HWND = WindowFromPoint(CursorPos.x, CursorPos.Y) Dim HWND1 As Long, hWndDesk As Long, hWndWin As Long Dim HwdDesktop As Long HWND1 = FindWindow("XLMAIN", Application.Caption) hWndDesk = FindWindowEx(HWND1, 0&, "XLDESK", vbNullString) Hwnd = FindWindowEx(hWndDesk, 0&, "EXCEL7", vbNullString) 'Excel 主窗体

'hwnd = FindWindow("XLMAIN", Application.Caption) GetWindowRect Hwnd, myRect 'OffsetRect myRect, -myRect.Left, -myRect.Top MyLeft = myRect.Left MyTop = myRect.Top Debug.Print myRect.Left Debug.Print myRect.Right Debug.Print myRect.Top Debug.Print myRect.Bottom

HwdDesktop = GetDesktopWindow() GetWindowRect HwdDesktop, DesktopRect

Dim HorizonPixels, VerticalPixels As Single HorizonPixels = DesktopRect.Right - DesktopRect.Left VerticalPixels = DesktopRect.Bottom - DesktopRect.Top

If hdc = 0 Then hdc = GetWindowDC(Hwnd) '给出窗口的设备名 DC GetWindowRect Hwnd, rc '给出窗口矩形 'OffsetRect rc, -rc.Left, -rc.Top Debug.Print rc.Left Debug.Print rc.Right Debug.Print rc.Top Debug.Print rc.Bottom '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' On Error Resume Next Dim lngCurPos As POINTAPI Dim mTop As Long, mLeft As Long, mRight As Long, mBottom As Long Dim x As Long, y As Long, x1 As Long, y1 As Long, x2 As Long, y2 As Long

If ClientToScreen(Hwnd, lngCurPos) = 0 Then Exit Sub 'ScreenToClient的作用是把屏幕中的坐标转换为客户区的坐标(关于什么是客户区,请参考前面的文章)。 'hwnd是客户区对象的句柄,而lpPoint则是已经存放着屏幕坐标的POINTAPI类型,执行该函数后, 'lpPoint的内容将被转换为客户区坐标值? ' ClientToScreen HWND, CursorPos 'ClientToScreen HWND, Point 'CursorPos ClientToScreen Hwnd, lngCurPos

GetCursorPos lngCurPos For y = lngCurPos.y To 0 Step -1 If ActiveWindow.RangeFromPoint(lngCurPos.x, y).Address <> Target.Address Then mTop = y - 1 Exit For End If Next y

For y1 = lngCurPos.y To VerticalPixels If ActiveWindow.RangeFromPoint(lngCurPos.x, y1).Address <> Target.Address Then mBottom = y1 - 1 Exit For End If Next y1

For x = lngCurPos.x To 0 Step -1 If ActiveWindow.RangeFromPoint(x, lngCurPos.y).Address <> Target.Address Then mLeft = x - 1 Exit For End If Next x

For x1 = lngCurPos.x To HorizonPixels If ActiveWindow.RangeFromPoint(x1, lngCurPos.y).Address <> Target.Address Then mRight = x1 - 1 Exit For End If Next x1 Debug.Print "Top:is:" & mTop & ";" & "Left:is:" & mLeft & ";" & _ "Right:is:" & mRight & ";" & "Bottom: is:" & mBottom & "."

If Target.Areas.Count > 1 Then Exit Sub End If Dim I As Long

I = InStr(1, Target.Address, ":") If I > 0 Then Exit Sub End If ' 'Column ' rc.Left = mLeft - MyLeft + 1 ' rc.Right = rc.Left + Target.Width * ActiveWindow.Zoom / 100 * lngLogPixelsX / 72 ' rc.Top = DefaultWindowFrameHeight ' rc.Bottom = rc.Top + ActiveWindow.UsableHeight * lngLogPixelsX / 72 ' 'Cells ' rc.Left = mLeft - MyLeft ' rc.Right = rc.Left + Target.Width * ActiveWindow.Zoom / 100 * lngLogPixelsX / 72 ' rc.Top = mTop - MyTop ' rc.Bottom = mBottom - MyTop

'Row ' rc.Left = 0 + DefaultWindowFrameWidth ' rc.Right = rc.Left + ActiveWindow.UsableWidth * lngLogPixelsX / 72 ' rc.Top = mTop - MyTop ' rc.Bottom = mBottom - MyTop

Debug.Print rc.Right Debug.Print rc.Left Debug.Print rc.Top Debug.Print rc.Bottom 'UpdateWindow HWND

' OleTranslateColor Colors.crSelBack, 0&, Colors.crSelBack Application.ScreenUpdating = True

brush = CreateSolidBrush(Colors.crSelBack) '创建蓝色画刷 (&HFF0000) ' Dim hPen As Long ' '用指定的样式、宽度和颜色创建一个画笔 -> PS_SOLID 代表直线 'hPen = CreatePen(PS_SOLID, 1&, Colors.crSelBack)'(&HFF0000) '创建蓝色画笔 ' Call SelectObject(hdc, hPen) '指定画笔'将画笔选入设备场景 Call SelectObject(hdc, brush) 'SetBkMode hdc, TRANSPARENT

SetROP2 hdc, 10 '10 '9 ' R2_NOT '设置DC的颜色,备以后移去时使用 '建立画笔14 '设置xor作图模式

Call SaveDC(hdc) '保存画笔和刷子 ' Call SelectObject(hdc, hPen) '设置新笔 Call SelectObject(hdc, brush) '设备空刷子

'DrawFrame hdc, rc, Colors.crSelBorder ' crBorder 'Rectangle hdc, rc.Left, rc.Top, rc.Right, rc.Bottom 'UpdateWindow HWND

'Row rc.Left = 0 + DefaultWindowFrameWidth rc.Right = rc.Left + ActiveWindow.UsableWidth * lngLogPixelsX / 72 rc.Top = mTop - MyTop rc.Bottom = mBottom - MyTop

Rectangle hdc, rc.Left, rc.Top, rc.Right, rc.Bottom

Call RestoreDC(hdc, -1) '-1时恢复以前的内容'恢复DC设备 ReleaseDC Hwnd, hdc '删除窗口设备句柄,释放资源 DeleteObject brush 'DeleteObject ll_Pen

End Sub

TA的精华主题

TA的得分主题

 楼主| 发表于 2005-8-24 21:23 | 显示全部楼层
现已做到全部支持上下键和ENTER键.

TA的精华主题

TA的得分主题

发表于 2005-8-24 22:35 | 显示全部楼层

多谢版版指教.谢谢~~~~~~~~[em23]

你说的支持上下键和enter键是什么意思?是指用上下键或者enter键来选取单元格时,照样可以高亮吗?

我试了好像不行的啊,只有用鼠标点选了单元格,才可以高亮.只要用键盘的上下键,Tab键或者enter键来重新选择单元格,高亮就马上消失了.

TA的精华主题

TA的得分主题

发表于 2005-8-24 22:39 | 显示全部楼层

如果再能支持键盘焦点的高亮问题,版版你的这个代码就非常的经典啦.

可以支持行高亮、列高亮、行列高亮、UNDO和复制粘贴功能不消失,再加上用键盘操作也一样能高亮……简直就是完美了^_^

TA的精华主题

TA的得分主题

 楼主| 发表于 2005-8-24 22:41 | 显示全部楼层

其实前一些时间我也在考虑支持上下键或者enter键来选取单元格时,照样可以高亮..目前我编程基本上是用VB编制ADDIN.本想做成限次版的.后来一想就算了.你现在试一下这个DLL吧.跟XCOLOR类似, 不过支持功能更多一些.

用来增强Excel显示效果,减少输入误差,用于防呆处理用.

支持两种方式,1).条件格式,影响Excel 中undo 功能 . 2).XColor 式功能:用API函数绘制实现.功能更强大,自定义选择Color 功能,在支持ROW的功能上,增加对单元格的支持.运行后不影响Excel 中undo 功能.3).支持上下键或者enter键高亮显示.

6lXtAAiA.zip (96.65 KB, 下载次数: 293)

quG18rAm.zip

96.51 KB, 下载次数: 180

PamIz7BB.zip

96.65 KB, 下载次数: 189

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关注官方微信,高效办公专列,每天发车

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2019-8-19 10:48 , Processed in 0.117465 second(s), 12 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2020 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

快速回复 返回顶部 返回列表