'模块中
专注于为中小企业提供成都网站设计、成都做网站服务,电脑端+手机端+微信端的三站合一,更高效的管理,为中小企业定安免费做网站提供优质的服务。我们立足成都，凝聚了一批互联网行业人才，有力地推动了上千企业的稳健成长，帮助中小企业通过网站建设实现规模扩充和转变。
Declare Function GetDC Lib "user32" (ByVal hwnd As Long) _
As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Declare Function BitBlt Lib "gdi32" _
(ByVal hDestDC As Long, ByVal x As Long, _
ByVal y As Long, ByVal nWidth As Long, _
ByVal nHeight As Long, ByVal hSrcDC As Long, _
ByVal xSrc As Long, ByVal ySrc As Long, _
ByVal dwRop As Long) As Long
'form1中
Private Sub Command1_Click()
Dim hDCtmp As Long, picWidth As Double, picHeight As Double
Dim x As Double
Dim y As Double
x = Val(Text2.Text)
y = Val(Text3.Text)
picWidth = Val(Text3.Text)
picHeight = Val(Text4.Text)
hDCtmp = GetDC(0)
BitBlt Picture1.hdc, 0, 0, picWidth, picHeight, hDCtmp, x, y, vbSrcCopy
ReleaseDC 0, hDCtmp
End Sub
目的: 将屏幕按照指定坐标和大小进行截取成图,在picture1显示
问题: 大小是相同了,为什么截取的坐标不对,只是屏幕上的左上
相信大家都用过QQ截图功能。不过很多人并没有真正掌握好它的用法。将QQ截图与其它截屏和制图软件配合使用，会有意想不到的效果。
获取颜色的RGB值
我们在编辑图片或网页的时候，经常需要获取某种颜色的“RGB值”，所以很多人都安装了第三方的颜色吸取工具。其时用QQ截图键即可获取屏幕上任意颜色的RGB值。
当按下“Ctrl+Shift+A”弹出“截图”提示框时，提示框中的“当前像素RGB”即为当前鼠标屏幕位置的颜色RGB值，将鼠标移动到你想查看的屏幕颜色上即可获得相应的RGB值（如图1）。
图1精确截取图片大小
有时我们对要使用的截图尺寸有严格要求，比如论坛签名或QQ头像等。用QQ截图键可以按尺寸精确截取，一步到位无需再进行后期裁剪了。
按下QQ截图键，按住鼠标不放选取截取范围时，在鼠标上方会有一个信息框显示当前范围的详细信息，其中“矩形大小”就是以像素来表示的图片的尺寸大小，括号内的数字分别表示的是长和高（如图2）。松开鼠标调整截图框时，对照“矩形大小”就可以按需要的尺寸来精确截图范围，然后用鼠标点住截图框将截图框拖到要截取的图片上，双击即可获得所需尺寸的图片了。
图2图片拼贴好帮手
大部分的截图软件一次只能截取一张图片，当要截取多张图片并进行拼贴组合时，就需要一张一张截取全部保存后再进行拼贴操作，非常麻烦。
我们知道用QQ截图键截取的图片可以在任一个可以粘贴图片的程序中使用，这样只需用截图软件进行一次截图操作，剩下的图片用QQ截图键来截取，然后依次粘贴到截图软件的窗口中即可快速进行拼贴操作了，是不是很方便啊。
小提示：QQ截图键无需打开聊天窗口即可使用，截取的图片在任一可粘贴图片的程序窗口中如画图、Word等，使用“粘贴”命令即可使用
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
'可以通过查看前景窗口是否为指定窗口判断
hwd1 = FindWindow("#32770", "QQ用户登录")
'获得指定窗口句柄
hwd2 = GetForegroundWindow
'获得前景窗口句柄
If hwd1 = hwd2 Then MsgBox "指定窗口为活动状态！"
'判断是否相同
'可以通过ModifyMenu修改系统菜单来禁止移动，但并不适用所有窗体，有的窗体不具有系统菜单(BorderStyle=0)
'但通过子类化仍可以实现系统菜单具有的功能,新建窗体，添加command1，复制粘贴下段代码
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Private Declare Function ModifyMenu Lib "user32" Alias "ModifyMenuA" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpString As Any) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const SC_MOVE = HF010
Private Const MF_BYCOMMAND = H0
Private Const MF_ENABLED = H0
Private Const MF_GRAYED = H1
Private Sub Command1_Click()
hwind = FindWindow("#32770", "QQ用户登录")
'获取窗体句柄
hMenu = GetSystemMenu(hwind, False)
'获取该窗体系统菜单句柄
ModifyMenu hMenu, SC_MOVE, MF_BYCOMMAND Or MF_GRAYED, -10, "禁止移动"
'设置移动菜单项不可用，并指定新ID为小于0的-10以防止系统重新加载该菜单，新标题为“禁止移动”，成功返回非0，失败0
'ModifyMenu hMenu, -10, MF_BYCOMMAND + MF_ENABLED, SC_MOVE, "移动(M)" '恢复移动菜单
SendMessage hwind, WM_NCACTIVATE, True, 0
'发送WM_NCACTIVE消息到指定窗体刷新非客户区(标题栏)
End Sub
如果你能驾御API函数的话，那么推荐你使用楼上的方法，那是一个较为正统的方法。如果不用API的话，还真就没有什么好的方法能实现，同感，咱多希望窗体对象能有一个“Active”之类的属性，当窗体活动时，它是True…呵呵。不过你可以试试换一个角度，当窗体变成活动时会触发Active事件，变成非活动(即失去焦点)时会触发LoseFocus事件，所以你可以定义一个工程级变量(即所有窗体之间都通用的一个变量，如果不会可以追问我)，定义成布尔类型的，假设变量名是Form1Active，将 Form1Active = True、Form1Active = False 这两句话分别放到Form1的Active、LoseFocus中，然后就可以在其他过程或其他窗体中通过判断Form1Active的真假来获知Form1的是否是活动的。
以上只是思路，如果想知道具体代码的话追问我就好。
If App.PrevInstance = True Then
End
End If
如果程序正在运行，结束程序。
在模块中加入每个窗口的标题变量。
然后用if then 来判断是否有相同窗口。
如果你事先不知道有哪些窗口的话，那你就用枚举 FindWindow来查找子窗口句柄。再用SendMessage 获得窗口标题再进行判断。
Dim F1 As New Datasystem.Form2 '实例化窗体
For Each na As Form In Application.OpenForms '打开窗体的集合
If na.ProductName = F1.ProductName AndAlso na.Name = F1.Name 0 Then '判断程序集的产品名称和窗体名称是否已存在打开的窗体中
If na.WindowState = FormWindowState.Minimized Then '判断窗体是否最小化
na.WindowState = FormWindowState.Normal '还原窗体
End If
na.Activate() '激活窗体
Return '返回
End If
Next
F1.Show() '如果没有打开的窗体中未找到，重新打开窗体
'e.x;e.y等于鼠标在当前控件的位置。
If sender Is Me Then
'窗体
Else
'ElseIf sender Is Label1 Then
End If
