■当前位置：首页 > VB 小程序 > 消除旋转图像的锯齿现象

　 　 　 73.消除旋转图像的锯齿现象

　　本程序是我编写的小程序 将图像快速旋转任意角度 的改进，可将一幅图像按任意指定的角度旋转，并可以在一定程度上消除旋转图像的锯齿现象。
　　任意角度旋转图像，不论用控件的 PSet 方法，还是用 API 函数 PlgBlt 和 SetBitmapBits，不可避免的都会产生程度不同的锯齿现象，如下面图 1 中人物脸部轮廓、图像边界等轮廓线分明的地方，就有明显的锯齿现象。
　　本程序尝试用编程消除旋转图像后产生的锯齿现象，具体方法是：先用 SetBitmapBits 获取图像每个像素的颜色值，然后分别将旋转后的像素坐标 x,y 转变为旋转前的坐标 x1,y1 ,再从源图像 x1,y1 处及其相邻点按比例取得颜色值赋值给 x,y 点。例如旋转后的坐标是（5,6），转变为旋转前的坐标假定为（4.2 , 5.7）,在源图像上，x 方向分别在点（4,5）和（5,5）各取 80% 和 20%，y 方向分别在点（4,5）和（4,6）各取 30% 和 70%，横纵两个方向平均后就将其设置为目的图像（5,6）点的颜色值。取值示意图如下:
http://s4/middle/b1879bb4x7a865e0aaf03&690代码VB小程序：消除旋转图像的锯齿现象" TITLE="VB 代码VB小程序：消除旋转图像的锯齿现象" />


　　下面是旋转角度 20 度时不勾选和勾选“消除锯齿现象”的比较图，锯齿现象得到了明显改善：
http://s5/middle/b1879bb4xc93fac6ae774&690代码VB小程序：消除旋转图像的锯齿现象" TITLE="VB 代码VB小程序：消除旋转图像的锯齿现象" />

http://s6/middle/b1879bb4xc93fac773275&690代码VB小程序：消除旋转图像的锯齿现象" TITLE="VB 代码VB小程序：消除旋转图像的锯齿现象" />

当然，要完全消除锯齿现象，恐怕只有专业的制图软件能完全做到了。
' '下面是窗体代码，在 VB6 调试通过
'需在窗体放置以下 8 个控件，所有控件不必设置任何属性（包括位置和大小），全部采用默认设置：
'   Command1、Command2、Command3、Label1、Picture1、Text1、Combo1、Check1
'本人原创，转载请注明文章来源：

'百度 http://hi.baidu.com/100bd/blog/item/05643af5230b94fd7709d7e4.html

'新浪 http://blog.sina.com.cn/s/blog_b1879bb401018hc8.html
Private Type BitMap
   bmType As Long         '图像类型：0 表示是位图
   bmWidth As Long        '图像宽度（像素）
   bmHeight As Long       '图像高度（像素）
   bmWidthBytes As Long   '每一行图像的字节数
   bmPlanes As Integer    '图像的图层数
   bmBitsPixel As Integer '图像的位数
   bmBits As Long         '位图的内存指针
End Type
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Private Declare Function SetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Dim ctExit As Boolean, ctWork As Boolean, ctP180 As Single ' As Double

Private Sub Form_Load()
   Me.Caption = "图片旋转-快速"
   Text1.Text = App.Path & "\Tu1.jpg"
   Command1.Caption = "打开": Command2.Caption = "旋转"
   Check1.Caption = "消除锯齿现象": Command3.Caption = "取消"
   Label1.Caption = "旋转角度": Label1.BackStyle = 0
   Me.ScaleMode = 3: Picture1.ScaleMode = 3
   Picture1.AutoSize = True: Picture1.AutoRedraw = True
   Picture1.ToolTipText = "双击恢复原图形"
   
   ctP180 = 4 * Atn(1) '圆周率
   
   For I = -18 To 18
      If I < 0 Then
         Combo1.AddItem I * 10 & " 度"
      Else
         Combo1.AddItem " " & I * 10 & " 度"
      End If
   Next
   Combo1.Text = " 30 度"
   
   '设置控件位置，实际可以在设计窗体时完成
   Dim W1 As Long
   W1 = Me.TextWidth("A")
   Command1.Move W1, W1, W1 * 6, W1 * 3:     Text1.Move W1 * 8, W1, W1 * 80, W1 * 3
   Command2.Move W1, W1 * 5, W1 * 6, W1 * 3: Label1.Move W1 * 8, W1 * 5.5, W1 * 11, W1 * 3
   Combo1.Move W1 * 16, W1 * 5, W1 * 12:     Check1.Move W1 * 30, W1 * 5, W1 * 16, W1 * 3
   Command3.Move W1 * 46, W1 * 5, W1 * 6, W1 * 3
   Picture1.Move W1, W1 * 9, W1 * 40, W1 * 40
   
   Call RndImg(Picture1) '随机画一些图像
