[共享]VBA尺寸单位的转换和鼠标控制

winland · 发表于 2006-11-29 18:13

VBA尺寸单位的转换和鼠标控制

1.
VBA里的尺寸单位很丰富, 如Twip,Point,Pixel,Inch,Character,Millimeter,Centimeter等. 单位转换时会觉得有点混乱. 例如Excel和Word多用Point, 而Access多用Twip, API里用的尺寸单位多为Pixel. 这主要介绍用得比较多的Twip, Point和Pixel.

Twip/Point是一个与屏幕无关的测量单位, 这样在打印时不要考虑屏幕分辨率的问题. Pixel则是同像素有关的测量单位. 屏幕上显示最小的一个点就是一个像素.

Twip,Point和Inch转换公式如下:
Twip=1/20*Point=1/1440*Inch
Point=20*Twip=1/72*Inch

而Twip/Point同Pixel之间则要依据设备环境参数做转换, 下面是一些转换的函数.

Private Const HORZRES = 8
Private Const VERTRES = 10
Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
Private Const TWIPSPERINCH = 1440

Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, _
   ByVal nIndex As Long) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, _
   ByVal hDC As Long) As Long
Function getDPI(bX As Boolean) As Integer  '获取屏幕分辨率
    Dim hDC As Long, RetVal As Long
    hDC = GetDC(0)
    If bX = True Then
        getDPI = GetDeviceCaps(hDC, LOGPIXELSX)
    Else
        getDPI = GetDeviceCaps(hDC, LOGPIXELSY)
    End If
    RetVal = ReleaseDC(0, hDC)
End Function
Function Pixel2TwipX(x As Long) As Long   '水平方向Pixel转Twip
    Pixel2TwipX = (x / getDPI(True)) * TWIPSPERINCH
End Function
Function Pixel2TwipY(x As Long) As Long   '垂直方向Pixel转Twip
    Pixel2TwipY = (x / getDPI(False)) * TWIPSPERINCH
End Function
Function Pixel2PointX(x As Long) As Long  '水平方向Pixel转Point
    Pixel2PointX = Pixel2TwipX(x) / 20
End Function
Function Pixel2PointY(x As Long) As Long  '垂直方向Pixel转Point
    Pixel2PointY = Pixel2TwipY(x) / 20
End Function
Function Twip2PixelX(x As Long) As Long   '水平方向Twip转Pixel
    Twip2PixelX = x / TWIPSPERINCH * getDPI(True)
End Function
Function Twip2PixelY(x As Long) As Long   '垂直方向Twip转Pixel
    Twip2PixelY = x / TWIPSPERINCH * getDPI(False)
End Function
Function Point2PixelX(x As Long) As Long  '水平方向Point转Pixel
    Point2PixelX = Twip2PixelX(x * 20)
End Function
Function Point2PixelY(x As Long) As Long  '垂直方向Point转Pixel
    Point2PixelY = Twip2PixelY(x * 20)
End Function
Function getScreenX() As Long     '获取屏幕宽
    Dim hDC As Long, RetVal As Long
    hDC = GetDC(0)
    getScreenX = GetDeviceCaps(hDC, HORZRES)
    RetVal = ReleaseDC(0, hDC)
End Function
Function getScreenY() As Long     '获取屏幕高
    Dim hDC As Long, RetVal As Long
    hDC = GetDC(0)
    getScreenY = GetDeviceCaps(hDC, VERTRES)
    RetVal = ReleaseDC(0, hDC)
End Function

2.
Excel里Cell有Width和Height的属性, 但它们只是可读, 你要设置行高和列宽的话, 需要用到RowHeight和ColumnWidth属性, 而这个ColumnWidth很是奇怪.
RowHeight就等于Height, 都是以Point为单位. 而ColumnWidth又不一样. 下面是ColumnWidth的说明.

ColumnWidth 属性
返回或设置指定区域中所有列的列宽。Variant 类型，可读写。
说明
一个列宽单位等于"常规"样式中一个字符的宽度。对于比例字体，则使用字符“0”（零）的宽度。
如果区域中所有列的列宽都相等，ColumnWidth 属性返回该宽度值。如果区域中的列宽不等，本属性返回 Null。

ColumnWidth用的是列宽单位, 就是说一列的ColumnWidth值刚好就是在"常规"样式下单元格可容纳的0的个数. 这个"常规"样式说的是创建这个文件时使用StandardFont和StandardFontSize的"常规"(regular)样式. 一般来说不过去你在一个文件里添加一个新的Sheet,这个新的Sheet采用的就是"常规"样式.

列宽单位=cells(1,1).Width/cells(1,1).ColumnWidth 个Point

可调的ColumnWidth用列宽单位, 而控件用Point单位, 在定位时需要转换一下. 下面是个让单元格适应控件的例子.

