OCR 文字点位

Option Explicit
Type WordPoint
x1 As Integer
y1 As Integer
x2 As Integer
y2 As Integer

End Type

Declare Function PlgBlt Lib "gdi32" (ByVal hdcDest As Long, _
lpPoint As POINTS2D, _
ByVal hdcSrc As Long, _
ByVal nXSrc As Long, _
ByVal nYSrc As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal hbmMask As Long, _
ByVal xMask As Long, _
ByVal yMask As Long) As Long

Global Const NotPI = 3.14159265238 / 180

'--------------------------------------------------------------------------------
Public Type POINTS2D
X As Long
Y As Long
End Type

Dim current As String

Public Sub DanRotate(ByRef picDestHdc As Long, xPos As Long, yPos As Long, _
ByVal Angle As Long, _
ByRef picSrcHdc As Long, srcXoffset As Long, srcYoffset As Long, _
ByVal srcWidth As Long, ByVal srcHeight As Long)

'## DanRotate - Rotates an image.
'##
'## PicDestHdc = the hDc of the target picturebox (ie. Picture2.hdc )
'## xPos = the target coordinates (note that the image will be centered around these
'## yPos coordinates).
'## Angle = Rotate Angle (0-360)
'## PicSrcHdc = The source image to rotate (ie. Picture1.hdc )
'## srcXoffset = The offset coordinates within the Source Image to grab.
'## srcYoffset
'## srcWidth = The width/height of the source image to grab.
'## srcHeight
'##
'## Returns: Nothing.

'## Please note this function doesn't check or returns anything. It's up to you to make sure all parameters
'## are valid, checked, etc.
'##
'## Use this code as you like. Credits appreciated.
'##
'## Danny van der Ark (danny@slave-studios.co.uk)
'## Aug 2Oo2

 

Dim Points(3) As POINTS2D
Dim DefPoints(3) As POINTS2D
Dim ThetS As Single, ThetC As Single
Dim ret As Long

'================XPOS/YPOS自动计算==========================
Dim SrcX1, SrcY1, SrcX2, SrcY2, SrcX3, SrcY3, SrcX4, SrcY4 As Double

SrcX1 = -(srcWidth - 1) / 2
SrcY1 = (srcHeight - 1) / 2
SrcX2 = (srcWidth - 1) / 2
SrcY2 = (srcHeight - 1) / 2
SrcX3 = -(srcWidth - 1) / 2
SrcY3 = -(srcHeight - 1) / 2
SrcX4 = (srcWidth - 1) / 2
SrcY4 = -(srcHeight - 1) / 2

'Theta = Angle * NotPI
ThetS = Sin(Angle * NotPI)
ThetC = Cos(Angle * NotPI)

'// 旋转后四个角的坐标（以图像中心为坐标系原点）
Dim DstX1, DstY1, DstX2, DstY2, DstX3, DstY3, DstX4, DstY4 As Double
DstX1 = ThetC * SrcX1 + ThetS * SrcY1
DstY1 = -ThetS * SrcX1 + ThetC * SrcY1
DstX2 = ThetC * SrcX2 + ThetS * SrcY2
DstY2 = -ThetS * SrcX2 + ThetC * SrcY2
DstX3 = ThetC * SrcX3 + ThetS * SrcY3
DstY3 = -ThetS * SrcX3 + ThetC * SrcY3
DstX4 = ThetC * SrcX4 + ThetS * SrcY4
DstY4 = -ThetS * SrcX4 + ThetC * SrcY4

xPos = max(Abs(DstX4 - DstX1), Abs(DstX3 - DstX2)) + 0.5
yPos = max(Abs(DstY4 - DstY1), Abs(DstY3 - DstY2)) + 0.5

'==================================

'SET LOCAL AXIS / ALIGNMENT
Points(0).X = -srcWidth * 0.5
Points(0).Y = -srcHeight * 0.5

Points(1).X = Points(0).X + srcWidth
Points(1).Y = Points(0).Y