End Sub

Private Sub RndImg(Kj As Object)
   '随机画一些图像
   Dim I As Long
   Randomize
   Kj.DrawWidth = 3
   For I = 1 To 100
      Kj.Line (Kj.ScaleWidth * Rnd, Kj.ScaleHeight * Rnd)-Step(50, 50), &HFFFFFF * Rnd, BF
      Kj.Circle (Kj.ScaleWidth * Rnd, Kj.ScaleHeight * Rnd), 30 * Rnd, &HFFFFFF * Rnd
   Next
   Kj.Font.Size = 24: Kj.Font.Bold = True
   Kj.CurrentX = 10: Kj.CurrentY = 10: Kj.ForeColor = &H777777
   Kj.Print Me.Caption
   Kj.CurrentX = 11: Kj.CurrentY = 11: Kj.ForeColor = RGB(0, 110, 110)
   Kj.Print Me.Caption
   Kj.Line (0, 0)-(Kj.ScaleWidth - 1, Kj.ScaleHeight - 1), 255, B
   Kj.DrawWidth = 1:  Picture1.ForeColor = 0 '还原为默认设置
   Picture1.Font.Size = 9: Picture1.Font.Bold = False
   Kj.Picture = Kj.Image
End Sub

Private Sub Command1_Click()
   '打开图片文件
   Dim F As String
   On Error GoTo Err1
   F = Trim(Text1.Text)
   Picture1.Picture = LoadPicture(F)
   Exit Sub
Err1:
   MsgBox "无法读取文件：" & vbCrLf & F, vbInformation
End Sub

Private Sub Combo1_Click()
   Call Command2_Click
End Sub

