VB实现马赛克

学了2个月的VB做的,请高手给点意见.



Option Explicit

Dim x, x1, y, y1, h, w

Dim choicedfile As String

Dim mark As Boolean  '定义i, mark为窗体级布尔型变量mark为是否进行局部马赛克标记

Const A1 = 5

Dim mX As Integer, mY As Integer  '存放鼠标在屏幕上的当前坐标

Dim color As Long  '定义color为窗体级长整型变量

Dim r As Integer, g As Integer, b As Integer  'r,g,b为三原色值

Dim starttime As Date, endtime As Date, spendtime As Date

Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long

Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long



 



Private Sub Command1_Click() '打开文件

On Error GoTo err

CommonDialog1.Filter = "所有文件|*.*|jpeg文件|*.jpg|bmp文件|*.bmp|gif文件|*.gif|ico文件|*.ico|wmf文件|*.wmf|dib文件|*.dib|cur文件|*.cur"



'设置所选文件类型



CommonDialog1.DialogTitle = "打开"  '将通用对话框标题设置为'打开'



CommonDialog1.FileName = ""  '将通用对话框的文件名置空



CommonDialog1.ShowOpen  '打开“打开文件”通用对话框



If CommonDialog1.FileName <> "" Then



 choicedfile = CommonDialog1.FileName  '文件名放入choicedfile变量

 

   '在picture1中装入指定的图象

 

 Picture1.Picture = LoadPicture(choicedfile)

 h = Me.ScaleY(Picture1.Picture.Height, vbHimetric)

 w = Me.ScaleX(Picture1.Picture.Width, vbHimetric)



 Clipboard.Clear  '将剪贴板清空



 Clipboard.SetData Picture1.Picture  '将指定的图象放入剪贴板



 '装入图象放在picture1,clipboard



Else



 Exit Sub



End If



HScroll1.Max = w

VScroll1.Max = h

Command2.Enabled = False

Command5.Enabled = False

Command3.Enabled = True

Command4.Enabled = True

Exit Sub

err:

MsgBox "打开文件类型错误，请核实！", 0 + 48 + 0, "提示"

End Sub



Private Sub command6_Click()  '退出程序



Clipboard.Clear  '将剪贴板清空



End



End Sub



Private Sub command3_Click()



MousePointer = 11  '将鼠标指针设置为沙漏形状



Form1.Picture1.AutoRedraw = True



mosaic Picture1





'调用马赛克函数



Form1.Picture1.AutoRedraw = False



MousePointer = 1  '将鼠标指针设置为箭头形状







Command2.Enabled = True

Command5.Enabled = True

Exit Sub



End Sub



Public Function mosaic(pic As PictureBox)  '马赛克函数



Dim row As Integer, lin As Integer



Dim rl As Integer, ll As Integer



Dim xl As Integer, yl As Integer



Dim k As Integer, j As Integer



Dim x As Integer, y As Integer



'row为马赛克块列数-1，lin为马赛克块行数-1，rl为所余块中的列数，ll为所余块中的行数



Dim color As Long



Dim r As Integer, g As Integer, b As Integer



starttime = Time



row = Int(pic.Width / 2)



lin = Int(pic.Height / 2)



rl = pic.Width \ 10



ll = pic.Height \ 10



For y = 0 To (lin) * 10 Step 10



 For x = 0 To (row) * 10 Step 10



  color = GetPixel(pic.hdc, x + 5, y + 5)



  r = (color Mod 256)



  b = (Int(color / 65536))



  g = Int((color - (b * 65536) - r) / 256)

If y > Picture1.Height Then

  Exit Function

  End If

  For k = 0 To 10



   For j = 0 To 10



    SetPixel pic.hdc, x + k, y + j, RGB(Abs(r), Abs(g), Abs(b))



   Next j



  Next k



   pic.Refresh



   Next x



 If rl <> 0 Then



  xl = pic.ScaleWidth - rl



  color = GetPixel(pic.hdc, xl + rl / 2, y + 7)



  r = (color Mod 256)



  b = (Int(color / 65536))



  g = Int((color - (b * 65536) - r) / 256)



  For k = 0 To rl - 1



   For j = 0 To rl



    SetPixel pic.hdc, xl + k, y + j, RGB(Abs(r), Abs(g), Abs(b))



   Next j



  Next k



  pic.Refresh



 End If



Next y



If ll <> 0 Then



 yl = pic.ScaleHeight - ll



 For x = 0 To (row - 1) * 100 Step 1



  color = GetPixel(pic.hdc, x + 5, yl + 11 / 2)



  r = (color Mod 256)



  b = (Int(color / 65536))



  g = Int((color - (b * 65536) - r) / 256)



  For k = 0 To 50



   For j = 0 To 60 - 1



    SetPixel pic.hdc, x + k, y + j, RGB(Abs(r), Abs(g), Abs(b))



   Next j



  Next k



 pic.Refresh



 Next x







