VB程序员博客

我用Teechart画图，横坐标为时间，纵坐标为水位，edit–n内部，这里面的栅格数量，我设置为50，但是并不是等分的，请问该怎么解决？另外，我想让画好的图输出到打印机时，打出来的是我想要的尺寸，例如纵坐标一大格是1cm，该如何解决？请各位高手帮忙，谢谢！

让我消化消化我把teechart.width设置成118,连结打印机打出来的却很大，貌似默认打印是满图打印，这个怎么解决

我用Teechart画图，横坐标为时间，纵坐标为水位，edit–n内部，这里面的栅格数量，我设置为50，但是并不是等分的，请问该怎么解决？另外，我想让画好的图输出到打印机时，打出来的是我想要的尺寸，例如纵坐标一大格是1cm，该如何解决？请各位高手帮忙，谢谢！

让我消化消化我把teechart.width设置成118,连结打印机打出来的却很大，貌似默认打印是满图打印，这个怎么解决

现在有两种方案
第一种是一张一张的把图片保存（savepicture）  撤销的时候读取上一步保存的图片
第二种是用dim tupian（9） as picture
然后
set tupian（n）= picture1.image
撤销的时候读取上一步保存的图片即可

但是有两点疑问
我在用第二种方法时这种数组格式是否能够保存多张图片，会不会只保留最后一张，因为我在用第二种方法处理的时候总是无法得到预期的效果，只能保持现有图片的样子而不能撤销，所以我怀疑保存图像到tupian（5）以后 tupian（4）等以前保存的图片是不是都被tupian（5）覆盖了 也就是说 数组对变量picture有没有效果？

第二点疑问就是 用第一种方法保存图片时 能不能把图片保存到用户文件夹（C:Documents and Settings用户名）的临时文件中 这个用户文件夹的路径可不可以用类似于%system%（系统目录下的system32目录） 或者是当前程序的目录（app.path)等通配符来表示啊

还有这两种方法哪一种更好一些1、第一种方法好些。第I张图片：App.Path & " emp p" & I & ".bmp"
2、使用第二种方法，应该：Dim pic(20) As IPictureDisp
注意保存时，PictureBox控件的属性AutoReDraw=True，保存的是Image。如：
Set pic(I)=Picture1.Image
还原图片时：Set Picture1.Picture=pic(I)Ding…………….
使用图元文件API，可以记录和回放一些GDI绘图动作。通常后退功能用 命令模式 搞定

如:

http://www.google.cn/search?hl=zh-CN&newwindow=1&q=%E5%91%BD%E4%BB%A4%E6%A8%A1%E5%BC%8F+undo&aq=3&oq=%E5%91%BD%E4%BB%A4%E6%A8%A1%E5%BC%8F+

有哪位高手帮帮忙，由于刚学VB，不会熟练运用。我用鼠标事件实现了画图的功能，当我用鼠标画好一个图后，我想在点击一个按钮后怎样才能实现将整个图形向上偏移一段距离呢？我画的图形是由多条线段组成的，我只能实现最后一次画的线向上偏移，怎样才能使所有的图形都偏移呢？

在VB中得出了五个坐标： 500,500
                    710.37,596.34
                    794.22,414.34
                    713.97,187.17
                    475.9,299.8
                    500,500
五个数据在自动生成的记事本里（在VB文本框里也有），请问怎样能自动使这五个坐标输入Autocad，并依次用直线连接起来。最后自动生成并保存图形。

On Error Resume Next                                    '连接AutoCAD
Set AcadApp = GetObject(, "AutoCAD.Application")
If Err Then
Err.Clear
Set AcadApp = CreateObject("AutoCAD.Application")
If Err Then
MsgBox ("不能运行AutoCAD,请检查是否安装了AutoCAD")
Exit Sub
End If
End If
AcadApp.WindowState = acMax
AcadApp.Visible = True
Dim lineobj As AcadLine
Dim startPoint(0 To 2) As Double
Dim endPoint(0 To 2) As Double
startPoint(0) = Val(Text1(0))
startPoint(1) = Val(Text1(1))
startPoint(2) = Val(Text1(2))
endPoint(0) = Val(Text2(0))
endPoint(1) = Val(Text2(1))
endPoint(2) = Val(Text2(2))
Set lineobj = acadDoc.ModelSpace.AddLine(startPoint, endPoint)
End Function
就是画线部分，它告诉我“用户类型未定义”，还有麻烦检查下代码有无问题

