求代码: VB自动去红章(jpg) - 编程论坛

#2

Artless2016-09-06 23:40

编程无自动

#3

xiangyue05102016-09-07 08:39

楼主想多了。

#4

风吹过b2016-09-07 09:08

VB，处理图像很慢，
JPG，属压缩图像，写不出解码程序。
BMP，倒写得出解码程序来，然后根据颜色清掉一种颜色。

得了懒病，不愿动了。
如果你有兴趣，我可以提供我改的BMP解码代码。

#5

xiangyue05102016-09-07 13:03

回复 4楼风吹过b

像他这种，打印的黑色字体和红章重叠了，应该也是没用吧

#6

风吹过b2016-09-07 15:13

扫描整个图像，把红色去掉。这个区分 R 变量可以看到，红色的 R变量很高。
然后图像调整为二色图像就是了。把以一个值为限，凡没达到的，全改为 RGB ：255 255 255 为背景，其他的为 0 0 0 为黑色。

如果你动手去过红章，就会知道是怎么一个回事。
盖的红章，是叠加在黑字上面的，不会让盖掉黑字的。

#7

pengzhanggui2016-09-08 07:56

用matlab吧，那个是专业的

#8

xiangyue05102016-09-08 08:43

回复 6楼风吹过b

#9

w5fh2016-09-08 20:56

"扫描整个图像" 太慢了! 图片内存我猜测有一个二维数组或者是数组byte(),版主想办法找到数组byte()内存地址么?

#10

风吹过b2016-09-08 21:16

Pb1.WriteProperty "Picture", Picture1.Image
或
Pb1.WriteProperty "Picture", Picture1.Picture
根据你的图像来源选择。

解析后的数据结构
Public Type pbbtype
    BMPSTART As Long                'BM头起位置
    MaxX As Long                    '图像横
    MaxY As Long                    '图像竖
    DatStart As Long                '数据区起始
    X() As Long                     '每行的起始坐标
    XL As Long                      '每行的数据个数，不含对齐用的数据
End Type

'解析，这几段代码是几个程序里找出来的，这个函数里固定解析的对象。与上面的段对不上。
'不写注释了，这段代码本来就是写给自己看的。

程序代码：

Public Sub AnalysisPB()
'解析PBB

Pbb = PBag.Contents

Dim i As Long
Dim HBN As Long

For i = 0 To 200
If Pbb(i) = 66 And Pbb(i + 1) = 77 Then
    PbT.BMPSTART = i
    Exit For
End If
Next i

If PbT.BMPSTART = 0 Then
    MsgBox "解析图像数据失败", vbCritical, "致命错误"
    End
End If
    CopyMemory PbT.DatStart, Pbb(PbT.BMPSTART + 10), 4
    PbT.DatStart = PbT.DatStart + PbT.BMPSTART
    CopyMemory PbT.MaxX, Pbb(PbT.BMPSTART + 18), 4
    CopyMemory PbT.MaxY, Pbb(PbT.BMPSTART + 22), 4
    ReDim PbT.X(PbT.MaxY)
    HBN = PbT.MaxX * 3
    If HBN Mod 4 <> 0 Then
        HBN = HBN + (4 - HBN Mod 4)
    End If
    For i = 1 To PbT.MaxY
        PbT.X(PbT.MaxY - i + 1) = PbT.DatStart + HBN * (i - 1)
    Next i
End Sub

对应的一个画圆函数，使用勾股定律来画。为啥我画的圆会有毛刺

程序代码：

Public Sub 画圆(X As Long, Y As Long, R As Long, Optional Red As Byte = 0, Optional Green As Byte = 0, Optional Blue As Byte = 0)
'X,Y,R 以缇为单位
    Dim i As Long, j As Long
    Dim m As Long, m2 As Long
    Dim n1 As Long, n2 As Long

    i = Int(X / TX)
    j = Int(Y / TX)
    m = Int(R / TX)
    Call 画点(i, j, Red, Green, Blue)
For n1 = 0 To m
    m2 = Sqr(m * m - n1 * n1)
    For n2 = -m2 To m2
        Call 画点(i + n1, j + n2, Red, Green, Blue)
        Call 画点(i - n1, j + n2, Red, Green, Blue)
    Next n2
Next n1
End Sub

'画点
Public Sub 画点(X As Long, Y As Long, Optional Red As Byte = 0, Optional Green As Byte = 0, Optional Blue As Byte = 0)
'X，Y 以像素为单位
    Dim m As Long
        If X > 0 And Y > 0 And Y < PbT.MaxY And X < PbT.MaxX Then
        m = PbT.X(Y) + X * 3
        Pbb(m) = Blue
        Pbb(m + 1) = Green
        Pbb(m + 2) = Red
    End If
End Sub

调用：
Call 画圆(.X, .Y, .R, .Red, .G, .B)