将图像裁取为圆形、菱形等形状的代码

新建一个窗体,添加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。