加一条代码：
set acadDoc=AcadApp.ActiceDocument
On Error Resume Next                                    '连接AutoCAD
Set AcadApp = GetObject(, "AutoCAD.Application")
If Err Then
Err.Clear
Set AcadApp = CreateObject("AutoCAD.Application")
If Err Then
MsgBox ("不能运行AutoCAD,请检查是否安装了AutoCAD")
Exit Sub
End If
End If
AcadApp.WindowState = acMax
AcadApp.Visible = True
Dim lineobj As AcadLine
set acadDoc=AcadApp.ActiceDocument
Dim startPoint(0 To 2) As Double
Dim endPoint(0 To 2) As Double
startPoint(0) = Val(Text1(0))
startPoint(1) = Val(Text1(1))
startPoint(2) = Val(Text1(2))
endPoint(0) = Val(Text2(0))
endPoint(1) = Val(Text2(1))
endPoint(2) = Val(Text2(2))
Set lineobj = acadDoc.ModelSpace.AddLine(startPoint, endPoint)

还是一样的，在Dim lineobj As AcadLine 处就停住了并说"用户类型未定义"，执行不到set acadDoc=AcadApp.ActiceDocument

一楼说的很清楚
在VB中引用autocad

Private Sub Command1_Click()
Shell ("C:Program FilesAutoCAD 2004acad")
On Error Resume Next                                    '连接AutoCAD
Set AcadApp = GetObject(, "AutoCAD.Application")
If Err Then
Err.Clear
Set AcadApp = CreateObject("AutoCAD.Application")
If Err Then
MsgBox ("不能运行AutoCAD,请检查是否安装了AutoCAD")
Exit Sub
End If
End If
AcadApp.WindowState = acMax
AcadApp.Visible = True
Dim lineobj As AcadLine
Set acadDoc = AcadApp.ActiceDocument
Dim startPoint(0 To 2) As Double
Dim endPoint(0 To 2) As Double
startPoint(0) = Val(Text1(0))
startPoint(1) = Val(Text1(1))
startPoint(2) = Val(Text1(2))
endPoint(0) = Val(Text2(0))
endPoint(1) = Val(Text2(1))
endPoint(2) = Val(Text2(2))
Set lineobj = acadDoc.ModelSpace.AddLine(startPoint, endPoint)
End Sub

这样可以了吧，我开始就调用了AUTOCAD了，还是一样的问题。我的程序界面只有一个Command1,一个text1(2)即三个文本框X坐标，一个text2(2)即三个文本框Y坐标。单击事件的代码就是以上那些，能不能麻烦检查下哪里出错了，为什么一运行就说用户类型未定义。本人初学，不知引用AUTOCAD是什么？

Dim lineobj As AcadLine 请问在VB中没有ACADLINE，怎么用，或者是怎样能使它定义正确。

VB 里面菜单操作.

工程=>引用…
出现对话框

选择 AutoCad 2005 (版本号,我的是2005) 让其打上勾就行了/

哦，在百度上找到了，谢谢。从“工程”菜单中选择“引用”选项，启动“引用”对话框
在“引用”对话框中，选择 AutoCAD 类型库，然后单击“确定”。
原来这个是引用，实在抱歉。

但是我的图形还是不会自己画线，也只是调用了AUtocad。是不是后面的又写错了，请帮帮忙。万分感谢

上面的方法都很好，但如果就这么简单的话，不如这么操作一下
L
710.37,596.34
794.22,414.34
713.97,187.17
475.9,299.8
500,500

