vba截屏位置偏移，是什么地方有问题？（已解决）
本帖最后由 jack093 于 2013-8-23 16:10 编辑代码如下，用了 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
自己搞定，直接用GetCursorPos，
页:
[1]