Points(2).X = Points(0).X
Points(2).Y = Points(0).Y + srcHeight

'ROTATE AROUND Z-AXIS
' ThetS = Sin(Angle * NotPI)
' ThetC = Cos(Angle * NotPI)
DefPoints(0).X = (Points(0).X * ThetC - Points(0).Y * ThetS) + xPos / 2
DefPoints(0).Y = (Points(0).X * ThetS + Points(0).Y * ThetC) + yPos / 2

DefPoints(1).X = (Points(1).X * ThetC - Points(1).Y * ThetS) + xPos / 2
DefPoints(1).Y = (Points(1).X * ThetS + Points(1).Y * ThetC) + yPos / 2

DefPoints(2).X = (Points(2).X * ThetC - Points(2).Y * ThetS) + xPos / 2
DefPoints(2).Y = (Points(2).X * ThetS + Points(2).Y * ThetC) + yPos / 2

PlgBlt picDestHdc, DefPoints(0), picSrcHdc, srcXoffset, srcYoffset, srcWidth, srcHeight, 0, 0, 0

End Sub
Public Function Rotate(src As Object, dst As Object, ByVal RotaryAngle As Single)

Dim rx0, ry0 As Double '旋转点
Dim dstX, dstY, DstC As Long
Dim Move_X, Move_Y As Integer
Dim X, Y As Double
Dim i, j As Integer
Dim OldWidth, OldHeight As Integer
Dim NewWidth, NewHeight As Integer
Dim Theta, ThetS, ThetC As Double
Dim dx, dy As Single

' 源图四个角的坐标（以图像中心为坐标系原点）
Dim SrcX1, SrcY1, SrcX2, SrcY2, SrcX3, SrcY3, SrcX4, SrcY4 As Double

OldWidth = src.Width
OldHeight = src.Height

SrcX1 = -(OldWidth - 1) / 2
SrcY1 = (OldHeight - 1) / 2
SrcX2 = (OldWidth - 1) / 2
SrcY2 = (OldHeight - 1) / 2
SrcX3 = -(OldWidth - 1) / 2
SrcY3 = -(OldHeight - 1) / 2
SrcX4 = (OldWidth - 1) / 2
SrcY4 = -(OldHeight - 1) / 2

Theta = RotaryAngle / 180 * 3.141592653
ThetS = Sin(Theta)
ThetC = Cos(Theta)

'// 旋转后四个角的坐标（以图像中心为坐标系原点）
Dim DstX1, DstY1, DstX2, DstY2, DstX3, DstY3, DstX4, DstY4 As Double
DstX1 = ThetC * SrcX1 + ThetS * SrcY1
DstY1 = -ThetS * SrcX1 + ThetC * SrcY1
DstX2 = ThetC * SrcX2 + ThetS * SrcY2
DstY2 = -ThetS * SrcX2 + ThetC * SrcY2
DstX3 = ThetC * SrcX3 + ThetS * SrcY3
DstY3 = -ThetS * SrcX3 + ThetC * SrcY3
DstX4 = ThetC * SrcX4 + ThetS * SrcY4
DstY4 = -ThetS * SrcX4 + ThetC * SrcY4

NewWidth = max(Abs(DstX4 - DstX1), Abs(DstX3 - DstX2)) + 0.5
NewHeight = max(Abs(DstY4 - DstY1), Abs(DstY3 - DstY2)) + 0.5

dx = -0.5 * NewWidth * ThetC - 0.5 * NewHeight * ThetS + 0.5 * OldWidth
dy = 0.5 * NewWidth * ThetS - 0.5 * NewHeight * ThetC + 0.5 * OldHeight

rx0 = OldWidth * 0.5 '(rx0,ry0)为旋转中心
ry0 = OldHeight * 0.5

dst.Cls
For i = 0 To NewHeight
For j = 0 To NewWidth

