主题:将图像裁取为圆形、菱形等形状的代码
将图像裁取为圆形、菱形等形状的代码
新建一个窗体,添加2个图片框(改名为pic3和pic4,因为我的程序中就是这个名,懒得再改了),窗体和图片框的ScaleMode属性均设置为3,图片框的AutoRedraw属性设置为True。
再在窗体上添加5个按纽,按纽的Caption分别为:矩形裁取、圆形裁取、菱形裁取、平行四边形裁取、三角形裁取。并将它们做成控件数组,Index值从1—5。
在pic3图片框上放置1个Shape控件和4个Line控件,这5个控件和pic4均设置为不可见。
使用时,在pic3加载图片后,先点击相应的按纽,再按下鼠标(鼠标尖处为隐形框左上角的坐标),然后移动鼠标拉出相应的形状,松开鼠标后就只显示形状内的图像,形状外空间被画框背景色填充。最终画框大小=隐形框大小,且裁取的图像还可粘贴到别的程序。
代码如下:
Option Explicit
Dim clippingMode As Integer '裁取方式
Dim editX As Long, editY As Long '隐形方框左上角坐标
Private Sub Command_Click(Index As Integer)
clippingMode = Index
End Sub
Private Sub Pic3_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
editX = X: editY = Y
If clippingMode Then '如果是裁取
Select Case clippingMode
Case 1
Shape1.Shape = 0: Shape1.Visible = True
Pic3.MousePointer = 2
Case 2
Shape1.Shape = 2: Shape1.Visible = True
Case 3
Shape1.Shape = 0
Line1.Visible = True: Line2.Visible = True: Line3.Visible = True: Line4.Visible = True
Case 4
Shape1.Shape = 0
Line1.Visible = True: Line2.Visible = True: Line3.Visible = True: Line4.Visible = True
Case 5
Shape1.Shape = 0
Line1.Visible = True: Line2.Visible = True: Line3.Visible = True
End Select
End If
End Sub
Private Sub Pic3_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If clippingMode Then '如果是裁取
Shape1.Move editX, editY, Abs(X - editX), Abs(Y - editY)
Select Case clippingMode
Case 3 '菱形
Line1.X1 = editX + Shape1.Width \ 2: Line1.Y1 = editY: Line1.X2 = editX: Line1.Y2 = editY + Shape1.Height \ 2
Line2.X1 = Line1.X2: Line2.Y1 = Line1.Y2: Line2.X2 = Line1.X1: Line2.Y2 = editY + Shape1.Height
Line3.X1 = Line2.X2: Line3.Y1 = Line2.Y2: Line3.X2 = editX + Shape1.Width: Line3.Y2 = Line1.Y2
Line4.X1 = Line3.X2: Line4.Y1 = Line3.Y2: Line4.X2 = Line1.X1: Line4.Y2 = Line1.Y1
Case 4 '平行四边形
Line1.X1 = editX: Line1.Y1 = editY: Line1.X2 = editX + Shape1.Width * 2 \ 3: Line1.Y2 = editY
Line2.X1 = Line1.X2: Line2.Y1 = Line1.Y2: Line2.X2 = editX + Shape1.Width: Line2.Y2 = editY + Shape1.Height
Line3.X1 = Line2.X2: Line3.Y1 = Line2.Y2: Line3.X2 = editX + Shape1.Width \ 3: Line3.Y2 = Line2.Y2
Line4.X1 = Line3.X2: Line4.Y1 = Line3.Y2: Line4.X2 = Line1.X1: Line4.Y2 = Line1.Y1
Case 5 '三角形
Line1.X1 = editX + Shape1.Width \ 2: Line1.Y1 = editY: Line1.X2 = editX: Line1.Y2 = editY + Shape1.Height
Line2.X1 = Line1.X2: Line2.Y1 = Line1.Y2: Line2.X2 = editX + Shape1.Width: Line2.Y2 = Line1.Y2
Line3.X1 = Line2.X2: Line3.Y1 = Line2.Y2: Line3.X2 = Line1.X1: Line3.Y2 = Line1.Y1
End Select
End If
End Sub
Private Sub Pic3_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If clippingMode Then '如果是裁取
If Pic3 Then '如果pic3已经加载了图像
Pic4.Move Pic4.Left, Pic4.Top, Shape1.Width, Shape1.Height
Pic4.PaintPicture Pic3, 0, 0, , , editX, editY, Shape1.Width, Shape1.Height
If clippingMode > 1 Then 形状裁取 clippingMode, X, Y
Pic4.Picture = Pic4.Image
Clipboard.SetData Pic4.Picture '设置剪贴板
Pic3.Picture = LoadPicture()
Pic3.PaintPicture Pic4, 0, 0, Shape1.Width, Shape1.Height
Pic3.Move (Me.ScaleWidth - Shape1.Width) / 2, (Me.ScaleHeight - Shape1.Height) / 2, Shape1.Width, Shape1.Height
End If
Line1.Visible = False: Line2.Visible = False: Line3.Visible = False: Line4.Visible = False
Shape1.Visible = False
clippingMode = 0
Pic3.MousePointer = 0
End If
End Sub
Private Sub 形状裁取(Index As Integer, X As Single, Y As Single)
Dim j As Long, k As Long, w As Long, h As Long, ColorUse As Long
w = Pic4.Width: h = Pic4.Height
ColorUse = vbRed
Select Case Index
Case 2 '圆形
If w > h Then
Pic4.Circle ((X - editX) / 2, (Y - editY) / 2), w / 2, ColorUse, , , h / w
Else
Pic4.Circle ((X - editX) / 2, (Y - editY) / 2), h / 2, ColorUse, , , h / w
End If
Case 3 '菱形
Pic4.CurrentX = w \ 2 '确定第一线的起始坐标
Pic4.CurrentY = 0
Pic4.Line -(0, h \ 2), ColorUse
Pic4.Line -(w \ 2, h), ColorUse
Pic4.Line -(w, h \ 2), ColorUse
Pic4.Line -(w \ 2, 0), ColorUse
Case 4 '平行四边形
Pic4.CurrentX = 0 '确定第一线的起始坐标
Pic4.CurrentY = 0
Pic4.Line -(w * 2 \ 3, 0), ColorUse
Pic4.Line -(w, h), ColorUse
Pic4.Line -(w \ 3, h), ColorUse
Pic4.Line -(0, 0), ColorUse
Case 5 '三角形
Pic4.CurrentX = w \ 2 '确定第一线的起始坐标
Pic4.CurrentY = 0
Pic4.Line -(0, h), ColorUse
Pic4.Line -(w, h), ColorUse
Pic4.Line -(w \ 2, 0), ColorUse
End Select
For j = 0 To h \ 2
For k = 0 To w \ 2
If Pic4.Point(k, j) = ColorUse Then
Pic4.Line (0, j)-(k - 1, j), Pic3.BackColor
Exit For
End If
Next
Next
For j = h \ 2 To h - 1
For k = 0 To w \ 2
If Pic4.Point(k, j) = ColorUse Then
Pic4.Line (0, j)-(k, j), Pic3.BackColor
Exit For
End If
Next
Next
For j = 0 To h \ 2
For k = w \ 2 To w
If Pic4.Point(k, j) = ColorUse Then
Pic4.Line (k + 1, j)-(w, j), Pic3.BackColor
Exit For
End If
Next
Next
For j = h \ 2 To h - 1
For k = w \ 2 To w
If Pic4.Point(k, j) = ColorUse Then
Pic4.Line (k + 1, j)-(w, j), Pic3.BackColor
Exit For
End If
Next
Next
End Sub
提示:示例程序可到163信箱去下载,帐号是:vb62013,密码是:vb620132013。