Private Sub Command2_Click()
   '旋转图片
   Dim W1 As Long, H1 As Long, B1() As Byte, Bs1 As Long, BytesW1 As Long, Ps1 As Long
   Dim W2 As Long, H2 As Long, B2() As Byte, Bs2 As Long, BytesW2 As Long, Ps2 As Long
   Dim S1 As Long, S2 As Long, X As Long, Y As Long, x1 As Single, y1 As Single
   Dim CenX1 As Long, CenY1 As Long, CenX2 As Long, CenY2 As Long
   Dim KjFocus As Control, ToJ As Single, Ci As Long
   Dim IntX As Long, IntY As Long, xBi As Single, yBi As Single
   Dim R As Single, G As Single, B As Single, NoChi As Boolean
   
   ToJ = Val(Combo1.Text)  '旋转角度转弧度
   
   '下面一条语句看似可有可无，实际有两个作用：恢复旋转前控件的原图像和大小
   Picture1.Picture = Picture1.Picture
   If Abs(ToJ * 10 Mod 360) < 1 Then Exit Sub
   ToJ = ToJ / 180 * ctP180  '旋转角度转弧度
   
   Set KjFocus = Me.ActiveControl '记忆具有焦点的控件
   Command1.Enabled = False: Command2.Enabled = False: ctWork = True
   Combo1.Enabled = False: Command3.Enabled = True: Check1.Enabled = False
   NoChi = Check1.Value = 1 '是否消去锯齿现象

   '旋转前图像数据：宽度，高度，颜色数组，总字节数，每行字节数，每像素字节数
   GetBmpDat Picture1, W1, H1, B1, Bs1, BytesW1, Ps1
   CenX1 = Int(W1 * 0.5): CenY1 = Int(H1 * 0.5)       '旋转前的图像中心点
   
   '计算旋转后控件的高度和宽度，要预先设置窗体和图片的 ScaleMode 为 3（像素）
   W2 = Abs(W1 * Cos(ToJ)) + Abs(H1 * Sin(ToJ))  '旋转后：图像宽度
   H2 = Abs(H1 * Cos(ToJ)) + Abs(W1 * Sin(ToJ))  '旋转后：图像高度
   X = Picture1.Width - Picture1.ScaleWidth      '图片框边框：宽度
   Y = Picture1.Height - Picture1.ScaleHeight    '图片框边框：高度
   Picture1.Move Picture1.Left, Picture1.Top, X + W2, Y + H2
   
   '下面的 Picture1.Cls 语句此处的作用主要不是清除图像，而是更新控件
   '的 Image 属性，使调用 GetBmpDat 时能正确取得图像数据
   Picture1.Cls
   Picture1.Line (0, 0)-(W2, H2), &HFFFFFF, BF

   '旋转后图像数据：宽度，高度，颜色数组，总字节数，每行字节数，每像素字节数
   GetBmpDat Picture1, W2, H2, B2, Bs2, BytesW2, Ps2
   CenX2 = Int(W2 * 0.5): CenY2 = Int(H2 * 0.5)       '旋转后：图像中心点

   '显示信息
   Picture1.Font.Size = 9
   Me.Refresh
   
   W1 = W1 - 1: H1 = H1 - 1
   For X = 0 To W2 - 1
   For Y = 0 To H2 - 1
      Zhuan -ToJ, CenX2, CenY2, X, Y, x1, y1           '用 x1,y1 获得旋转前的坐标
      x1 = x1 - CenX2 + CenX1: y1 = y1 - CenY2 + CenY1 '转变为旋转前的坐标
      S2 = XYtoIndex(X, Y, BytesW2, Ps2)    '旋转后：像素点在数组 B2 中的索引
      IntX = Int(x1): IntY = Int(y1)
       
      If NoChi Then '消除锯齿现象
         xBi = x1 - IntX: yBi = y1 - IntY: R = 0: G = 0: B = 0
        
         'X 方向取值
         Hun R, G, B, W1, H1, IntX, IntY + S, 1 - xBi, B1, BytesW1, Ps1
         Hun R, G, B, W1, H1, IntX + 1, IntY + S, xBi, B1, BytesW1, Ps1
        
         'Y 方向取值
         Hun R, G, B, W1, H1, IntX + S, IntY, 1 - yBi, B1, BytesW1, Ps1
         Hun R, G, B, W1, H1, IntX + S, IntY + 1, yBi, B1, BytesW1, Ps1
        
         B2(S2 + 2) = R * 0.5: B2(S2 + 1) = G * 0.5: B2(S2) = B * 0.5
      Else
         If IntX < 0 Or IntX > W1 Or IntY < 0 Or IntY > H1 Then
            B2(S2 + 2) = 255: B2(S2 + 1) = 255: B2(S2) = 255 '超出原图像区域，设为白色
         Else
            S1 = XYtoIndex(IntX, IntY, BytesW1, Ps1)   '旋转前：像素点在数组 B1 中的索引
            B2(S2 + 2) = B1(S1 + 2): B2(S2 + 1) = B1(S1 + 1): B2(S2) = B1(S1) '红绿蓝
         End If
      End If
      
      Ci = Ci + 1
      If Ci > 20000 Then
         Ci = 0
         Picture1.Line (0, 0)-(150, 30), &HFFFFFF, BF
         Picture1.CurrentX = 10: Picture1.CurrentY = 5
         Picture1.Print Format((X * H2 + Y) / (W2 * H2) * 100, "0.0") & "% 处理中..."
         DoEvents
         If ctExit Then Exit Sub
         If Not ctWork Then GoTo OK
      End If
   Next
   Next
   
