vb 屏幕问题 跪求答案 请问我用一下代码 输出图片是空白呀 我想截取当前整个电脑屏幕
作者&投稿：除时 （若有异议请与网页底部的电邮联系）
SavePicture Picture1.Image, "C:\瞬间的画面.BMP"
布局管理里面把当前自定义模块删掉试试，如果不行的话，给个子帐号我帮你搞定
'是你的bitbit用法有问题，下面是修改后的代码：Option Explicit
Private Type PALETTEENTRY
peRed As Byte
peGreen As Byte
peBlue As Byte
peFlags As Byte
End Type
Private Type LOGPALETTE
palVersion As Integer
palNumEntries As Integer
palPalEntry(255) As PALETTEENTRY
End Type
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Const RASTERCAPS As Long = 38
Private Const RC_PALETTE As Long = &H100
Private Const SIZEPALETTE As Long = 104
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function CreateCompatibleDC Lib "GDI32" (ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "GDI32" (ByVal hDC As Long, _
ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function GetDeviceCaps Lib "GDI32" (ByVal hDC As Long, ByVal _
iCapabilitiy As Long) As Long
Private Declare Function GetSystemPaletteEntries Lib "GDI32" (ByVal hDC As Long, _
ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries _
As PALETTEENTRY) As Long
Private Declare Function CreatePalette Lib "GDI32" (lpLogPalette As LOGPALETTE) _
As Long
Private Declare Function SelectObject Lib "GDI32" (ByVal hDC As Long, ByVal hObject _
As Long) As Long
Private Declare Function BitBlt Lib "GDI32" (ByVal hDCDest As Long, ByVal XDest As _
Long, ByVal YDest As Long, ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal hDCSrc As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop _
As Long) As Long
Private Declare Function DeleteDC Lib "GDI32" (ByVal hDC As Long) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function SelectPalette Lib "GDI32" (ByVal hDC As Long, ByVal hPalette _
As Long, ByVal bForceBackground As Long) As Long
Private Declare Function RealizePalette Lib "GDI32" (ByVal hDC As Long) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As _
RECT) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As _
Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Type PicBmp
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As _
PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Dim ComputerName As String '本机名称，用来区分不同的机器所生成的图像。
'创建BMP位图
Public Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture
Dim r As Long
Dim Pic As PicBmp
Dim IPic As IPicture
Dim IID_IDispatch As GUID
'填充IDispatch界面
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
'填充Pic
With Pic
.Size = Len(Pic) '注释： Pic结构长度
.Type = vbPicTypeBitmap '注释： 图象类型
.hBmp = hBmp '注释： 位图句柄
.hPal = hPal '注释： 调色板句柄
End With
'建立Picture图象
r = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
'返回Picture对象
Set CreateBitmapPicture = IPic
End Function
'截图处理
Public Function CaptureWindow(ByVal hWndSrc As Long, ByVal Client As Boolean, ByVal _
LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc _
As Long) As Picture
Dim hDCMemory As Long '保存截取图象的目标设备
Dim hBmp As Long
Dim hBmpPrev As Long
Dim r As Long
Dim hDCSrc As Long '要截取图象的源设备
Dim hPal As Long
Dim hPalPrev As Long
Dim RasterCapsScrn As Long
Dim HasPaletteScrn As Long
Dim PaletteSizeScrn As Long
Dim LogPal As LOGPALETTE
'GetDC传回用于写入窗口显示区域的设备内容句柄,而GetWindowDC传回写入整个窗口的设备内容句柄
'区别在于GetDC不包括边框、滚动条、标题栏、菜单等，而GetWindowDC则包括
If Client Then '如果为真，即指定是客户区（不包括标题栏等）
hDCSrc = GetDC(hWndSrc) 'GetDC检索一指定窗口的客户区域或整个屏幕的显示设备上下文的句柄
Else '否则用GetWindowDC寻找后获取
hDCSrc = GetWindowDC(hWndSrc)
End If
hDCMemory = CreateCompatibleDC(hDCSrc) '创建一块与hDCSrc设备场景一样的内存区
hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc) '创建一幅与设备有关位图
hBmpPrev = SelectObject(hDCMemory, hBmp) 'SelectObject将位图放入设备场景中
'获得屏幕属性
RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS) '根据指定设备场景代表的设备的功能返回信息
HasPaletteScrn = RasterCapsScrn And RC_PALETTE
PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE)
'如果屏幕对象有调色板则获得屏幕调色板
If HasPaletteScrn And (PaletteSizeScrn = 256) Then
'建立屏幕调色板的拷贝
LogPal.palVersion = &H300
LogPal.palNumEntries = 256
r = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0)) '获取系统调色板
hPal = CreatePalette(LogPal) 'CreatePalette调色板函数
'将新建立的调色板选入建立的内存绘图句柄中
hPalPrev = SelectPalette(hDCMemory, hPal, 0)
r = RealizePalette(hDCMemory) 'RealizePalette函数使系统恢复当前选中的逻辑调色板中的值
End If
'拷贝图象
r = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, vbSrcCopy)
hBmp = SelectObject(hDCMemory, hBmpPrev)
If HasPaletteScrn And (PaletteSizeScrn = 256) Then
hPal = SelectPalette(hDCMemory, hPalPrev, 0)
End If
'释放资源
r = DeleteDC(hDCMemory)
r = ReleaseDC(hWndSrc, hDCSrc)
Set CaptureWindow = CreateBitmapPicture(hBmp, hPal)
End Function
Private Sub Form_Load()
Dim sBuffer As String
Dim lSize As Long
sBuffer = Space$(255)
lSize = Len(sBuffer)
Call GetComputerName(sBuffer, lSize)
ComputerName = Trim(Left$(sBuffer, lSize))
End Sub
Private Sub Timer1_Timer()
Dim hWndScreen As Long, CaptureScreen As StdPicture
'获得桌面的窗口句柄
hWndScreen = GetDesktopWindow()
Set CaptureScreen = CaptureWindow(hWndScreen, False, 0, 0, Screen.Width _
\ Screen.TwipsPerPixelX, Screen.Height \ Screen.TwipsPerPixelY)
SavePicture CaptureScreen, "\\WWW-94E37D893B8\D$\ClientScreen\image" & ComputerName & ".bmp"
Call iniPara
End Sub
'当发现有异常情况时，往往需要缩短采样间隔，下面iniPara函数可实现改变定时器的Interval属性的功能。
Private Function iniPara() '读取服务器上的Client.ini文件，初使化定时器的间隔。
Dim sBuffer As String
Dim lSize As Long
Dim TimerInterval As Integer '采样间隔
Open "\\WWW-94E37D893B8\D$\ClientScreen\Client.ini" For Input As #1
Line Input #1, sBuffer
lSize = InStr(1, sBuffer, "=")
Timer1.Interval = Val(Mid(sBuffer, lSize + 1))
Close (1)
End Function
钦昏西艾： 屏幕和VB程序能不能显示无关,只要你的机器硬件和系统环境达到VB程序的运行要求即可.屏幕只是一个起到一个显示的作用,无关程序的运行.以上为个人看法,手打很辛苦,希望采纳,谢谢您的支持...
新洲区18913971810： 怎么解决vb窗口等待或者白屏啊,希望大家帮忙啊 - ？
钦昏西艾： Private Declare Function GetInputState Lib ＂user32＂ () As Long'该API用来判断是否存在任何待决(等待处理)的鼠标或键盘事件 private sub 你处理数据库的函数()'里面肯定会有循环 do while xx if GetInputState then doevents'以上的代码是用来转让控制权,以便让操作系统处理其它的事件.'你处理数据的程序 loop end sub'如果满意我的回答,请采纳,谢谢'如有不解之处,请给我发消息
新洲区18913971810： VB2005 初始屏幕显示问题 - ？
钦昏西艾： 很简单啊,timer控件在splash窗体上,登陆成功后隐藏 login窗体(login是主进程,关闭程序就结束了,还有别的解决方法但是很复杂).计时开始后若干秒,先unload splash,再让mainform show就可以了 ,记得关闭mainform 是关闭 login窗体 可以重写new()时用窗体做参数,这样你就可以在这个窗体总操作另一个窗体了
新洲区18913971810： VB中用宽屏设计的软件在正常屏幕上显示出现问题？
钦昏西艾： 最简单的:按小的屏幕做.你看这个网页,宽就是按1024 做的.软件界面设计也一样
新洲区18913971810： VB 屏幕截图问题! - ？
钦昏西艾： Private Sub Command1_Click() picture1.autoredraw=true Timer1.Enabled = True End Sub Private Sub Timer1_Timer() Dim hdc As Long hdc = GetDC(0) Dim a As String Dim b As String a = Screen.Width \ Screen.TwipsPerPixelX b = Screen....
新洲区18913971810： vb 判断屏幕保护 状态 - ？
钦昏西艾： 'API调用与常用定义:Private Declare Function SystemParametersInfo _ Lib ＂user32＂ _ Alias ＂SystemParametersInfoA＂ _ (ByVal uiAction As Long, _ ByVal uiParam As Long, _ pvParam As Any, _ ByVal fWInIni As Long) As Boolean Private ...
新洲区18913971810： 跪求Vb锁定屏幕代码？
钦昏西艾： 在win98可以限制鼠标移动区域,nt内核的不行. 我建议是将窗口全屏,然后置于顶层.就算调出任务管理器也会被挡住. 记得置顶的API很简单,你可以上网搜搜或者给我发邮件kqwd@163.com 我还有在winxp sp3之前的windows中隐藏进程的代码.要的话发邮件给我
新洲区18913971810： VB屏幕的刷新频率的问题! - ？
钦昏西艾： Private Declare Function EnumDisplaySettings Lib ＂user32＂ Alias ＂EnumDisplaySettingsA＂ (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lpDevMode As Any) As Boolean Const CCDEVICENAME = 32 Const ...
新洲区18913971810： VB全屏显示,不是最大化 - ？
钦昏西艾： 不支持.无论是VB C# C/C++.由于VC应经没有了原来的graphic.h.只能调用系统的API.调用系统的API是做不出全屏的.但是可以做无边框,最大化的顶层窗口.也近似全屏了.除非用低层的的图形库如OpenGL,DirectX这才能做出原汁原味的全屏.
新洲区18913971810： 难题跪求vb屏幕输出 - ？
钦昏西艾： Private Declare Function SetLayeredWindowAttributes Lib ＂user32＂ (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long Private Const WS_EX_LAYERED = &H80000 Private Const GWL_...