X = (j - rx0) * ThetC - (i - ry0) * ThetS + rx0 '+ dx
Y = (j - rx0) * ThetS + (i - ry0) * ThetC + ry0 '+ dy
If X < 0 Or Y < 0 Or X >= OldWidth Or Y >= OldHeight Then 'out of range
SetPixel dst.hdc, j, i, vbBlack
Else
SetPixel dst.hdc, j, i, GetPixel(src.hdc, X, Y)
End If
Next j
Next i

End Function
Public Function Position(src As Object)
Dim col As Long
Dim srcWidth, srcHeight As Integer
Dim BlackCount, WhiteCount As Integer
Dim yTop, yBottom, xTop, xBottom As Integer

srcWidth = src.ScaleWidth
srcHeight = src.ScaleHeight

'Ybottom
For j = 0 To srcHeight
BlackCount = 0
WhiteCount = 0
For i = 0 To srcWidth

col = GetPixel(src.hdc, i, j)

If col = vbWhite Then
WhiteCount = WhiteCount + 1
ElseIf col = vbBlack Then
BlackCount = BlackCount + 1
End If
'SetPixel Src.hdc, i, j, vbRed
Next i
If WhiteCount > 20 Then
yBottom = j
j = srcHeight + 1
i = srcWidth + 1
End If

Next j

'ytop
For j = srcHeight To 0 Step -1
BlackCount = 0
WhiteCount = 0
For i = 0 To srcWidth

col = GetPixel(src.hdc, i, j)

If col = vbWhite Then
WhiteCount = WhiteCount + 1
ElseIf col = vbBlack Then
BlackCount = BlackCount + 1
End If
'SetPixel Src.hdc, i, j, vbRed
Next i

If WhiteCount > 3 Then
yTop = j
j = 0
i = srcWidth + 1
End If
Next j

'xbottom
For i = 0 To srcWidth
BlackCount = 0
WhiteCount = 0

For j = 0 To srcHeight ' To 0 Step -1

col = GetPixel(src.hdc, i, j)

If col = vbWhite Then
WhiteCount = WhiteCount + 1
ElseIf col = vbBlack Then
BlackCount = BlackCount + 1
End If

'SetPixel Src.hdc, i, j, vbRed

Next j
If WhiteCount > 20 Then
xBottom = i
j = srcHeight + 1
i = srcWidth + 1
End If

Next i

'xtop
For i = srcWidth To 0 Step -1
BlackCount = 0
WhiteCount = 0

For j = 0 To srcHeight ' To 0 Step -1

col = GetPixel(src.hdc, i, j)

If col = vbWhite Then
WhiteCount = WhiteCount + 1
ElseIf col = vbBlack Then
BlackCount = BlackCount + 1
End If
'SetPixel Src.hdc, i, j, vbRed

Next j

If WhiteCount > 20 Then
xTop = i
j = srcHeight + 1
i = 0
End If

Next i

src.Line (xBottom, yBottom)-(xBottom, yTop), vbBlue
src.Line (xBottom, yBottom)-(xTop, yBottom), vbBlue
src.Line (xBottom, yTop)-(xTop, yTop), vbBlue
src.Line (xTop, yBottom)-(xTop, yTop), vbBlue

'
' WhiteCount = 0
' BlackCount = 0
'
' For i = yBottom To yTop
' BlackCount = 0
' For j = xBottom To xTop '图像回归
' 'For y = 0 To NewHeight
'
' col = GetPixel(Src.hdc, j, i)
'
' If col = vbWhite Then
' WhiteCount = WhiteCount + 1
' ElseIf col = vbBlack Then
' BlackCount = BlackCount + 1
'
' End If
' Next j
' Src.Line (0, i)-(BlackCount / 5, i), vbYellow
' Src.Refresh
' DoEvents
' Next i

Dim ret As Integer

ret = WordsPosition(src, xBottom, yBottom, xTop, yTop)