你从L复制到本行的上一行（也就是500，500后有两次回车），粘贴到AUTOCAD命令行，你所要的曲线就出来了。

不用做任何引用，你就把这段代码贴到你的程序里，建个COMMAND1按钮，就能打开AUTOCAD

Private Sub Command1_Click()
Set objacad = GetObject("", "autocad.application")
objacad.Visible = True
End Sub

Private Sub Command1_Click()
Dim OBJACAD As Object
Set OBJACAD = GetObject("", "autocad.application")

OBJACAD.Visible = True
End Sub
对不起，得加上上面红色代码

都是我太笨了，实验了很久后终于我明白了，原来是三维的坐标系。现在图是画起了，还有最后一个问题，就是图画起后能不能让它自动保存在某一个地址？例如：D盘。

我有很多不懂的问题是在网友的帮助下解决的，对此我一直心存感激。所以一般我会尽力帮助我能解决的问题。但与此同时我也想说说自己的想法。网友的帮助更多的是一种思路和方法，想学好最好是发挥自己的能动性，多看看代码，多找些资料，多琢磨琢磨，这样才提高的快！对于程序我的想法是先架构功能，程序想实现什么功用，再思考怎么用代码和程序去实现！……
至于楼主最后的问题，还是建议你多看看书吧。有关磁盘和文件操作的资料几乎每本VB的书都有的！

楼上的说得对，我承认。但我没有那么多时间查书了，我刚在网上找了两个多小时都没有找到答案。就差最后一步了，就可怜可怜，告诉我啊。

目前我找到的只有；If MsgBox("") = vbYes Then
acadDoc.Save
Else: ThisWorkbook.Saved = True
End If
这个可以是可以保存了，可是保存在不是我要的路径里。

acadDoc.Saveas "文件名"

vb除了画正规的直线、圆形、长方形有没其他一些图案的代码，比如五角星，红旗等，最好用鼠标画，鼠标一拖拉就出来效果，谢谢各位先了。

国旗制法说明
[编辑本段]
　　（1949年9月28日中国人民政治协商会议第一届全体会议主席团公布）
　　国旗的形状、颜色两面相同，旗上五星两面相对。为便利计，本件仅以旗杆在左之一面为说明之标准。对于旗杆在右之一面，凡本件所称左均应改右，所称右均应改左。
（一）旗面为红色，长方形，其长与高为三与二之比，旗面左上方缀黄色五角星五颗。一星较大，其外接圆直径为旗高十分之三，居左；四星较小，其外接圆直径为旗高十分之一，环拱于大星之右。旗杆套为白色。
（二）五星之位置与画法如下：
　甲、为便于确定五星之位置，先将旗面对分为四个相等的长方形，将左上方之长方形上下划为十等分，左右划为十五等分。
　乙、大五角星的中心点，在该长方形上五下五、左五右十之处。其画法为：以此点为圆心，以三等分为半径作一圆。在此圆周上，定出五个等距离的点，其一点须位于圆之正上方。然后将此五点中各相隔的两点相联，使各成一直线。此五直线所构成之外轮廓线，即为所需之大五角星。五角星之一个角尖正向上方。
　丙、四颗小五角星的中心点，第一点在该长方形上二下八、左十右五之处，第二点在上四下六、左十二右三之处，第三点在上七下三、左十二右三之处，第四点在上九下一、左十右五之处。其画法为：以以上四点为圆心，各以一等分为半径，分别作四个圆。在每个圆上各定出五个等距离的点，其中均须各有一点位于大五角星中心点与以上四个圆心的各联结线上。然后用构成大五角星的同样方法，构成小五角星。此四颗小五角星均各有一个角尖正对大五角星的中心点。
（三）国旗之通用尺度定为如下五种，各界酌情选用：
　甲、长288公分，高192公分。
　乙、长240公分，高160公分。
　丙、长192公分，高128公分。
　丁、长144公分，高96公分。
　戊、长96公分，高64公分。

