VB程序员博客

大家好，我上星期发了一个贴，说事“需要设计一个程序，一开始开启windows的画图程序，打开一个直径是360*360像素的空白圆形（用其他画图软件也可以）。当用户在这个圆形内用铅笔或其他工具画完图后保存成BMP文件，现在需要读取保存下来的BMP文件，获取用户所画点的坐标，并保存在txt文件中。”
lyserver大大给出了一个解决方法。
Option Explicit 
Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long 
Private Const ARRAY_SIZE As Long = 129600 

Private Sub Command1_Click() 
    Dim i As Long 
    Dim lpOldBits(1 To ARRAY_SIZE) As Long 
    Dim lpNewBits(1 To ARRAY_SIZE) As Long 
    Dim hCOOR As Long, vCOOR As Long 
     
    GetBitmapBits Me.OldPicture.Picture.Handle, ARRAY_SIZE * 4, lpOldBits(1) 
    GetBitmapBits Me.NewPicture.Picture.Handle, ARRAY_SIZE * 4, lpNewBits(1) 
    For i = 1 To ARRAY_SIZE 
        If lpOldBits(i)   <> lpNewBits(i) Then 
            hCOOR = Fix(i / 360) + 1 
            vCOOR = i Mod 360 
            Debug.Print "坐标位置为" & hCOOR & "行" & vCOOR & "列" 
        End If 
    Next 
End Sub 

Private Sub Form_Load() 
    Me.OldPicture.AutoRedraw = True 
    Me.NewPicture.AutoRedraw = True 
    Set Me.OldPicture.Picture = LoadPicture("d:\旧圆.bmp") 
    Set Me.NewPicture.Picture = LoadPicture("d:\新圆.bmp") 
End Sub 

我试了一下，虽然识别坐标点的速度不是很快，我想应该还是符合了要求，中间有事就没仔细看，今天翻开来看，发现获取的坐标点有问题，比如画了一个图，增加一条直线，

结果出来这样的数据，我觉得这个数据应该是不正确的，如果左下角为（0，0）坐标，这根线的坐标应该是（180，2xx),(180,2xx)…但出来的数据却有点怪，还有我现在想把坐标定为圆形的原点来算出坐标，这个数据又该怎么获取？

11,315,
12,225,
13,135,
14,45,
14,315,
15,225,
16,135,
17,45,
17,315,
18,225,
19,135,
20,45,
20,315,
21,225,
22,135,
23,45,
23,315,
24,225,
25,135,
26,45,
26,315,
27,225,
28,135,
29,45,
29,315,
30,225,
31,135,
32,45,
32,315,
33,225,
34,135,
35,45,
35,315,
36,225,
37,135,
38,45,
38,315,
39,225,
40,135,
41,45,
41,315,
42,225,
43,135,
44,45,
44,315,
45,225,
46,135,

再顶顶

虽然不懂,不过从楼主的例子中也学到了些东西..

为你的区域作一个掩码图来对比不就解决了。
如掩码图黑色部分不处理，白色部分处理

坐标怎么正确获取呢？
掩码图处理是不是速度和精确度都快和高点？

没有看出什么，关注

一个像素RGB占3个字节，用Long（4个字节）明显是不对的。

VBScript code

Option Explicit
Private Type BITMAP
    bmType As Long
    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 Sub Command1_Click()
    Dim i As Long
    Dim PicInfo As BITMAP, BytesPerLine As Long, TotalBytes As Long
    Dim lpOldBits() As Byte
    Dim lpNewBits() As Byte
    Dim x As Long, y As Long

    GetObject Me.OldPicture.Picture, Len(PicInfo), PicInfo
    BytesPerLine = (PicInfo.bmWidth * 3 + 3) And &HFFFFFFFC
    TotalBytes = BytesPerLine * PicInfo.bmHeight * 3

    ReDim lpOldBits(TotalBytes - 1)
    GetBitmapBits Me.OldPicture.Picture.Handle, TotalBytes, lpOldBits(0)
    ReDim lpNewBits(TotalBytes - 1)
    GetBitmapBits Me.NewPicture.Picture.Handle, TotalBytes, lpNewBits(0)

    For i = 0 To TotalBytes - 1 Step 3
        If RGB(lpOldBits(i), lpOldBits(i + 1), lpOldBits(i + 2)) <> _
           RGB(lpNewBits(i), lpNewBits(i + 1), lpNewBits(i + 2)) Then
            y = (i \ BytesPerLine) + 1
            x = ((i Mod BytesPerLine) \ 3) + 1
            Debug.Print x & "," & y
        End If
    Next