Sub ColumnWidthFitCmdButton()
    Dim iCol As Integer
    Dim i As Integer
    Dim iRate As Variant

    Sheet1.CommandButton1.Left = Cells(2, 2).Left
    Sheet1.CommandButton1.Top = Cells(2, 2).Top
    Sheet1.CommandButton1.Height = Range(Cells(2, 2), Cells(3, 2)).Height
    For i = 1 To 256
        If Sheet1.CommandButton1.Width < Range(Cells(2, 2), Cells(2 + i)).Width Then
            iCol = i
            Exit For
        End If
    Next i

    iRate = Range(Cells(2, 2), Cells(2 + iCol - 1)).Width / Sheet1.CommandButton1.Width
    For i = 0 To iCol - 1
        Cells(2, 2 + i).ColumnWidth = Cells(2, 2 + i).ColumnWidth / iRate
    Next i
End Sub

3.
最后说说怎么在Excel里让鼠标定位. 这里要用到API函数和上面的转换函数. 下面是一些例子设置鼠标到指定单元格或控件.
Public Type POINTAPI
x As Long
y As Long
End Type
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
'Additional function
Public Const MOUSEEVENTF_LEFTDOWN = &H2
Public Const MOUSEEVENTF_LEFTUP = &H4
Public Const MOUSEEVENTF_MOVE = &H1
Public Const MOUSEEVENTF_ABSOLUTE = &H8000
Declare Function GetFocus Lib "user32" () As Long
Public Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Public Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Public Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)

Sub SetCursorToCell(iRow As Integer, iCol As Integer) '设鼠标到单元格
    Dim pt As POINTAPI
    Dim iTRow As Integer
    Dim iTCol As Integer
    Dim iDRow As Integer
    Dim iDCol As Integer

    iTRow = ActiveWindow.VisibleRange.Rows.Count
    iTCol = ActiveWindow.VisibleRange.Columns.Count
    Dim i As Integer

    If iRow < ActiveWindow.VisibleRange.Row Or iRow > ActiveWindow.VisibleRange.Row + iTRow - 1 Or iCol < ActiveWindow.VisibleRange.Column Or iCol > ActiveWindow.VisibleRange.Column + iTCol - 1 Then
        Cells(iRow, iCol).Select   '如果单元格不在当前可见范围内, 选择它
    End If

    GetCursorPos pt     '获取鼠标坐标
    Err.Clear
    On Error Resume Next
    iTRow = ActiveWindow.RangeFromPoint(pt.x, pt.y).Row '获取鼠标所在上的单元格
    iTCol = ActiveWindow.RangeFromPoint(pt.x, pt.y).Column '获取鼠标所在上的单元格
    If Len(Err.Description) <> 0 Then
        SetDataArea   '如果鼠标在标题栏或工具栏或窗口外位置, 设到Excel的数据区内
        Err.Clear
        GetCursorPos pt
        iTRow = ActiveWindow.RangeFromPoint(pt.x, pt.y).Row
        iTCol = ActiveWindow.RangeFromPoint(pt.x, pt.y).Column
    End If

    For i = pt.x To 0 Step -1
        If ActiveWindow.RangeFromPoint(i, pt.y).Column < iTCol Then
  iDRow = pt.x - i - 1 '获取鼠标所在上的单元格的左上角X坐标
            Exit For
        End If
    Next i
    For i = pt.y To 0 Step -1
        If ActiveWindow.RangeFromPoint(pt.x, i).Row < iTRow Then
            iDCol = pt.y - i - 1 '获取鼠标所在上的单元格的左上角Y坐标
            Exit For
        End If
    Next i

    SetCursorPos pt.x - Point2PixelX(Cells(iTRow, iTCol).Left - Cells(iRow, iCol).Left) + Cells(iRow, iCol).Width / Cells(iTRow, iTCol).Width * iDRow - iDRow, pt.y - Point2PixelY(Cells(iTRow, iTCol).Top - Cells(iRow, iCol).Top) + Cells(iRow, iCol).Height / Cells(iTRow, iTCol).Height * iDCol - iDCol
End Sub
Sub SetCursorToControl(iControl As Variant)
    Dim pt As POINTAPI
    Dim iTRow As Integer
    Dim iTCol As Integer
    Dim iDRow As Integer
    Dim iDCol As Integer

    Dim i As Integer
    With ActiveWindow.VisibleRange
    If iControl.Left + iControl.Width > .Left + .Width Or iControl.Top + iControl.Height > .Top + .Height Then
        iControl.BottomRightCell.Select
    End If
    If iControl.Left < .Left Or iControl.Top < .Top Then
        iControl.TopLeftCell.Select
    End If
    End With

    GetCursorPos pt
    Err.Clear
    On Error Resume Next
    iTRow = ActiveWindow.RangeFromPoint(pt.x, pt.y).Row
    iTCol = ActiveWindow.RangeFromPoint(pt.x, pt.y).Column
    If Len(Err.Description) <> 0 Then
        SetDataArea
        Err.Clear
        GetCursorPos pt
        iTRow = ActiveWindow.RangeFromPoint(pt.x, pt.y).Row
        iTCol = ActiveWindow.RangeFromPoint(pt.x, pt.y).Column
    End If

    For i = pt.x To 0 Step -1
        If ActiveWindow.RangeFromPoint(i, pt.y).Column < iTCol Then
            iDRow = pt.x - i - 1
            Exit For
        End If
    Next i
    For i = pt.y To 0 Step -1
        If ActiveWindow.RangeFromPoint(pt.x, i).Row < iTRow Then
            iDCol = pt.y - i - 1
            Exit For
        End If
    Next i

    SetCursorPos pt.x - Point2PixelX(Cells(iTRow, iTCol).Left - iControl.Left) + iControl.Width / Cells(iTRow, iTCol).Width * iDRow - iDRow, pt.y - Point2PixelY(Cells(iTRow, iTCol).Top - iControl.Top) + iControl.Height / Cells(iTRow, iTCol).Height * iDCol - iDCol
