Question

vb 截图问题

因为太清楚 所以很占硬盘一张图需要2.50MB 有没有什么截图代码 不需要太清楚，只要把全屏截下来就行。 然后保存到c:\123.bmp 保存的文件不要超过1MB

Answer 1

楼上太烦了，说两个办法
办法一：用“print screen”(打印屏幕)，在键盘的右侧，保存到WORD里后点图片，然后右键“图片格式”-“压缩图片”-"败猜优化"-“确定”，就OK了，这样保存后图片可以并敏减少一察蔽型半的内存
方法二：用QQ截图，即打开QQ后“ctrl+altA”开始截图，然后按照上面的办法压缩图片。。。
早日成功啊。。。

Answer 2

'可以洞此剪切。复制。粘贴图像。

Dim flag1 As Boolean
Private Sub Form_Load()
Shape1.Visible = False
Shape1.BorderStyle = 3
flag1 = False
End Sub

Private Sub Picture1_MouseDown(Button As Integer, _
Shift As Integer, _
X As Single, Y As Single)
'开始选择区域
Shape1.Left = X
Shape1.Top = Y
flag1 = True
'设置标志变量并将Shape1的左上角移动到鼠标所在点
End Sub

Private Sub Picture1_MouseMove(Button As Integer, _
Shift As Integer, _
X As Single, Y As Single)
'在选定区域过程中随着鼠标移动产生虚线框
If Button = 1 Then
If flag1 = True Then
'如果是处在正在选择区域状态
Shape1.Width = Abs(X - Shape1.Left)
Shape1.Height = Abs(Y - Shape1.Top)
Shape1.Visible = True
Picture1.Refresh
Else
Shape1.Visible = False
End If
End If
End Sub

Private Sub Picture1_MouseUp(Button As Integer, _
Shift As Integer, _
X As Single, Y As Single)
flag1 = False
'结束选择区域状态
End Sub
Private Sub CmdCopy_Click()
'通过PictureClip控件作为中间灶颤键对象将Picture1中由Shape1表明的图像块
'复制隐巧到剪贴板上
If Shape1.Visible = True Then
'如果有选定的图像块
Clipboard.Clear '清空剪贴扳
On Error Resume Next
PictureClip1.Picture = Picture1.Picture
PictureClip1.ClipX = Shape1.Left
PictureClip1.ClipY = Shape1.Top
PictureClip1.ClipWidth = Shape1.Width
PictureClip1.ClipHeight = Shape1.Height
Clipboard.SetData PictureClip1.Clip
End If
End Sub

Private Sub CmdCut_Click()
Const vbMergePaint = &HBB0226
If Shape1.Visible = True Then
Clipboard.Clear '清空剪贴扳
On Error Resume Next
PictureClip1.Picture = Picture1.Picture
PictureClip1.ClipX = Shape1.Left
PictureClip1.ClipY = Shape1.Top
PictureClip1.ClipWidth = Shape1.Width
PictureClip1.ClipHeight = Shape1.Height
Clipboard.SetData PictureClip1.Clip
'如果有选定的图像块则复制到剪贴板

Picture1.PaintPicture Picture1.Picture, _
Shape1.Left, Shape1.Top, Shape1.Width, Shape1.Height, _
Shape1.Left, Shape1.Top, Shape1.Width, Shape1.Height, _
vbMergePait
'使用OR运算使Picture1中Shape1所标识的部分清空

End If
End Sub

Private Sub CmdPaste_Click()
'粘贴
Picture2.Picture = Clipboard.GetData
End Sub

'点击command1可以降低屏幕分辨率
Private Sub Command1_Click()
Dim red As Integer
Dim green As Integer
Dim blue As Integer
Dim c1, c2 As Long
Dim i, j As Integer
For i = 1 To Picture1.Width - 2 Step 4
For j = 1 To Picture1.Height - 2 Step 4
c1 = Picture1.Point(i, j)
red = c1 And &HFF
green = (c1 And 62580) / 256
blue = (c1 And &HFF0000) / 65536
'颜色处理
Picture2.PSet (i, j), RGB(red, green, blue)
Picture2.PSet (i, j + 1), RGB(red, green, blue)
Picture2.PSet (i, j + 2), RGB(red, green, blue)
Picture2.PSet (i, j + 3), RGB(red, green, blue)

Picture2.PSet (i + 1, j), RGB(red, green, blue)
Picture2.PSet (i + 1, j + 1), RGB(red, green, blue)
Picture2.PSet (i + 1, j + 2), RGB(red, green, blue)
Picture2.PSet (i + 1, j + 3), RGB(red, green, blue)

Picture2.PSet (i + 2, j), RGB(red, green, blue)
Picture2.PSet (i + 2, j + 1), RGB(red, green, blue)
Picture2.PSet (i + 2, j + 2), RGB(red, green, blue)
Picture2.PSet (i + 2, j + 3), RGB(red, green, blue)