End If



endtime = Time



spendtime = endtime - starttime



End Function



Private Sub command2_Click()  '保存文件



CommonDialog1.Filter = "bmp文件|*.bmp"  '设置保存文件的类型



CommonDialog1.DialogTitle = "保存文件"



'将通用对话框标题设置为'保存文件'



CommonDialog1.FileName = ""  '将通用对话框的文件名置空



CommonDialog1.ShowSave  '打开“保存文件”对话框



CommonDialog1.DefaultExt = "bmp"  '设置缺省的文件扩展名为bmp



If CommonDialog1.FileName <> "" Then



 choicedfile = CommonDialog1.FileName



 SavePicture Picture1.Image, choicedfile  '按输入的文件名保存文件



Else



 Exit Sub



End If



End Sub



Private Sub command4_Click()  '局部马赛克



If mark = False Then



 mark = True



 'mark为进行局部马赛克的标记,为真进行局部马赛克处理,为假则不处理







Else



 mark = False  '关闭局部马赛克功能

 Picture1.AutoRedraw = False

 

End If

End Sub



Private Sub picture1_click()  '在图象中单击鼠标处进行局部马赛克

Dim il As Integer, jj As Integer

Dim r As Long, g As Long, b As Long

Dim aa As Long

Dim imagepixels(2, 2 * A1, 2 * A1) As Integer

If Picture1.Picture = 0 Then

    MsgBox ("请加载一个图片")

    Exit Sub

End If

If mark = True Then

 Picture1.AutoRedraw = True

For il = mY - A1 To mY + A1

For jj = mX - A1 To mX + A1

  aa = GetPixel(Picture1.hdc, il + 100, jj + 100)

  r = (aa Mod 256)



  b = (Int(aa / 65536))



  g = Int((aa - (b * 65536) - r) / 256)

  imagepixels(0, jj - mX + A1, il - mY + A1) = r          '分别存储像素点的ＧＲＢ值

  imagepixels(1, jj - mX + A1, il - mY + A1) = g

  imagepixels(2, jj - mX + A1, il - mY + A1) = b

Next

Next



r = 0

g = 0

b = 0

For il = 0 To 2 * A1 - 1

  For jj = 0 To 2 * A1 - 1

      r = r + imagepixels(0, jj, il)

      g = g + imagepixels(1, jj, il)

      b = b + imagepixels(2, jj, il)

   Next

Next

   

r = Int(r / (2 * A1) ^ 2)                      '求小方块所有像素点的平均值

g = Int(g / (2 * A1) ^ 2)

b = Int(b / (2 * A1) ^ 2)



For il = mY - A1 To mY + A1 / 2

For jj = mX - A1 To mX + A1 / 2

  Picture1.PSet (jj, il), RGB(r, g, b)

Next

Next

End If

End Sub



Private Sub command5_Click()  '复位



Picture1.Picture = Clipboard.GetData  '将剪贴板中保存的图象装入picture1



HScroll1.Max = w





VScroll1.Max = h







End Sub



 



Private Sub Form_Load()  '窗体的初始位置



Command2.Enabled = False

Command3.Enabled = False

Command4.Enabled = False

Command5.Enabled = False

End Sub



Private Sub hscroll1_Change()  '水平滚动条



Picture1.Left = -(HScroll1.Value \ 2)



End Sub







Private Sub picture1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)

    '设置当前位置

mX = x

mY = y

Text1 = mX

Text2 = mY

If mark = True Then

Command2.Enabled = True

Command5.Enabled = True

End If

End Sub





Private Sub vscroll1_Change()  '垂直滚动条



Picture1.Top = -(VScroll1.Value \ 2)



End Sub



Private Sub exitm_Click()

Clipboard.Clear



End

End Sub

--------------------编程问答-------------------- 效果还不是很好,请高手指点下 --------------------编程问答-------------------- 速度不好，算法也没优化

用ＶＢ做这东西，还是得用模拟指针．

马赛克是最简单的滤镜．至于速度和效果可参考　

http://www.vbgood.com/viewthread.php?tid=44464&extra=page%3D1&page=35 --------------------编程问答-------------------- 哦
好的谢谢了
我在试着优化下算法 --------------------编程问答-------------------- 你有想关的代码吗?/
下了文件
但是运行不了

--------------------编程问答-------------------- LZ好！小弟看啦代码！但是对具体的算法不是很明白,希望楼主能给我说说具体的算法！~急用~~~谢谢！~本人正在做马赛克的课设！~对算法不是很理解！ --------------------编程问答-------------------- 马赛克，没那么复杂吧！就写随机图像块，二三十行就搞定了。 --------------------编程问答-------------------- 请各位帮忙说说算法！正文得写十页以上啊马赛克的素材在网上不是很多！~~~本人对VB基本不太会！只是学过点！~还是选修！

补充：VB ,  基础类