End Sub
Sub ClickControl(iControl As Variant)
    SetCursorToControl iControl
    mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0&, 0& '模拟鼠标按左键动作
    mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0&, 0&
End Sub
Sub ColumnWidthFitCmdButton()
    Dim iCol As Integer
    Dim i As Integer
    Dim iRate As Variant

    Sheet1.CommandButton1.Left = Cells(2, 2).Left
    Sheet1.CommandButton1.Top = Cells(2, 2).Top
    Sheet1.CommandButton1.Height = Range(Cells(2, 2), Cells(3, 2)).Height
    For i = 1 To 256
        If Sheet1.CommandButton1.Width < Range(Cells(2, 2), Cells(2 + i)).Width Then
            iCol = i
            Exit For
        End If
    Next i

    iRate = Range(Cells(2, 2), Cells(2 + iCol - 1)).Width / Sheet1.CommandButton1.Width
    For i = 0 To iCol - 1
        Cells(2, 2 + i).ColumnWidth = Cells(2, 2 + i).ColumnWidth / iRate
    Next i
End Sub
Private Sub SetDataArea()
    Dim pt As POINTAPI
    ClientToScreen GetFocus, pt
    SetCursorPos pt.x + 250, pt.y + 150
End Sub
Sub trythis()
    SetCursorToControl Sheet1.CommandButton1
    'ClickControl Sheet1.CommandButton1
    'SetCursorToCell 8, 2
End Sub

有什么错误, 请帮指出. 多谢.

1gdLyYkQ.zip (22.75 KB, 下载次数: 1788)

winland · 发表于 2006-11-29 18:27

多谢taller版主, 我的获取鼠标所在单元格的一些代码是从你那里学的.

zhoujibin1 · 发表于 2006-11-29 20:32

谢谢

opiona · 发表于 2006-11-30 12:54

我想在excel中套打一些表格

表格的宽度，长度使用毫米或厘米更方便写

请问毫米和Twip/Point（一个与屏幕无关的测量单位）怎样换算？？

比如：设置row(2)的高度为20 毫米

使用vba如何写？？

谢谢

当归 · 发表于 2006-11-30 14:55

不错。很有创意的一个帖子。

丸究阵引 · 发表于 2006-11-30 22:57

多谢！

winland · 发表于 2006-12-1 10:07

1 Inch等于25.4毫米.这样:

1 毫米 = 72/25.4 * Point

1 毫米 = 1440/25.4 * Twip

设行高为20毫米的话就是 Rows(2).RowHeight=20*72/25.4

设列宽为20毫米的话就是

Cells(2, 1).ColumnWidth = 20 * 72 / (25.4 * Cells(2, 1).Width / Cells(2, 1).ColumnWidth)

opiona · 发表于 2006-12-1 14:25

QUOTE:

以下是引用winland在2006-12-1 10:07:02的发言：

1 Inch等于25.4毫米.这样:

1 毫米 = 72/25.4 * Point

1 毫米 = 1440/25.4 * Twip

设行高为20毫米的话就是 Rows(2).RowHeight=20*72/25.4

设列宽为20毫米的话就是

Cells(2, 1).ColumnWidth = 20 * 72 / (25.4 * Cells(2, 1).Width / Cells(2, 1).ColumnWidth)

多谢，我看看

wclaw · 发表于 2006-12-1 14:37

One unit of column width is equal to the width of one character in the Normal style. For proportional fonts, the width of the character 0 (zero) is used.

The row height is measured in points (1pt = 1/72 inch or about 1/28 centimeters). A point is a "unit of measure referring to the height of a printed character" (quoting from the VBA help file for the RowHeight property).

可以使用 Application.CentimetersToPoints

winland · 发表于 2006-12-1 15:30

Application里有很多有用的.

除了Application.CentimetersToPoints, 还有个Application.InchsToPoints.

		自动登录	找回密码
密码			免费注册

[共享]VBA尺寸单位的转换和鼠标控制

评分

最新热点 /1