局部放大据我所知没有现成的函数,除了 BITBLT以下是不用 API 实现的方法:==============================
'''新建工程,放入一个 label ,2 个 picturebox
''' copy 代码运行:
Option ExplicitDim Flag As Boolean '拖动标志
Dim oldx, oldx1, oldy1, oldy As Double '记录原来的坐标Private Sub Form_Load()
Picture2.Move 0, 0, Me.Width, Me.Height
Set Label1.Container = Picture2
Set Picture2.Picture = LoadPicture("C:\Documents and Settings\wxy\My Documents\My Pictures\样品.jpg")
Label1.Caption = ""
Label1.Move 0, 0, 1000, 1000
Label1.BackStyle = 0
Label1.BorderStyle = 1
Label1.ToolTipText = "鼠标右击截取图片"
Picture1.Width = Label1.Width * 2 ''这里控制放大倍数
Picture1.Height = Label1.Height * 2
Picture1.Visible = False
Picture1.AutoRedraw = True
End SubPrivate Sub Form_Unload(Cancel As Integer)
End
End SubPrivate Sub Label1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = 1 Then
'开始拖动
Flag = True
'记录下应该绘图的左上角坐标
oldx = Label1.Left
oldy = Label1.Top
'在控件内部的位置
oldx1 = x
oldy1 = y
Picture2.DrawMode = 6
Picture2.DrawStyle = 2
'绘制一个拖动的虚线框
Picture2.Line (oldx, oldy)-(oldx + Label1.Width, oldy + Label1.Height), , B
ElseIf Button = 2 Then
Picture1.Visible = True
Picture1.ZOrder 0
Set Picture1.Picture = LoadPicture("")
Picture1.PaintPicture Picture2.Image, 0, 0, Picture1.Width, Picture1.Height, Label1.Left, Label1.Top, Label1.Width, Label1.Height
MsgBox "图片被保存在 C:\tmp.bmp"
SavePicture Picture1.Image, "C:\tmp.bmp"
End If
End SubPrivate Sub Label1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
If Flag = False Then
Exit Sub
End If
'首先消除原先的边框
Picture2.DrawMode = 6
Picture2.DrawStyle = 2
Picture2.Line (oldx, oldy)-(oldx + Label1.Width, oldy + Label1.Height), , B
'计算新的虚线框位置
oldx = Label1.Left - oldx1 + x
oldy = Label1.Top + y - oldy1
'重新绘制拖动位置
Picture2.Line (oldx, oldy)-(oldx + Label1.Width, oldy + Label1.Height), , BEnd SubPrivate Sub Label1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
If Flag = False Then Exit Sub
'消除最后的边框
Picture2.Line (oldx, oldy)-(oldx + Label1.Width, oldy + Label1.Height), , B
Label1.Move oldx, oldy
'不让控件被别的东西遮住
Label1.ZOrder 0
'不能跑出窗体
If oldx < 0 Then
Label1.Move 0, oldy
oldx = 0
End If
If oldx > (Picture2.ScaleWidth - Label1.Width) Then
Label1.Move Me.ScaleWidth - Label1.Width, oldy
oldx = Me.ScaleWidth - Label1.Width
End If
If oldy < 0 Then
Label1.Move oldx, 0
oldy = 0
End If
If oldy > (Picture2.ScaleHeight - Label1.Height) Then
Label1.Move oldx, Me.ScaleHeight - Label1.Height
oldy = Me.ScaleHeight - Label1.Height
End If
'结束拖动
Flag = FalseEnd Sub
'''新建工程,放入一个 label ,2 个 picturebox
''' copy 代码运行:
Option ExplicitDim Flag As Boolean '拖动标志
Dim oldx, oldx1, oldy1, oldy As Double '记录原来的坐标Private Sub Form_Load()
Picture2.Move 0, 0, Me.Width, Me.Height
Set Label1.Container = Picture2
Set Picture2.Picture = LoadPicture("C:\Documents and Settings\wxy\My Documents\My Pictures\样品.jpg")
Label1.Caption = ""
Label1.Move 0, 0, 1000, 1000
Label1.BackStyle = 0
Label1.BorderStyle = 1
Label1.ToolTipText = "鼠标右击截取图片"
Picture1.Width = Label1.Width * 2 ''这里控制放大倍数
Picture1.Height = Label1.Height * 2
Picture1.Visible = False
Picture1.AutoRedraw = True
End SubPrivate Sub Form_Unload(Cancel As Integer)
End
End SubPrivate Sub Label1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = 1 Then
'开始拖动
Flag = True
'记录下应该绘图的左上角坐标
oldx = Label1.Left
oldy = Label1.Top
'在控件内部的位置
oldx1 = x
oldy1 = y
Picture2.DrawMode = 6
Picture2.DrawStyle = 2
'绘制一个拖动的虚线框
Picture2.Line (oldx, oldy)-(oldx + Label1.Width, oldy + Label1.Height), , B
ElseIf Button = 2 Then
Picture1.Visible = True
Picture1.ZOrder 0
Set Picture1.Picture = LoadPicture("")
Picture1.PaintPicture Picture2.Image, 0, 0, Picture1.Width, Picture1.Height, Label1.Left, Label1.Top, Label1.Width, Label1.Height
MsgBox "图片被保存在 C:\tmp.bmp"
SavePicture Picture1.Image, "C:\tmp.bmp"
End If
End SubPrivate Sub Label1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
If Flag = False Then
Exit Sub
End If
'首先消除原先的边框
Picture2.DrawMode = 6
Picture2.DrawStyle = 2
Picture2.Line (oldx, oldy)-(oldx + Label1.Width, oldy + Label1.Height), , B
'计算新的虚线框位置
oldx = Label1.Left - oldx1 + x
oldy = Label1.Top + y - oldy1
'重新绘制拖动位置
Picture2.Line (oldx, oldy)-(oldx + Label1.Width, oldy + Label1.Height), , BEnd SubPrivate Sub Label1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
If Flag = False Then Exit Sub
'消除最后的边框
Picture2.Line (oldx, oldy)-(oldx + Label1.Width, oldy + Label1.Height), , B
Label1.Move oldx, oldy
'不让控件被别的东西遮住
Label1.ZOrder 0
'不能跑出窗体
If oldx < 0 Then
Label1.Move 0, oldy
oldx = 0
End If
If oldx > (Picture2.ScaleWidth - Label1.Width) Then
Label1.Move Me.ScaleWidth - Label1.Width, oldy
oldx = Me.ScaleWidth - Label1.Width
End If
If oldy < 0 Then
Label1.Move oldx, 0
oldy = 0
End If
If oldy > (Picture2.ScaleHeight - Label1.Height) Then
Label1.Move oldx, Me.ScaleHeight - Label1.Height
oldy = Me.ScaleHeight - Label1.Height
End If
'结束拖动
Flag = FalseEnd Sub
不过,图片的放大已经可以实现了!谢谢!给分
不过,图片的放大已经可以实现了!谢谢!给分