■当前位置：首页 > VB 小程序 > 将图像快速旋转任意角度

　 　 　 61. 将图像快速旋转任意角度

　　本程序是我编写的小程序 用VB将图片旋转任意角度 的改进，可将一幅图像按任意指定的角度旋转，旋转方式抛弃了用控件的 Point 和 PSet 的方法，改用调用 API 函数 GetBitmapBits 和 SetBitmapBits，通过操作二进数组的方式旋转图像，旋转速度非常快，至少比原程序快十倍以上。
　　程序运行效果截图如下：
http://s3/middle/b1879bb4xc93fac595112&690

http://s7/middle/b1879bb4xfdc7cbb40426&690


' '下面是窗体代码，在 VB6 调试通过
'需在窗体放置以下 6 个控件，所有控件不必设置任何属性（包括位置和大小），全部采用默认设置：
'   Command1、Command2、Label1、Picture1、Text1、Combo1
'本人原创，转载请注明出处：

'百度 http://hi.baidu.com/100bd/blog/item/400ce7c90c6cc7057e3e6fa0.html
'新浪 http://blog.sina.com.cn/s/blog_b1879bb401018hbo.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 ctP180 As Double

Private Sub Form_Load()
   Me.Caption = "图片旋转-快速"
   Text1.Text = App.Path & "\Tu1.jpg"
   Command1.Caption = "打开": Command2.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
   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 Long, y1 As Long
   Dim CenX1 As Long, CenY1 As Long, CenX2 As Long, CenY2 As Long
   Dim KjFocus As Control, ToJ As Single
   
   ToJ = Val(Combo1.Text) / 180 * ctP180 '旋转角度转弧度
   
   Set KjFocus = Me.ActiveControl '记忆具有焦点的控件
   Command1.Enabled = False: Command2.Enabled = False: Combo1.Enabled = False
   
   '下面一条语句看似可有可无，实际有两个作用：恢复旋转前控件的原图像和大小
   Picture1.Picture = Picture1.Picture
   
   '旋转前图像数据：宽度，高度，颜色数组，总字节数，每行字节数，每像素字节数
   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.CurrentX = 5: Picture1.CurrentY = 5
   Picture1.Print "处理中，请稍候..."
   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 中的索引
      If x1 < 0 Or x1 > W1 Or y1 < 0 Or y1 > H1 Then
         B2(S2 + 2) = 255: B2(S2 + 1) = 255: B2(S2) = 255 '超出原图像区域，设为白色
      Else
         S1 = XYtoIndex(x1, y1, BytesW1, Ps1)  '旋转前：像素点在数组 B1 中的索引
         B2(S2 + 2) = B1(S1 + 2): B2(S2 + 1) = B1(S1 + 1): B2(S2) = B1(S1) '红绿蓝
      End If
   Next
   Next
   
   SetBitmapBits Picture1.Image, Bs2, B2(0) '将 Picture1 的图像设置为旋转后的二进数组 B2()
   Command1.Enabled = True: Command2.Enabled = True: Combo1.Enabled = True
   On Error Resume Next
   KjFocus.SetFocus  '还原具有焦点的控件
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
   GetObject Kj.Image, Len(MapInf), MapInf '用 MapInf 得到 Kj 的图像信息
   W = MapInf.bmWidth: H = MapInf.bmHeight '图像宽度、高度（像素）
   BytesW = MapInf.bmWidthBytes            '每行占用字节数
   Ps = BytesW \ W                         '每个像素字节数(一般为4)
   Bs = W * H * Ps                         '总字节数=宽度*高度*每个像素字节
   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 Long, y1 As Long)
   '将点 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 Picture1_DblClick()
   '下面语句看似可有可无，实际有两个作用：恢复旋转前控件的原图像和大小
   Picture1.Picture = Picture1.Picture
End Sub

'后记：用 PlgBlt 旋转图像比本文的方法还快，几乎可以说是瞬间就完成了图像的旋转和变形。玩过祖玛游戏的朋友一定会对那个随鼠标转圈的蛤蟆印象深刻，PlgBlt 就能达到相同的效果。PlgBlt 的功能是：将源对象指定矩形区域的图像复制到目标对象的一个平行四边形区域内，通过设置放置区的平行四边形的四个点，可实现图像的扭曲、翻转、放大、缩小、任意角度旋转等功能。见：用 PlgBlt 将图像快速任意旋转和变形(是目前vb中旋转图像最快的方法)

■当前位置：首页 > VB 小程序 > 将图像快速旋转任意角度