' For i = xBottom To xTop
' BlackCount = 0
' For j = yBottom To yTop '文字定位
' 'For y = 0 To NewHeight
'
' col = GetPixel(Src.hdc, i, j)
'
' If col = vbWhite Then
' 'WhiteCount = WhiteCount + 1
' ElseIf col = vbBlack Then
' BlackCount = BlackCount + 1
'
' End If
' Next j
' col = GetPixel(Src.hdc, i - 1, j)
' Src.Line (i, 0)-(i, BlackCount), vbYellow
' If BlackCount = 0 And col <> vbBlack Then Src.Line (i, 0)-(i, xTop), vbBlue
'
' Src.Refresh
' DoEvents
' Next i

End Function
Public Function WordsPosition(src As Object, ByVal xBottom As Integer, ByVal yBottom As Integer, ByVal xTop As Integer, ByVal yTop As Integer)
Dim i, j, ii, jj, p As Integer
Dim BlackCount, col As Long
Dim xLevel, yLevel As Integer '阈值
Dim myWord(0 To 20) As WordPoint
Dim inWord As Boolean
Dim x1temp, x2temp, y1temp, y2temp As Single

Dim bool1stScan As Boolean
Dim ax As Integer '最小
Dim ay As Integer 'biggest
Dim bx As Integer 'smallest
Dim by As Integer 'biggest

ax = 0
ay = yBottom / 2 + yTop / 2
bx = 0
by = yBottom / 2 + yTop / 2

 

xLevel = 1
yLevel = 1
inWord = False
p = 0

For i = xBottom + 5 To xTop - 5
BlackCount = 0

For j = yBottom + 5 To yTop - 5 '文字定位
'For y = 0 To NewHeight

col = GetPixel(src.hdc, i, j)
If col = vbBlack Then
BlackCount = BlackCount + 1


'‘**********************************
If Not bool1stScan Then
' If i <= ax Then
' ax = i
' End If
' If i >= bx Then
' bx = i
' End If
If j <= ay Then
ay = j
End If
If j >= by Then
by = j
End If
Else
bool1stScan = False
ax = i
bx = i 'big
ay = j
by = j 'big
End If

'‘**********************************


End If
Next j

If BlackCount > xLevel Then '开始进入字体区间
If inWord = False Then
myWord(p).x1 = i
inWord = True
End If
End If

If BlackCount < xLevel Then '退出字符区间
If inWord = True Then
myWord(p).x2 = i
myWord(p).y1 = ay
myWord(p).y2 = by
p = p + 1
ay = yBottom / 2 + yTop / 2
by = yBottom / 2 + yTop / 2

src.Line (myWord(p - 1).x1, myWord(p - 1).y1)-(myWord(p - 1).x2, myWord(p - 1).y2), vbBlue, B
'src.Line (58, 40)-(72, 63), vbBlue, B
inWord = False
recog src, myWord(p - 1).x1, myWord(p - 1).x2, myWord(p - 1).y1, myWord(p - 1).y2
' '++++++++++++ start of y position check +++++++++++
' For jj = yBottom + 5 To yTop - 5 '文字定位 y
' BlackCount = 0
' For ii = xBottom + 5 To xTop - 5
' col = GetPixel(Src.hdc, ii, jj)
' If col = vbBlack Then
' BlackCount = BlackCount + 1
' End If
' Next ii
'
' If BlackCount > yLevel Then '开始进入字体区间
' If inWord = False Then
' myWord(p).y1 = jj
' inWord = True
' End If
' End If
'
' If BlackCount < yLevel Then '退出字符区间
' If inWord = True Then
' myWord(p).y2 = jj
' p = p + 1
' inWord = False
' x1temp = myWord(p - 1).x1
' x2temp = myWord(p - 1).x2
' y1temp = myWord(p - 1).y1
' y2temp = myWord(p - 1).y2
' 'Src.Line (myWord(p - 1).x1, myWord(p - 1).y1)-(myWord(p - 1).x2, myWord(p - 1).y2), vbYellow, B
' Src.Line (x1temp, y1temp)-(x2temp, y2temp), vbBlue, B
' End If
' End If
'
' Next jj
' '++++++++++++ end of y position check +++++++++++++

