vba截屏位置偏移，是什么地方有问题？（已解决）

jack093

代码如下，用了 ClientToScreen 还是偏移，原因何在？

另外，如何改为jpg格式的？
Function Screen_pos(ByVal x As Double, ByVal y As Double) As Double()
Dim iPt As Variant
Dim h As Double
Dim wh As Variant
Dim w As Double
Dim minPt(0 To 2) As Double
Dim maxPt(0 To 2) As Double

Dim ret(0 To 1) As Double
iPt = ThisDrawing.GetVariable("VIEWCTR")
h = ThisDrawing.GetVariable("VIEWSIZE")
wh = ThisDrawing.GetVariable("SCREENSIZE")
w = wh(0) / wh(1) * h
minPt(0) = iPt(0) - w / 2: minPt(1) = iPt(1) - h / 2: minPt(2) = 0
maxPt(0) = iPt(0) + w / 2: maxPt(1) = iPt(1) + h / 2: maxPt(2) = 0
ret(0) = wh(0) * (x - minPt(0)) / w
ret(1) = wh(1) - wh(1) * (y - minPt(1)) / h
Screen_pos = ret
End Function


' 拷贝选定方框区域的屏幕图像到剪贴板
Sub ScrnCap()
Dim Left As Long
Dim Top As Long
Dim Right As Long
Dim Bottom As Long

Right = 800
Bottom = 900
    Dim rWidth As Long
    Dim rHeight As Long
    Dim SourceDC As Long
    Dim DestDC As Long
    Dim BHandle As Long
    Dim Wnd As Long
    Dim DHandle As Long
  Dim Pt1 As Variant, Pt2 As Variant
    On Error Resume Next
    Pt1 = ThisDrawing.Utility.GetPoint(, "Select First Point")
    Pt2 = ThisDrawing.Utility.GetCorner(Pt1, "Select Corner Point")
    'Wnd = Screen.ActiveForm.hwnd
    Wnd = GetActiveWindow
    Dim pt As POINTAPI
Dim aa() As Double
    aa = Screen_pos(Pt1(0), Pt1(1))
    pt.x = aa(0)
    pt.y = aa(1)


    Dim DispInfo As String
   DispInfo = "left " & ThisDrawing.Utility.RealToString(pt.x, acDefaultUnits, LuPrec) & " top " & ThisDrawing.Utility.RealToString(pt.y, acDefaultUnits, LuPrec)


   AutoCAD.Application.ActiveDocument.Utility.Prompt (DispInfo)

    ' 转换屏幕坐标
   ClientToScreen Wnd, pt
   DispInfo = " left " & ThisDrawing.Utility.RealToString(pt.x, acDefaultUnits, LuPrec) & " top " & ThisDrawing.Utility.RealToString(pt.y, acDefaultUnits, LuPrec)


   AutoCAD.Application.ActiveDocument.Utility.Prompt (DispInfo)

Left = pt.x
Top = pt.y


    aa = Screen_pos(Pt2(0), Pt2(1))
    pt.x = aa(0)
    pt.y = aa(1)

   DispInfo = " left " & ThisDrawing.Utility.RealToString(pt.x, acDefaultUnits, LuPrec) & " top " & ThisDrawing.Utility.RealToString(pt.y, acDefaultUnits, LuPrec)


   AutoCAD.Application.ActiveDocument.Utility.Prompt (DispInfo)
    ' 转换屏幕坐标
    ClientToScreen Wnd, pt
   DispInfo = " left " & ThisDrawing.Utility.RealToString(pt.x, acDefaultUnits, LuPrec) & " top " & ThisDrawing.Utility.RealToString(pt.y, acDefaultUnits, LuPrec)


   AutoCAD.Application.ActiveDocument.Utility.Prompt (DispInfo)

Right = pt.x
Bottom = pt.y


    rWidth = Right - Left
    rHeight = Bottom - Top
    SourceDC = CreateDC("DISPLAY", 0, 0, 0)
    DestDC = CreateCompatibleDC(SourceDC)
    BHandle = CreateCompatibleBitmap(SourceDC, rWidth, rHeight)
    SelectObject DestDC, BHandle
    BitBlt DestDC, 0, 0, rWidth, rHeight, SourceDC, Left, Top, &HCC0020
    Wnd = GetActiveWindow
    OpenClipboard Wnd
    EmptyClipboard
    SetClipboardData 2, BHandle
    CloseClipboard
    DeleteDC DestDC
    ReleaseDC DHandle, SourceDC

End Sub

jack093

自己搞定，直接用GetCursorPos，