OK:
   SetBitmapBits Picture1.Image, Bs2, B2(0) '将 Picture1 的图像设置为旋转后的二进数组 B2()
   Command1.Enabled = True: Command2.Enabled = True
   Combo1.Enabled = True: Check1.Enabled = True
   Command3.Enabled = False: ctWork = False
   On Error Resume Next
   KjFocus.SetFocus  '还原具有焦点的控件
End Sub

Private Sub Command3_Click()
   ctWork = False
End Sub

Private Sub Hun(R As Single, G As Single, B As Single, W As Long, H As Long, X As Long, Y As Long, Bi As Single, B1() As Byte, BytesW As Long, Ps As Long)
   Dim S As Long
   If X < 0 Or X > W Or Y < 0 Or Y > H Then
      R = R + Bi * 255: G = G + Bi * 255: B = B + Bi * 255
   Else
      S = XYtoIndex(X, Y, BytesW, Ps)
      R = R + Bi * B1(S + 2): G = G + Bi * B1(S + 1): B = B + Bi * B1(S)
   End If
End Sub

Private Sub GetBmpDat(Kj As Control, W As Long, H As Long, B() As Byte, Bs As Long, BytesW As Long, Ps As Long)
   '获取控件 Kj 的图像数据
   Dim MapInf As BitMap
   
   '如果用 Kj.Image， Ps=4
   '如果用 Kj.Picture，且 Kj.Picture 是读入的磁盘文件，Ps=3，BytesW / W 的结果不是整数？
   GetObject Kj.Image, Len(MapInf), MapInf '用 MapInf 得到 Kj 的图像信息
   
'   GetObject Kj.Picture, Len(MapInf), MapInf
'   S = MapInf.bmPlanes    '图像的图层数
'   d = MapInf.bmBitsPixel '每个像素字节数=图像的位数/8
   
   W = MapInf.bmWidth: H = MapInf.bmHeight '图像宽度、高度（像素）
   BytesW = MapInf.bmWidthBytes            '每行占用字节数
   Ps = BytesW / W                         '每个像素字节数(一般为4)
   Bs = W * Ps * H                         '总字节数=宽度*高度*每个像素字节
   ReDim B(0 To Bs - 1)
   GetBitmapBits Kj.Image, Bs, B(0)        '将 Kj 图像所有像素点的颜色值读入二进数组 B()
End Sub

Private Function XYtoIndex(X As Long, Y As Long, BytesW As Long, Ps As Long) As Long
   '返回图像坐标 x,y 在颜色数组中的序号位置。
   'BytesW：每行图像占用字节数，Ps：每个像素点占用字节数(一般为4)
   XYtoIndex = Y * BytesW + X * Ps
End Function

Private Sub Zhuan(ToJ As Single, x0 As Long, y0 As Long, ByVal X As Long, ByVal Y As Long, x1 As Single, y1 As Single)
   '将点 x,y 围绕 x0,y0 顺时针旋转 ToJ 弧度，用 x1,y1 返回旋转后的位置
   '注意：要预先设置圆周率 ctP180 = 4 * Atn(1)
    Dim S As Single, J As Single
   
    X = X - x0: Y = Y - y0
    S = Sqr(X ^ 2 + Y ^ 2)               'X,Y 与 x0,y0 的距离
    If S = 0 Then J = 0 Else J = Y / S   '与水平线的夹角的正弦值

    If Abs(J) >= 1 Then
       If J > 0 Then J = ctP180 * 0.5 Else J = -ctP180 * 0.5 '90 度时的特殊情况
    Else
       J = Atn(J / Sqr(-J * J + 1)) '与水平线的夹角
    End If
   
    If X < 0 Then J = -ctP180 - J
    x1 = x0 + S * Cos(J + ToJ): y1 = y0 + S * Sin(J + ToJ) '返回旋转后的位置
End Sub

Private Sub Form_Unload(Cancel As Integer)
   ctExit = True
End Sub

Private Sub Picture1_DblClick()
   '下面语句看似可有可无，实际有两个作用：恢复旋转前控件的原图像和大小
   If Not ctWork Then Picture1.Picture = Picture1.Picture
End Sub

■当前位置：首页 > VB 小程序 > 消除旋转图像的锯齿现象