|
|
代码如下，用了 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)
.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
5itk14yhpbu.JPG
本帖以下内容被隐藏保护；需要你回复后，才能看到！ 游客，如果您要查看本帖隐藏内容请 回复 |
|
置顶卡