End If
End If


' Src.Line (i, 0)-(i, BlackCount), vbYellow

'Src.Refresh
DoEvents
Next i

 

End Function

Public Function recog(src As Object, ByVal x1 As Integer, ByVal x2 As Integer, ByVal y1 As Integer, ByVal y2 As Integer)
Dim i, max, maxtch As Integer
Dim template, ans, name, s As String
Dim match As Integer

Dim px, py, p As Double

Dim myImage(0 To 500, 0 To 500) As Long

frmMain.Pic2.Cls

'frmMain.Pic2.ScaleWidth = x2 - x1
'frmMain.Pic2.ScaleHeight = y2 - y1

'frmMain.Pic2.Width = (x2 - x1) * 1.8
'frmMain.Pic2.Height = (y2 - y1) * 1.2

If y2 - y1 < 100 Then py = 100 / (y2 - y1)
If x2 - x1 < 100 Then px = 100 / (x2 - x1)

If py < px Then
p = py
Else: p = px
End If

 

Dim SrcX, SrcY, kx, ky As Integer

kx = 0
ky = 0

current = ""
For i = 0 To (x2 - x1) * p Step (x2 - x1) * p / 20
ky = 0
For j = 0 To (y2 - y1) * p Step (y2 - y1) * p / 20

SrcX = i / p + x1 'dstX / p ' * (srcWidth / dstWidth)
SrcY = j / p + y1 'dstY / p '* (srcHeight / dstHeight)

If GetPixel(src.hdc, SrcX, SrcY) = vbBlack Then
SetPixel frmMain.Pic2.hdc, i, j, GetPixel(src.hdc, SrcX, SrcY)
current = current & 0
Else
current = current & 1
End If
ky = ky + 1
If ky = 20 Then j = (y2 - y1) * p + 100
Next j
kx = kx + 1
If kx = 20 Then i = (x2 - x1) * p + 100
Next i
Debug.Print
Debug.Print
Debug.Print "current=" & current

Stop

'current = ""

' For i = x1 To x2 - (x2 - x1) / 20 Step (x2 - x1) / 20
' For j = y1 To y2 - (y2 - y1) / 20 Step (y2 - y1) / 20
' If src.Point(i, j) = vbBlack Then
'
' current = current & src.Point(i, j)
' Else
' current = current & 1
' End If
' Next j
'
' Next i

template = ""

max = 0
Open "d:\data.rec" For Input As #1
While Not EOF(1)
Input #1, s
match = 0
template = Right(s, Len(s) - 1)
name = Left(s, 1)
i = 1
While i <= Len(current) And Len(current) - i + match >= max
If Mid(current, i, 1) = Mid(template, i, 1) Then match = match + 1
i = i + 1
Wend
If match > max Then
max = match
ans = name
End If
Debug.Print match, "->", name
Wend
Close #1
frmMain.Text3.Text = frmMain.Text3.Text + ans

End Function

Public Function Zoom(dst As Object, src As Object, p As Single)

Dim srcWidth, srcHeight, dstWidth, dstHeight As Long
srcWidth = src.Width
srcHeight = src.Height
dstWidth = (srcWidth - 1) * p
dstHeight = (srcHeight - 1) * p

Dim dstX, dstY, SrcX, SrcY As Integer

dst.Cls
dst.AutoRedraw = True
For dstX = 0 To dstWidth
For dstY = 0 To dstHeight

SrcX = dstX / p ' * (srcWidth / dstWidth)
SrcY = dstY / p '* (srcHeight / dstHeight)

SetPixel dst.hdc, dstX, dstY, GetPixel(src.hdc, SrcX, SrcY)
'If dstY = 160 Then Stop
Next dstY
Next dstX

End Function

Public Function max(a As Double, b As Double) As Double
If a > b Then max = a Else max = b
End Function