End Sub

Private Sub Form_Load()
    Me.OldPicture.AutoRedraw = True
    Me.NewPicture.AutoRedraw = True
    Set Me.OldPicture.Picture = LoadPicture("d:\旧圆.bmp")
    Set Me.NewPicture.Picture = LoadPicture("d:\新圆.bmp")
End Sub

输出为 (180,15) - (180,61)

我后来确实发现坐标计算有问题,原因是真彩色位图有32位色和24位色,在计算前应该使用GetObject API函数判断颜色深度后再计算!

这两天忙,等到下星期一或二再给你完整的代码.

以下是完整的图像比较代码，已成功通过测试。
Option Explicit

Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Type BITMAP '14 bytes
        bmType As Long
        bmWidth As Long
        bmHeight As Long
        bmWidthBytes As Long
        bmPlanes As Integer
        bmBitsPixel As Integer
        bmBits As Long
End Type

'图像比较
Private Sub Command1_Click()
    Dim i As Long
    Dim ARRAY_SIZE As Long
    Dim OldPic As stdole.IPictureDisp
    Dim NewPic As stdole.IPictureDisp
    Dim OldBits() As Byte
    Dim NewBits() As Byte
    Dim hCOOR As Long, vCOOR As Long
    Dim OldPicInfo As BITMAP
    Dim NewPicInfo As BITMAP
    Dim LineWidth As Long
 
    Set OldPic = Me.Controls.Add("VB.PictureBox", "OldPic")
    Set NewPic = Me.Controls.Add("VB.PictureBox", "NewPic")

    Set OldPic = LoadPicture("c:\旧圆.bmp")
    Set NewPic = LoadPicture("c:\新圆.bmp")
    GetObjectAPI OldPic, Len(OldPicInfo), OldPicInfo
    
    LineWidth = OldPicInfo.bmWidthBytes
    ARRAY_SIZE = OldPicInfo.bmHeight * OldPicInfo.bmWidth * 3
    ReDim OldBits(1 To ARRAY_SIZE)
    ReDim NewBits(1 To ARRAY_SIZE)
     
    GetBitmapBits OldPic, ARRAY_SIZE, OldBits(1)
    GetBitmapBits NewPic, ARRAY_SIZE, NewBits(1)
    For i = 1 To ARRAY_SIZE Step 3
        If OldBits(i)  <> NewBits(i) Or OldBits(i + 1)  <> NewBits(i + 1) Or OldBits(i + 2)  <> NewBits(i + 2) Then
            vCOOR = Fix(i / LineWidth)
            hCOOR = IIf((i Mod LineWidth) = 0, LineWidth, (i Mod LineWidth)) / 3
            Debug.Print "坐标位置为" & vCOOR & "行" & hCOOR & "列"
        End If
    Next
    Erase OldBits
    Erase NewBits
    Set OldPic = Nothing
    Set NewPic = Nothing
End Sub

Private Sub Form_Load()
    Dim Pic As PictureBox
    
    Me.ScaleMode = vbPixels
    Set Pic = Me.Controls.Add("VB.PictureBox", "Pic1")
    Pic.ScaleMode = vbPixels
    Pic.BorderStyle = 0
    Pic.Appearance = 0
    Pic.Move 0, 0, 101, 101
    Pic.AutoRedraw = True
    Pic.Circle (Pic.ScaleWidth \ 2, Pic.ScaleWidth \ 2), Pic.ScaleWidth \ 2 '画一个正圆
    SavePicture Pic.Image, "c:\旧圆.bmp"   '保存空白圆
    Pic.Line (0, 0)-(20, 0) '从(0,0)到(20,0)画一条水平直线,终端点(0,20)被Line忽略
    Pic.Line (10, 10)-(20, 20) '从(10,10)到(20,20)画一第斜线,终端点(20,20)被Line忽略
    Pic.PSet (99, 99) '在坐标点(99,99)画一个点
    SavePicture Pic.Image, "c:\新圆.bmp"
    Me.Controls.Remove "Pic1"
End Sub

收好 再慢慢研究 谢谢了！

标签: 坐标, 画图