vba获取通达信光标的坐标数据_「高阶应用」谈一下VB6和VBA的坐标系统

两个知识点：1、常见单位换算 1英寸(Inch) = 72磅(Point) 1磅(Point) = 20缇(Twip) 2英寸(Inch) = 1440缇(Twip) 1英寸(Inch) = 2.54厘米(Centimeter)2、GetDeviceCaps(GetDC(0), LOGPIXELSX) 获取一个英寸多少个像素，即PPI(Pixels per Inch) 通过调用我们可以发现： 缩放比例100%时：1英寸=96个像素，缩放比例125%时：1英寸=120个像素 通过换算我们可以知道： 缩放比例100%时：1像素=15缇， 缩放比例125%时：1像素=12缇

首先，第2条里的这些单位：英寸、磅、缇、厘米，这些都是屏幕无关的打印尺寸单位

而像素则是屏幕相关的尺寸单位

PPI是每英寸屏幕的像素点个数, Pixels per Inch

注意大家经常把PPI和DPI混为一谈，这俩其实不是一个东西，但是你心里要有点*数DPI是一个打印尺度，打印墨点密度；而PPI是一个屏幕尺度，屏幕像素密度

在Word和Excel里，使用最多的长宽的单位是：磅

在Access里，使用最多的长宽的单位是：缇

API里使用的单位大部分都是：像素

---

有这些基础知识，在VBA里遭遇坐标的时候，就不会蒙蔽了。

例如，给UserForm上CommandButton控件画边框，光标移动到按钮上时，就画上边框，光标移出按钮，就删除边框

惯例废话少说：

'GDI+部分，画图用的GDI+

Public Declare Function GdiplusStartup Lib "gdiplus" ( _ token As Long, _ inputbuf As GdiplusStartupInput, _ Optional ByVal outputbuf As Long = 0) As GpStatusPublic Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As GpStatusPublic Type GdiplusStartupInput GdiplusVersion As Long DebugEventCallback As Long SuppressBackgroundThread As Long SuppressExternalCodecs As LongEnd TypePublic Enum GpStatus Ok = 0 GenericError = 1 InvalidParameter = 2 OutOfMemory = 3 ObjectBusy = 4 InsufficientBuffer = 5 NotImplemented = 6 Win32Error = 7 WrongState = 8 Aborted = 9 FileNotFound = 10 ValueOverflow = 11 AccessDenied = 12 UnknownImageFormat = 13 FontFamilyNotFound = 14 FontStyleNotFound = 15 NotTrueTypeFont = 16 UnsupportedGdiplusVersion = 17 GdiplusNotInitialized = 18 PropertyNotFound = 19 PropertyNotSupported = 20 #If GdipVersion >= 1.1 Then ProfileNotFound = 21 #End IfEnd EnumPublic Enum GpUnit UnitWorld = 0 UnitDisplay UnitPixel UnitPoint UnitInch UnitDocument UnitMillimeterEnd EnumPublic Declare Function GdipCreateFromHDC _ Lib "gdiplus" (ByVal hDC As Long, _ graphics As Long) As GpStatusPublic Declare Function GdipCreatePen1 _ Lib "gdiplus" (ByVal Color As Long, _ ByVal Width As Single, _ ByVal unit As GpUnit, _ pen As Long) As GpStatusPublic Declare Function GdipDrawRectangle _ Lib "gdiplus" (ByVal graphics As Long, _ ByVal pen As Long, _ ByVal X As Single, _ ByVal Y As Single, _ ByVal Width As Single, _ ByVal Height As Single) As GpStatusPublic Declare Function GdipDeletePen Lib "gdiplus" (ByVal pen As Long) As GpStatusPublic Declare Function GdipDeleteGraphics _ Lib "gdiplus" (ByVal graphics As Long) As GpStatus Private mToken As LongPublic Function InitGDIPlus(Optional OnErrorMsgbox, Optional ByVal OnErrorEnd As Boolean = True) As GpStatus If mToken <> 0 Then Debug.Print "InitGDIPlus> GdiPlus已被初始化" Exit Function End If Dim uInput As GdiplusStartupInput Dim Ret As GpStatus uInput.GdiplusVersion = 1 Ret = GdiplusStartup(mToken, uInput) If Ret <> Ok Then If Not IsMissing(OnErrorMsgbox) Then MsgBox OnErrorMsgbox If OnErrorEnd Then End End If InitGDIPlus = RetEnd FunctionPublic Sub TerminateGDIPlus() If mToken = 0 Then Debug.Print "TerminateGDIPlus> GdiPlus已被结束" Exit Sub End If GdiplusShutdown mToken mToken = 0End Sub

---

'然后是UserForm1部分，里面有一个按钮，CommandButton1

Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPrivate Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hParent As Long, ByVal hChildAfter As Long, ByVal sClass As String, ByVal sTitle As String) As LongPrivate Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As LongPrivate Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As LongPrivate Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As LongPrivate hParent& 'UserForm主窗体Private hChild& '客户区窗体Private ppi As Long '分辨率Private MMove As Boolean '控制变量Private Sub UserForm_Initialize() Dim hDC As Long hParent = UserFormHWnd() '主窗体 hChild = FindWindowEx(hParent, 0&, vbNullString, vbNullString) '客户区窗体 hDC = GetDC(0&) ppi = GetDeviceCaps(hDC, 88&) '获取分辨率 ReleaseDC 0&, hDC InitGDIPlus '初始化GDIPlusEnd SubPrivate Sub UserForm_Terminate() TerminateGDIPlusEnd SubPrivate Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) If MMove Then Me.Repaint MMove = False End IfEnd SubPrivate Sub CommandButton1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) If Not MMove Then MMove = True DrawRect Me.CommandButton1 End IfEnd SubPrivate Sub DrawRect(obj As Control) Dim hDC As Long Dim graphics As Long Dim pen As Long hDC = GetDC(hParent) '主窗体hDC GdipCreateFromHDC hDC, graphics GdipCreatePen1 &HFFFF0000, 1, GpUnit.UnitPixel, pen GdipDrawRectangle graphics, pen, PointsToPixels(obj.Left) - 1, _ PointsToPixels(obj.Top) - 1, _ PointsToPixels(obj.Width) + 1, _ PointsToPixels(obj.Height) + 1 'GDIPlus画矩形 GdipDeletePen pen GdipDeleteGraphics graphics '释放graphics占用的内存End SubFunction PointsToPixels(XY As Long) As Long PointsToPixels = XY / 72 * ppiEnd FunctionPrivate Function UserFormHWnd() As Long Dim strCaption$ Dim strClass$ strClass = "ThunderDFrame" 'Office2000以后一直是这个类名 strCaption = Me.Caption '记住现在的标题，以备最后恢复 Randomize '给当前窗口一个随机窗体名，这样获取到的窗口才会可靠 Me.Caption = CStr(Rnd) UserFormHWnd = FindWindow(strClass, Me.Caption) '查找窗体句柄 'UserFormHWnd = FindWindowEx(UserFormHWnd, 0&, vbNullString, vbNullString) '客户区窗体 Me.Caption = strCaption '恢复窗体标题End Function

跟本文相关的部分其实就是一个函数：PointsToPixels，多么简单的换算，不过动用了一个小技巧，获取ppi的代码写在了UserForm_Initialize事件里，避免多次换算时，每次都需要调用GetDeviceCaps获取ppi...