先谢了楼上朋友了，我希望的是根据鼠标前后点击记取坐标，然后简单画取图形。图案不求很标准，只要新奇好玩就可以，比如一只老鼠，一条鱼，一个简装版的米老鼠等或其他新奇图案。
Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) '记录起始点
    X1 = x
    Y1 = y
End Sub

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  If Button = 1 Then   
  Select Case DongZuo 
            Case "画笔"
                Picture1.Line (X1, Y1)-(x, y)
                X1 = x
                Y1 = y
            Case "划线"
                Line1.X2 = x
                Line1.Y2 = y
                Line1.X1 = X1
                Line1.Y1 = Y1
end sub

Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
Case "线"  Picture1.Line (X1, Y1)-(x, y) '划线
Case "长方形"  Picture1.Line (X1, Y1)-(x, y), , B
end sub

类似于这样。
ps：语言需求，vb6.

顶下

帮顶。

当然可以

请问大哥该怎么做，方便贴代码吗？

比如说我先画好直线，再画矩形
之前画的直线就没有了
怎么改能让之前画的都留在画板上呢？谢谢~~

以下是代码
Dim color1 As Long
Dim a, b As Integer
Dim xx, yy As Integer

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComCtlLib.Button)
    On Error Resume Next
    Select Case Button.Key
      Case "直线"
          Call line_Click
            a = 0
        Case "椭圆"
          Call cycle_Click
            a = 1
        Case "矩形"
          Call rec_Click
            a = 2
        Case "保存"
          Call save_Click
         
        Case "打开"
          Call open_Click
         
        Case "新建"
          Call build_Click
    End Select
End Sub

Private Sub build_Click()
    Set Picture1.Picture = Nothing
    save1 = 0
    Picture1.Top = 480
    Picture1.Left = 1080
    Picture1.Height = 3735
    Picture1.Width = 6255
End Sub

Private Sub command1_Click()
color1 = Command1.BackColor
b = 0
End Sub

Private Sub Command2_Click()
color1 = Command2.BackColor
b = 1
End Sub

Private Sub Command3_Click()
color1 = Command3.BackColor
b = 2
End Sub

Private Sub Command4_Click()
color1 = Command4.BackColor
b = 3
End Sub

Private Sub Command5_Click()
color1 = Command5.BackColor
b = 4
End Sub

Private Sub cycle_Click()
a = 1
End Sub

Private Sub end_Click()
End
End Sub

Private Sub help_Click()
MsgBox "画图程序！"
End Sub

Private Sub Form_Load()
    Command1.Value = True
End Sub

Private Sub line_Click()
a = 0
End Sub

Private Sub open_Click()
On Error Resume Next
    CommonDialog1.CancelError = True
    CommonDialog1.Filter = "图像文件(*.Bmp;*.jpg;*.ico;*.gif) &brvbar*.Bmp;*.jpg;*.ico;*.gif"
    CommonDialog1.Flags = &H200000
    CommonDialog1.ShowOpen
    If Err.Number <> 32755 Then
    Picture1.Picture = LoadPicture(CommonDialog1.FileName)
    End If
End Sub

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  If Button = 1 Then
    If k > 100 Then
    k = 0
    End If
       
    Select Case a
            Case 0
                Picture1.Height = Picture1.Height
                Picture1.Width = Picture1.Width
                Picture1.Picture = Picture1.Image
                xx = X
                yy = Y
            Case 1
                Picture1.Height = Picture1.Height
                Picture1.Width = Picture1.Width
                Picture1.Picture = Picture1.Image
                xx = X
                yy = Y
            Case 2
                Picture1.Height = Picture1.Height
                Picture1.Width = Picture1.Width
                Picture1.Picture = Picture1.Image
                xx = X
                yy = Y
    End Select
  End If
End Sub

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  If Button = 1 Then
    Select Case a
            Case 0
                Picture1.Cls
                Picture1.Picture = Picture1.Image
                Picture1.Line (xx, yy)-(X, Y), color1
         
            Case 1
                Picture1.Cls
                Picture1.Picture = Picture1.Image
                Picture1.Circle (xx, yy), Sqr((X - xx) * (X - xx) + (Y - yy) * (Y - yy)), color1, , , Y / X
            Case 2
                Picture1.Cls
                Picture1.Picture = Picture1.Image
                Picture1.Line (xx, yy)-(X, Y), color1, B
    End Select
  End If
