屏幕画线问题?帮忙看下

TripH0101 2009-04-20 10:01:56
我的代码是:
Option Explicit
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long

Private Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpPoint As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function InvalidateRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT, ByVal bErase As Long) As Long

Private Declare Function InvalidateRectBynum& Lib "user32" Alias "InvalidateRect" (ByVal hWnd As Long, ByVal lpRect As Long, ByVal bErase As Long)


Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const PS_SOLID = 0
Private Const WM_KEYDOWN = &H100



Private Sub Command1_Click()
Dim cx As Integer
Dim cy As Integer
Dim old As Long '存储旧画笔
Dim p As Long '存储新画笔

Dim a As Long '桌面句柄
Dim b As Long '桌面设备环境
cx = GetSystemMetrics(0)
cy = GetSystemMetrics(1)
a = GetDesktopWindow() '获得桌面句柄
b = GetWindowDC(a) '获得桌面设备环境

p = CreatePen(PS_SOLID, 3, vbRed) '创建画笔
old = SelectObject(b, p) '选择画笔

MoveToEx b, cx / 2, 0, 0 '设置起点坐标
LineTo b, cx / 2, cy '划竖线

MoveToEx b, 0, cy / 2, 0 '设置起点坐标
LineTo b, cx, cy / 2 '划线

SelectObject b, old '恢复画笔
DeleteObject p '删除创建的画笔
End Sub

Private Sub Timer1_Timer()
InvalidateRectBynum& GetDesktopWindow(), 0, True

End Sub

上面的代码是在屏幕中央画一个十字线。问题是刷新屏幕或者移动窗口就没了,要怎么改?
如何实现屏幕刷新即重绘时,不闪烁?
...全文
170 12 打赏 收藏 转发到动态 举报
AI 作业
写回复
用AI写文章
12 条回复
切换为时间正序
请发表友善的回复…
发表回复
TripH0101 2009-04-20
  • 打赏
  • 举报
回复
异形窗口怎么建啊?请大家说详细点,新手啊
舉杯邀明月 2009-04-20
  • 打赏
  • 举报
回复
还是创建异形窗口比较好。
东方之珠 2009-04-20
  • 打赏
  • 举报
回复
在Command1_Click中加上一行:Me.Refresh '刷新
在Timer中加一上一行:Call Command1_Click

其他应用程序是遮不住了,但移动本窗口还是有些问题。
嗷嗷叫的老马 2009-04-20
  • 打赏
  • 举报
回复
[Quote=引用 1 楼 chenjl1031 的回复:]
可否在一个半透明的,全屏的顶级窗口上画线.
[/Quote]
同意这种思路.

我说说具体的实现方案:

一,建个异形窗体,显示部分就是你的十字线.

二,设置这个窗体样式为"鼠标穿透",即可.

三,建议整好一个退出方案,因为这个窗体现在不响应鼠标键盘事件了.不然你就结束进程吧....
TripH0101 2009-04-20
  • 打赏
  • 举报
回复
我画的线要在最顶层显示 
东方之珠 2009-04-20
  • 打赏
  • 举报
回复
可否在一个半透明的,全屏的顶级窗口上画线.
TripH0101 2009-04-20
  • 打赏
  • 举报
回复
搞定了,谢谢
TripH0101 2009-04-20
  • 打赏
  • 举报
回复
太感谢了,再请问一下,怎样使十字线总在最顶层显示?
东方之珠 2009-04-20
  • 打赏
  • 举报
回复
楼上不错。再用setwindowpos置为顶层的就可以了。
lyserver 2009-04-20
  • 打赏
  • 举报
回复

'* ****************************************** *
'* 程序说明:一个可在屏幕上拖动的十字架 *
'* 作者:lyserver *
'* ****************************************** *
Option Explicit

Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Const RGN_OR = 2
Private Declare Function SelectClipRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Const GWL_STYLE = (-16)
Private Const WS_BORDER = &H800000
Private Const WS_MINIMIZE = &H20000000
Private Const WS_SYSMENU = &H80000
Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long

Dim bAdjust As Boolean
Dim hLine As RECT, vLine As RECT
Dim hhRgn As Long, hvRgn As Long
Dim startX As Long, startY As Long

Private Sub Form_Load()
WindowState = 2
MousePointer = 0
ScaleMode = vbPixels
BackColor = vbRed '十字条线条颜色
SetWindowLong hwnd, GWL_STYLE, WS_BORDER Or WS_MINIMIZE Or WS_SYSMENU
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = 1 Then
bAdjust = True
startX = x: startY = y
MousePointer = IIf(CBool(PtInRect(hLine, x + 1, y + 1)), 7, 9)
SetCapture hwnd
End If
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = 0 Then
MousePointer = IIf(CBool(PtInRect(hLine, x + 1, y + 1)), 7, 9)
ElseIf Button = 1 Then
If Not bAdjust Then
bAdjust = True
startX = x: startY = y
SetCapture hwnd
End If
End If
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = 1 And bAdjust Then
Dim tRgn As Long
If MousePointer = 7 Then
OffsetRect hLine, 0, y - startY
hhRgn = CreateRectRgn(hLine.Left, hLine.Top, hLine.Right, hLine.Bottom)
Else
OffsetRect vLine, x - startX, 0
hvRgn = CreateRectRgn(vLine.Left, vLine.Top, vLine.Right, vLine.Bottom)
End If
tRgn = CreateRectRgn(hLine.Left, hLine.Top, hLine.Right, hLine.Bottom)
Call CombineRgn(tRgn, hhRgn, hvRgn, RGN_OR)
Call SetWindowRgn(hwnd, tRgn, True)
DeleteObject tRgn
startX = x: startY = y
bAdjust = False
End If
ReleaseCapture
MousePointer = 0
End Sub

Private Sub Form_Resize()
Dim tRgn As Long

SetRect hLine, 0, ScaleHeight \ 2, ScaleWidth, ScaleHeight \ 2 + 1
SetRect vLine, ScaleWidth \ 2, 0, ScaleWidth \ 2 + 1, ScaleHeight
hhRgn = CreateRectRgn(hLine.Left, hLine.Top, hLine.Right, hLine.Bottom)
hvRgn = CreateRectRgn(vLine.Left, vLine.Top, vLine.Right, vLine.Bottom)
tRgn = CreateRectRgn(hLine.Left, hLine.Top, hLine.Right, hLine.Bottom)
Call CombineRgn(tRgn, hhRgn, hvRgn, RGN_OR)
Call SetWindowRgn(hwnd, tRgn, True)
DeleteObject tRgn
End Sub


Private Sub Form_Unload(Cancel As Integer)
DeleteObject hhRgn
DeleteObject hvRgn
End Sub
TripH0101 2009-04-20
  • 打赏
  • 举报
回复
那位能贴点代码出来 ,感谢
舉杯邀明月 2009-04-20
  • 打赏
  • 举报
回复
可能会用到的API:
CreateRectRgn()
CombineRgn()
SetWindowRgn()
DeleteObject()

有事要走了,你自己先试一下吧。

闪~~~~~~~~~

7,785

社区成员

发帖
与我相关
我的任务
社区描述
VB 基础类
社区管理员
  • VB基础类社区
加入社区
  • 近7日
  • 近30日
  • 至今
社区公告
暂无公告

试试用AI创作助手写篇文章吧