Picture2.PSet (i + 3, j), RGB(red, green, blue)
Picture2.PSet (i + 3, j + 1), RGB(red, green, blue)
Picture2.PSet (i + 3, j + 2), RGB(red, green, blue)
Picture2.PSet (i + 3, j + 3), RGB(red, green, blue)
Next
Next

End Sub

Private Sub Form_Load()
With Form1
.Caption = "降低分辨率"
.Height = 4800
.Left = 0
.Top = 0
.Width = 6000
.ScaleMode = 3 'Pixel
End With
With Command1
.Caption = "降低分辨率"
.Height = 40
.Left = 20
.Top = 250
.Width = 100
.Visible = True

End With
With Picture1
.AutoRedraw = True
.AutoSize = True
.Height = 220
.Left = 20
.ScaleMode = 3 'Pixel
.Top = 20
.Width = 200
End With
With Picture2
.AutoRedraw = True
.AutoSize = True
.Height = 220
.Left = 200
.ScaleMode = 3 'Pixel
.Top = 20
.Width = 180
End With
Picture1.Picture = LoadPicture(App.Path + "xxxx.bmp")
End Sub

'可以缩小图像。保存
Dim flag As Integer

Private Sub CmdOpen_Click()
'打开文件
On Error GoTo Error_Handle
CommonDialog1.DialogTitle = "打开文件"
CommonDialog1.ShowOpen
If CommonDialog1.FileName <> "" Then
If Err <> 32755 Then
Dim OpenFileName As String
OpenFileName = CommonDialog1.FileName
Picture1.Picture = LoadPicture(OpenFileName)
End If
End If
Error_Handle: MsgBox Err.Description, vbOKOnly
Exit Sub
End Sub

Private Sub CmdSave_Click()
On Error GoTo Error_Handle
CommonDialog1.DialogTitle = "保存为BMP文件"
CommonDialog1.Filter = "位图文件(*.bmp)|*.bmp"
CommonDialog1.ShowSave
If CommonDialog1.FileName <> "" Then
If Err <> 32755 Then
Dim SaveBmpName As String
SaveBmpName = CommonDialog1.FileName
SavePicture Picture2.Image, SaveBmpName
End If
End If
Error_Handle: MsgBox Err.Description, vbOKOnly
Exit Sub
End Sub

Private Sub CmdScale_Click()
Dim i, j As Integer
Dim r, g, b As Integer
Dim r1, g1, b1 As Integer
Dim r2, g2, b2 As Integer
Dim r3, g3, b3 As Integer
Dim r4, g4, b4 As Integer
Dim c1, c2, c3, c4 As Long
If flag = 2 Then
'将图像缩小为原来的四分之一
Picture2.Width = Picture1.Width / 2
Picture2.Height = Picture1.Height / 2
For i = 0 To Picture2.Width Step 1
For j = 0 To Picture2.Height Step 1
c1 = Picture1.Point(2 * i, 2 * j)
r1 = c1 And &HFF
g1 = (c1 And 62580) / 256
b1 = (c1 And &HFF0000) / 65536

c2 = Picture1.Point(2 * i, 2 * j + 1)
r2 = c2 And &HFF
g2 = (c2 And 62580) / 256
b2 = (c2 And &HFF0000) / 65536

c3 = Picture1.Point(2 * i + 1, 2 * j)
r3 = c3 And &HFF
g3 = (c3 And 62580) / 256
b3 = (c3 And &HFF0000) / 65536

c4 = Picture1.Point(2 * i + 1, 2 * j + 1)
r4 = c4 And &HFF
g4 = (c4 And 62580) / 256
b4 = (c4 And &HFF0000) / 65536
r = (r1 + r2 + r3 + r4) / 4
g = (g1 + g2 + g3 + g4) / 4
b = (b1 + b2 + b3 + b4) / 4
Picture2.PSet (i, j), RGB(r, g, b)
Next
Next
ElseIf flag = 4 Then
'将图像缩小为原来的十六分之一
Picture2.Width = Picture1.Width / 4
Picture2.Height = Picture1.Height / 4
For i = 0 To Picture1.Width Step 4
For j = 0 To Picture1.Height Step 4
c1 = Picture1.Point(i, j)
Picture2.PSet (i / 4, j / 4), c1
Next
Next
ElseIf flag = 3 Then
'利用PictureBox控件缩小图像
Dim temp As String
temp = InputBox("请输入倍数", "自定义", 0.5)
If temp <> "" And temp > 0 And temp < 1 Then
Picture2.Width = Picture1.Width * temp
Picture2.Height = Picture1.Height * temp
Picture2.PaintPicture Picture1.Picture, 0, 0, Picture2.Width, Picture2.Height, _
0, 0, Picture1.Width, Picture1.Height
Else
MsgBox "输入倍数不符合要求", vbExclamation, "错误"
End If
End If

End Sub

Private Sub Form_Load()
'为Picture1添加图像并初始化flag变量
Picture1.Picture = LoadPicture(App.Path + "\鸟.bmp")
flag = 2
End Sub

Answer 3

向系统租宴发送模激饥拟按键 printscreen 的指定，然后弊铅银再保存起来

发送指定要用API

Answer 4

换一种方式保存