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

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