| رەسىمگە تامغا بېسىش پىروگىراممىسى ئەسلى كودى
ئادەتتە تور بېكەتلەردە رەسىم ھۆججەتلىرىگە ئۆز تور بېكىتىنىڭ لوگو رەسىمىنى تامغا قىلىپ بېسۋالغانلىقىنى كۈرىمىز ،خەنزۇچىدە بۇنى (水印) دەپ ئاتايدۇ .تۆۋەندىكى پىروگىرامما كودى بولسا vb ئارقىلىق شۇ خىل ئىقتىدارنى ئەمەلگە ئاشۇرۇش كودى .
قەدەم باسقۇچلىرى :
vb دا يېڭى كۆزنەكتىن بىرنى قۇرۇپ كۆزنەك ئۈستىگە pictrebox دىن 3 نى .command تىن 2 نى قۇرىمىز .
ئاندىن pictrebox نىڭ خاسلىقلىرىنى تۆۋەندىكىدەك تەڭشەيمىز:
1.ScaleMode خاسلىقىنى 3 قىلىپ تەڭشەيمىز .رولى .ئوبىكىتنىڭ چوڭ-چىكىكلىكىنىڭ بىرلىكىنى بەلگىلەيدۇ .3 پىكسىل بۇيىچە بۇلىدىغانلىقىنى ئىپادىلەيدۇ .
2.AutoRedraw خاسلىقىنى true قىلىپ تەڭشەيمىز. رولى :تامغا قۇيۇلغان يېڭى رەسىمنى ئۇزۇنغىچە ساقلاش .(ئەگەر بۇ خاسلىقىنى تەڭشىمىسىڭىز تامغا قۇيۇلغان رەسىم ھاسىل بۇلۇپلا يوقاپ كىتىدۇ )
3.Picture1 ۋە Picture2 لەرگە ئايرىم ئايرىم خالىغان رەسىم ھۆججىتىدىن بىردىن كىرگۈزۈڭ .Picture1 گە سەل چوڭاراق رەسىمنى Picture2 گە سەل كىچىكرەك رەسىمنى كىرگۈزۈڭ ،چۈنكى بىز دەل Picture2 دىكى رەسىمنى Picture1 نى ئۈستىگە تامغا شەكلىدە چىقىرىمىز .بولمىسا ھاسىل بولغان رەسىم كۈرۈمسىز چىقىپ قالىدۇ .
ئاندىن تۆۋەندىكى كودنى كود يىزىش رايۇنىغا كۈچۈرۈپ چاپلاڭ:- Private Declare Function SetPixelV 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() '加水印图像
- Dim transparence As Integer '水印透明度
- Dim x1 As Integer, y1 As Integer '水印图取点坐标
- Dim x2 As Integer, y2 As Integer '背景图上的水印位置坐标
- Dim c As Long
- Dim r1 As Integer, g1 As Integer, b1 As Integer
- Dim r2 As Integer, g2 As Integer, b2 As Integer
- transparence = 30 '此值在 10-90 之间，越大越透明
- y2 = (Picture1.Height - Picture2.Height) / 15 - 20
- For y1 = 0 To Picture2.ScaleHeight - 1
- x2 = (Picture1.Width - Picture2.Width) / 15 - 20
- For x1 = 0 To Picture2.ScaleWidth - 1
-
- c = GetPixel(Picture2.hdc, x1, y1) '从水印图像取点
- r1 = c Mod 256
- g1 = c \ 256 Mod 256
- b1 = c \ 256 \ 256
-
- c = GetPixel(Picture1.hdc, x2, y2) '从背景图像取点
- r2 = c Mod 256
- g2 = c \ 256 Mod 256
- b2 = c \ 256 \ 256
-
- r1 = r1 - transparence * (r1 - r2) / 100
- g1 = g1 - transparence * (g1 - g2) / 100
- b1 = b1 - transparence * (b1 - b2) / 100
- SetPixelV Picture1.hdc, x2, y2, RGB(r1, g1, b1)
- x2 = x2 + 1
- Next
- y2 = y2 + 1
- Next
- Picture1.Refresh
- End Sub
- Private Sub Command2_Click() '加水印字符
- Dim transparence As Integer '水印透明度
- Dim x1 As Integer, y1 As Integer '水印字符图取点坐标
- Dim x2 As Integer, y2 As Integer '背景图上的水印位置坐标
- Dim c1 As Long, c2 As Long
- Dim r1 As Integer, g1 As Integer, b1 As Integer
- Dim r2 As Integer, g2 As Integer, b2 As Integer
- Dim st As String
- transparence = 10
- y2 = (Picture1.Height - Picture3.Height) / 15 - 20
- st = "火花网站欢迎你！" '水印文字
- c2 = vbWhite '文字颜色
- With Picture3
- .FontSize = 14
- .FontBold = True
- .ForeColor = c2
- .Width = .TextWidth(st) * 15 + 60
- .Height = .TextHeight(st) * 15 + 60
- .Cls
- Picture3.Print st
- .Refresh
- End With
- For y1 = 0 To Picture3.ScaleHeight - 1
- x2 = (Picture1.Width - Picture3.Width) / 15 - 20
- For x1 = 0 To Picture3.ScaleWidth - 1
- c1 = GetPixel(Picture3.hdc, x1, y1) '从水印字符图取点
- If c1 = c2 Then
- r1 = c1 Mod 256
- g1 = c1 \ 256 Mod 256
- b1 = c1 \ 256 \ 256
-
- c1 = GetPixel(Picture1.hdc, x2, y2) '从背景图像取点
- r2 = c1 Mod 256
- g2 = c1 \ 256 Mod 256
- b2 = c1 \ 256 \ 256
-
- r1 = r1 - transparence * (r1 - r2) / 100
- g1 = g1 - transparence * (g1 - g2) / 100
- b1 = b1 - transparence * (b1 - b2) / 100
- SetPixelV Picture1.hdc, x2, y2, RGB(r1, g1, b1)
- End If
- x2 = x2 + 1
- Next
- y2 = y2 + 1
- Next
- Picture1.Refresh
- End Sub
تاما قۇيۇلدىغان رەسىم ۋە خەتنىڭ سۈزۈكلىك دەرىجىسىنى command1-click ۋە command2-click دىكى transparence دىگەن ئۆزگەرگۈچى مىقدارنىڭ قىممىتىنى ئۆزگەرتىش ئارقىلىق تەڭشىگىلى بۇلىدۇ .
كود ئارىسىدا ئىزاھات بار ،شۇلارغا ئاساسەن بۇ كودلارنىڭ مەنىسى ۋە رولىنى چۈشىنۋالساڭلار بۇلىدۇ . |
|
شۆھرەت
تۆھپە
تىللا
قىزغىنلىق
ۋاقتى: 2011-9-12 22:02:22
ۋاقتى: 2011-9-13 11:20:31