End Sub

Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  If Button = 1 Then
    Select Case a
            Case 0
                Picture1.Picture = Picture1.Image
                Picture1.Line (xx, yy)-(X, Y), color1
            Case 1
                Picture1.Picture = Picture1.Image
                Picture1.Circle (xx, yy), Sqr((X - xx) * (X - xx) + (Y - yy) * (Y - yy)), color1, , , Y / X
            Case 2
                Picture1.Picture = Picture1.Image
                Picture1.Line (xx, yy)-(X, Y), color1, B
    End Select
  End If
End Sub

Private Sub rec_Click()
a = 2
End Sub

Private Sub save_Click()
    On Error Resume Next
    CommonDialog1.CancelError = True
    CommonDialog1.Filter = "Bmp图像文件(*.Bmp) &brvbar*.Bmp &brvbar所有文件(*.*) &brvbar*.*"
    CommonDialog1.Flags = &H200000
    CommonDialog1.ShowSave
    If Err.Number <> 32755 Then
    SavePicture Picture1.Image, CommonDialog1.FileName
    End If
End Sub

Private Sub selcol_Click()
On Error Resume Next
    CommonDialog1.CancelError = True
    CommonDialog1.Flags = &H1 Or &H2
    CommonDialog1.ShowColor
    If Err.Number <> 32755 Then
      Select Case b
              Case 0: Command1.BackColor = CommonDialog1.color
              Case 1: Command2.BackColor = CommonDialog1.color
              Case 2: Command3.BackColor = CommonDialog1.color
              Case 3: Command4.BackColor = CommonDialog1.color
              Case 4: Command5.BackColor = CommonDialog1.color
        End Select
    color1 = CommonDialog1.color
    End If
End Sub

程序中有的变量没有声明，个人觉得设置picture1为autoredraw，然后在保存的时候执行set picture1.picture = picture1.image即可。

设置picture1为autoredraw后，就能留图了
为什么还要在保存的时候执行set picture1.picture = picture1.image？

摘自msdn,看看能否理解，一时不理解也没有关系，大体意思就是说picturebox的内容已经变了，但只有image属性才反应运行时的实时情况，而picture属性仅仅是装载时的依据而已:
=====================
Image 属性
     

返回持久图形的句柄，该句柄由 Microsoft Windows 运行环境提供。

语法

object.Image

object 所在处代表一个对象表达式，其值是“应用于”列表中的一个对象。

说明

对象的 AutoRedraw 属性决定是否用持久图形或通过 Paint 事件重绘对象。 Windows 运行环境通过给对象的持久图形分配一个句柄来标识它；用 Image 属性可以得到该句柄。

Image 值的存在，不受 AutoRedraw 属性设置值的影响。如果 AutoRedraw 为 True，并且还没有绘任何内容，图象仅显示由 BackColor 属性和图片确定的颜色。

可以给 Picture 属性分配 Image 的值。Image 属性还提供了一个传递给 Windows API调用的值。

Image、DragIcon 和 Picture 属性，通常用在给其它属性分配值的情况，如用 SavePicture 语句保存，或在剪贴板上放置一些内容。除图象数据类型外，不能把它们赋给临时变量。

AutoRedraw 属性可以引起 Image 改变，Image 是指向位图的句柄。当 AutoRedraw 为 True 时，对象的 hDC 属性成为指向设备描述体的句柄，该设备描述体包含 Image 返回的位图。

不懂

