回 帖 发 新 帖 刷新版面

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

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

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

回复列表 (共3个回复)

沙发

HSK Weldassistant SMART Edition 8.1.7.1633 焊接工艺规范生成软件
Engissol 2D Frame Analysis Dynamic Edition v4.9 2D框架结构分析软件

ESI SimulationX Pro 4.1.1.63427 多物理系统模拟软件
 InventorCAM.2019.SP2.HF7.Win64 1DVD

 Siemens.Simcenter.FloEFD.2019.3.0.v4745.NX.Win64 1CD

 Siemens.Simcenter.Nastran.2020.1-1899.Linux64 1DVD

 Siemens.Simcenter.Nastran.2020.1-1899.Win64 1DVD

 SolidCAM.2019.SP2.HF6.Win64 1DVD
CAMWorks.ShopFloor.2020.SP0.0.0.Win64 1DVD

 DICAD.Strakon.Premium.2019.SP1.Patch3.Win64 1DVD

 Geometric NestingWorks 2020 SP0 for SolidWorks 2018-2020 1CD

 Golden.Software.Voxler.v4.6.913.Win32_64 1CD

 PSS Adept v5.16 1CD

 PSS E v33.4.0 1CD

 Rhinoceros 6.21.19351.09141 Win64 1CD
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 
+                                                                
+ 长期有效,需要联系: 

+   电 话(TEL):18980583122 可以加微信
 
+ QQ:120991156

+请 按 Clrt+F 查找, 输入 具体 关键字 查询(不要全部输入)  
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 

 Altair Inspire Studio 2019.3.1 Build 10173 Win64 1DVD

 Siemens Simcenter Amesim 2019.2 Win64 & Linux64 2DVD

 Siemens Star CCM+ 2019.3.1 (14.06.013-R8 double precision) Win64 1DVD

 Siemens Star CCM+ 2019.3.1 (14.06.013-R8 double precision) Linux64 1DVD

2019.12.17

 Altium Nexus 3.0.9 Build 80 Win64 1DVD

 Altium NEXUS Server 1.1.4.125 Win64 1CD

 DICAD Strakon Premium v2019 SP1 .3.4 (Patch 3) 1DVD

 Engissol.2D.Frame.Analysis.Dynamic.Edition.v4.9 1CD

 FlexLogger 2020 R1 Multilanguage Win64 1DVD

 SAS JMP Pro 14.3.0 2DVD

2019.12.15

 Golden.Software.Voxler.v4.6.913.Win32_64 1CD

 Altair Inspire Studio 2019.3.1 Build 10173 Win64 1DVD

2019.12.14

 Artlantis 2020 v9.0.2.21017 Multilingual Win64 1CD

 Artlantis 2020 v9.0.2.21201 MacOSX 1DVD

 BETA.CAE.Systems.V19.1.5.Win64 1DVD

 CSI ETABS Ultimate 18.1.0 Win64 1DVD

 MestReNova v14.1.1 1CD

 Motor-CAD.v12.1.23.Win32 1CD

2019.12.13

 ESI SimulationX v4.1.1.63427 Win32_64 1DVD

2019.12,12

 ESKO Automation Engine(AE) v18.1.1 1DVD

2019.12.11

 PTC.Arbortext.Editor.7.1.M060.Win64 1DVD

 PTC.Arbortext.Publishing.Engine.7.1.M060.Win64 1CD

 PTC.Creo.Illustrate.6.1.0.0.Win64 1CD

 PTC.Creo.View.6.1.0.0.Win64.&.Linux64 2DVD+2CD


ESKO Automation Engine(AE) v18.1.1 1DVD


板凳

感谢分享proyty1@donotsendemailtome.com
proyty2@donotsendemailtome.com
proyty3@donotsendemailtome.com
proyty4@donotsendemailtome.com
proyty5@donotsendemailtome.com
moteye1@donotsendemailtome.com
moteye2@donotsendemailtome.com
moteye3@donotsendemailtome.com
moteye4@donotsendemailtome.com
moteye5@donotsendemailtome.com
youpro1@donotsendemailtome.com
youpro2@donotsendemailtome.com
youpro3@donotsendemailtome.com
youpro4@donotsendemailtome.com
youpro5@donotsendemailtome.com
havece1@donotsendemailtome.com
havece2@donotsendemailtome.com
havece3@donotsendemailtome.com
havece4@donotsendemailtome.com
havece5@donotsendemailtome.com
danror1@donotsendemailtome.com
danror2@donotsendemailtome.com
danror3@donotsendemailtome.com
danror4@donotsendemailtome.com
danror5@donotsendemailtome.com

我来回复

您尚未登录,请登录后再回复。点此登录或注册