picturebox.line 的画图速度是不是很慢啊？
    我从串口中（下位机发送）每隔500ms接收一组数据存下来（约500多个），然后用 .line(x1,y1)-(x2,y2)画图，显示不正常，偶尔显示出来了一屏，过了好久不定时的会更新一屏，不知道是不是因为vb画图速度慢的原因？还是串口的原因？
    串口是9600，8位，无校验位，1停止位。 inputlen=3, 接收到3个字节后事件触发，接收方式为二进制。（下位机发送的命令格式为3个字节：1个前导命令符，数据低8位，数据高8位）

Public worktime As Integer
Public timecnt                          '秒计数器
Dim cqstart, cqdly1, cqdly2, cqdly3
Dim maibo, DS
Dim first
Dim adbuf(1024) ', data                      'ad数据缓冲数组,  接收缓冲数组
Dim data() As Byte                  '接收缓冲数组
Dim num                            'ad 数据个数计数器
—————————————————–
Private Sub Form_Load()
maibo = 0
DS = 0#
first = 1
num = 0
MSComm1.PortOpen = True
End Sub
—————————–
Private Sub MSComm1_OnComm()        '串口程序
Select Case MSComm1.CommEvent
  Case comEvReceive                  '接收到1数据
  data = MSComm1.Input                '取出3个字节缓冲
  MSComm1.InBufferCount = 0          '清除缓冲
  Select Case Chr(data(0))                '命令符号
    Case "B"      '是缓冲数据
    If num < 1024 Then
    adbuf(num) = data(1) + data(2) * 256  '2个8位合成一个16位
    num = num + 1
    End If
    '————————————————————-
    Case "C"      '缓冲区数据接收结束
    Call draw          '画波形
    MSComm1.InBufferCount = 0          '清除缓冲
    num = 0
    '————————————————————-
    Case "D"      '是d/s比
    DS = data(1) + data(2) * 256  '2个8位合成一个16位
    'dsText.Text = DS              '显示
    dsText.Text = DS / 100            '显示
    '————————————————————-
    Case "M"      '是脉搏
    maibo = data(1) + data(2) * 256 '2个8位合成一个16位
    maiboText.Text = maibo              '显示
    '————————————————————-
    Case "Y"      '是cqSTART延时时间
    cqstart = data(1)              '返回cqSTART延时时间
    cqstartText.Text = cqstart              '显示

  End Select
End Select
End Sub
————————————
'—–绘制指脉曲线———————
Sub draw()
picturemb.Cls
picturemb.DrawWidth = 1
picturemb.BackColor = QBColor(15)
picturemb.Scale (0, 1024)-(num + 1, 0) 'x,y坐标
For i = 1 To num - 1
  X1 = (i - 1)
  Y1 = adbuf(i - 1)
  X2 = i
  Y2 = adbuf(i)
  picturemb.Line (X1, Y1)-(X2, Y2), QBColor(0)
Next i
End Sub

建议使用API,如polyline,polygon等。

ding…

500ms????即使来得及画，你的眼睛来得及看吗？

500ms足够了,时间是没有问题的,解决方法有两种（当然AutoRedraw=True）:

1、画线时将picture的Visible属性置成False，画完再置成True，Picture只重绘一次。
2、将曲线图像用PaintPicture方法，将图像向左移一个单位，清除最右一个单位的内容，再用画线方法画最右一个单位，Picture重绘三次。

还有另一种能让你看到图的方法
3、在画线时的For Next循环中，加入DoEvents语句，这样可以保证你眼睛能看到图，但不保证不闪，哈哈。

大家好，我上星期发了一个贴，说事“需要设计一个程序，一开始开启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

收好 再慢慢研究 谢谢了！

我已经写好一个画图的OCX控件,如何才能转换成像微软的OWC控件一样,可以有直接直接导出图片EXPORTPICTURE的功能?
因为我想在ASP中用这个控件,但是好像OCX控件不好用.能不能把已经有的OCX控件重新封装成一个纯DLL文件,弄一个接口,直接画图并导出图片但此过程中不用在窗体上放下这个OCX控件?
我写的OCX控件是建立一个用户控件并在上面放了一个PICTUREBOX画图的.

要DLL你还是用C写吧, 不过那难度好像有点大哦, 还是用楼上的办法试下