关于Visual Basic 6.0SP6（很多人之所以不使用最新的VS2010系列而使用老式的6.0，也是因为它的经典性以及便携性，比如我的迅雷5.0，一直都不愿意升级为7.0，哪怕是界面确实漂亮一些），很老式的一款软件，这里就不介绍了。
工程目录：
分为窗体，模块和用户控件三个部分。
VB是解释型的语言，分一个个Sub对事件进行处理。
Private Sub CmdClear_Click() '清理手写输入框（清除按钮）
PicPrint.Cls
SapText.Visible = False
End Sub
Private Sub CmdFont_Click() '选择文字大小和字体（字体按钮）
On Error GoTo Error
With CDFont
.Flags = cdlCFBoth
.FontName = PicSample.FontName //字体名
.FontSize = PicSample.FontSize //字体大小
.FontBold = PicSample.FontBold //字形
.FontItalic = PicSample.FontItalic //字符集
.ShowFont
End With
With PicSample
.FontName = CDFont.FontName
.FontSize = CDFont.FontSize
.FontBold = CDFont.FontBold
.FontItalic = CDFont.FontItalic
End With
With TxtSample //由于是软件使用者自己输入的，所以不需要字符集
.FontName = CDFont.FontName
'.FontSize = CDFont.FontSize
.FontBold = CDFont.FontBold
End With
Error:
End Sub
Private Sub CmdRead_Click() '进行识别
Dim CutPic As RECT //定义一个RECT类型的数据
ListSame.Clear '清空List框
CutPic = CutLetters(PicPrint) '将PicPrint中的手写文本剪切
SapText.Left = CutPic.Left
SapText.Width = CutPic.Right - CutPic.Left
SapText.Top = CutPic.Top
SapText.Height = CutPic.Bottom - CutPic.Top
SapText.Visible = True
ReDim OcrText(1 To Len(TxtSample.Text)) '重新定义OcrText数组的长度
For i = 1 To Len(TxtSample.Text) '循环进行匹配度校验（对每一个计算匹配度）
OcrText(i).ModeText = Mid(TxtSample.Text, i, 1) '取得文字
PicSample.Width = PicSample.TextWidth(OcrText(i).ModeText) '初步设置大小
PicSample.Height = PicSample.TextHeight(OcrText(i).ModeText)
PicSample.CurrentX = 0
PicSample.CurrentY = 0
PicSample.Cls
PicSample.Print OcrText(i).ModeText '输出标准文本
CutPic = CutLetters(PicSample) '剪切标准文本
BitBlt PicSample.hdc, 0, 0, CutPic.Right - CutPic.Left, CutPic.Bottom - CutPic.Top, PicSample.hdc, CutPic.Left, CutPic.Top, vbSrcCopy
PicSample.Refresh
PicSample.Width = CutPic.Right - CutPic.Left
PicSample.Height = CutPic.Bottom - CutPic.Top
PicSample.Left = (PicSampleOutSide.ScaleWidth - PicSample.ScaleWidth) / 2
PicSample.Top = (PicSampleOutSide.ScaleHeight - PicSample.ScaleHeight) / 2
PicPrintMode.Width = PicSample.Width
PicPrintMode.Height = PicSample.Height
StretchBlt PicPrintMode.hdc, 0, 0, PicPrintMode.ScaleWidth, PicPrintMode.ScaleHeight, PicPrint.hdc, SapText.Left, SapText.Top, SapText.Width, SapText.Height, vbSrcCopy
BlackBits PicSample '对标准文本二值化(二值化处理是图像处理的一个重要过程)
OcrText(i).SameBits = OcrBits(PicPrintMode, PicSample) '进行匹配度校验
DoEvents
Next i
Kspxd OcrText, 1, Len(TxtSample.Text) '对匹配进行排序
For i = Len(TxtSample.Text) To 1 Step -1 '输出到List框中
ListSame.AddItem OcrText(i).ModeText & "的相似度：" & CStr(Round(OcrText(i).SameBits / 100, 2)) & "%"
Next i
'显示最匹配文字到标准文本输出框
TxtPrint.Text = TxtPrint.Text & OcrText(Len(TxtSample.Text)).ModeText
PicSample.Width = PicSample.TextWidth(OcrText(Len(TxtSample.Text)).ModeText)
PicSample.Height = PicSample.TextHeight(OcrText(Len(TxtSample.Text)).ModeText)
PicSample.CurrentX = 0
PicSample.CurrentY = 0
PicSample.Cls
PicSample.Print OcrText(Len(TxtSample.Text)).ModeText
CutPic = CutLetters(PicSample)
BitBlt PicSample.hdc, 0, 0, CutPic.Right - CutPic.Left, CutPic.Bottom - CutPic.Top, PicSample.hdc, CutPic.Left, CutPic.Top, vbSrcCopy
PicSample.Refresh
PicSample.Width = CutPic.Right - CutPic.Left
PicSample.Height = CutPic.Bottom - CutPic.Top
PicSample.Left = (PicSampleOutSide.ScaleWidth - PicSample.ScaleWidth) / 2
PicSample.Top = (PicSampleOutSide.ScaleHeight - PicSample.ScaleHeight) / 2
End Sub
Private Sub Form_Load()
PicPrint.DrawWidth = 10 '设置笔刷大小
TxtSample.Text = "0123456789AaBbCcDdEeFfGgHhIiJjKkLlMmNnOoPpQqRrSsTtUuVvWwXxYyZz" '设置在哪些文字中进行识别
End Sub
Private Sub ListSame_Click() '点击List框，选择文字添加到文本框中
On Error Resume Next
TxtPrint.Text = Left(TxtPrint.Text, Len(TxtPrint.Text) - 1) & OcrText(ListSame.ListCount - ListSame.ListIndex).ModeText
End Sub
Private Sub PicPrint_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button <> 0 Then
If SapText.Visible = True Then Call CmdClear_Click '如果虚框在就将输入框清理了。
PicPrint.Circle (x, y), 2 '进行绘图
End If
End Sub
用户控件（UI）的实现：
这里的UI很精致啊！不是可以单靠属性框来实现的，需要再借助于编码来完成，UI编码如下：
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2
Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As POINTAPI, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
Const RGN_OR = 2
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type POINTAPI
x As Long
y As Long
End Type
Private Sub ImageL_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = 1 Then
Call ReleaseCapture
Call SendMessage(UserControl.Parent.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0)
End If
End Sub
Private Sub ImageM_DblClick()
If PicMaxU.Enabled = True Then
Call PicMaxU_Click
End If
End Sub
Private Sub ImageM_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = 1 Then
Call ReleaseCapture
Call SendMessage(UserControl.Parent.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0)
End If
End Sub
Private Sub ImageR_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = 1 Then
Call ReleaseCapture
Call SendMessage(UserControl.Parent.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0)
End If
End Sub
Private Sub LabelC_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = 1 Then
Call ReleaseCapture
Call SendMessage(UserControl.Parent.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0)
End If
End Sub
Private Sub PicClose_Click()
End Sub
Private Sub PicCloseU_Click()
Unload UserControl.Parent
End Sub
Private Sub PicCloseU_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
With PicCloseU
If Button = 0 Then
If (x < 0) Or (y < 0) Or (x > .Width) Or (y > .Height) Then
ReleaseCapture ' 鼠标离开
.Cls
Else
SetCapture .hwnd '鼠标进入
BitBlt .hdc, 0, 0, 15, 16, PicClose.hdc, 0, 0, vbSrcCopy
.Refresh
End If
End If
End With
End Sub
Private Sub PicMax_Click()
End Sub
Private Sub PicMaxU_Click()
If UserControl.Parent.WindowState = 2 Then
UserControl.Parent.WindowState = 0
Else
UserControl.Parent.WindowState = 2
End If
PicMaxU.Cls
End Sub
Private Sub PicMaxU_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
With PicMaxU
If Button = 0 Then
If (x < 0) Or (y < 0) Or (x > .Width) Or (y > .Height) Then
ReleaseCapture ' 鼠标离开
.Cls
Else
SetCapture .hwnd '鼠标进入
BitBlt .hdc, 0, 0, 15, 16, PicMax.hdc, 0, 0, vbSrcCopy
.Refresh
End If
End If
End With
End Sub
Private Sub PicMin_Click()
End Sub
Private Sub PicMinU_Click()
UserControl.Parent.WindowState = 1
PicMinU.Cls
End Sub
Private Sub PicMinU_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
With PicMinU
If Button = 0 Then
If (x < 0) Or (y < 0) Or (x > .Width) Or (y > .Height) Then
ReleaseCapture ' 鼠标离开
.Cls
Else
SetCapture .hwnd '鼠标进入
BitBlt .hdc, 0, 0, 15, 16, PicMin.hdc, 0, 0, vbSrcCopy
.Refresh
End If
End If
End With
End Sub
Private Sub PicUn_Click()
End Sub
Private Sub UserControl_Resize()
On Error Resume Next
ImageM.Width = UserControl.ScaleWidth - 14
ImageR.Left = UserControl.ScaleWidth - 7
UserControl.Height = 360
UserControl.Width = UserControl.Parent.Width
PicCloseU.Left = UserControl.ScaleWidth - 20
PicMaxU.Left = UserControl.ScaleWidth - 43
PicMinU.Left = UserControl.ScaleWidth - 67
AllBlt UserControl.Parent, Picture000
Dim Regn As Long
Dim CER As Long
'MakeNoBorderForm UserControl.Parent
X1 = UserControl.Parent.Width / Screen.TwipsPerPixelX
Y1 = UserControl.Parent.Height / Screen.TwipsPerPixelY
Regn = CreateRectRgn(0, 4, X1, Y1) '把句柄设为第一个矩形区域
CER = CreateRectRgn(4, 0, X1 - 4, 10) '创建第二个矩形区域
CombineRgn Regn, Regn, CER, RGN_OR '把临时句柄变量或运算到句柄变量中
CER = CreateRectRgn(2, 1, X1 - 2, 10)
CombineRgn Regn, Regn, CER, RGN_OR '把临时句柄变量或运算到句柄变量中
CER = CreateRectRgn(1, 2, X1 - 1, 10)
CombineRgn Regn, Regn, CER, RGN_OR '把临时句柄变量或运算到句柄变量中
Call SetWindowRgn(UserControl.Parent.hwnd, Regn, True) '创建窗体
UserControl.Parent.Line (0, 21)-(0, UserControl.Parent.ScaleHeight - 1), 8684676
UserControl.Parent.Line (0, UserControl.Parent.ScaleHeight - 1)-(UserControl.Parent.ScaleWidth - 1, UserControl.Parent.ScaleHeight - 1), 8684676
UserControl.Parent.Line (UserControl.Parent.ScaleWidth - 1, 21)-(UserControl.Parent.ScaleWidth - 1, UserControl.Parent.ScaleHeight), 8684676
End Sub
Private Function AllBlt(frm As Object, Pic As Object)
Dim i As Long, j As Long
frm.ScaleMode = 3
frm.AutoRedraw = True
Pic.AutoRedraw = True
Pic.ScaleMode = 3
Pic.AutoSize = True
For i = 0 To frm.ScaleWidth Step Pic.ScaleWidth
For j = 0 To frm.ScaleHeight Step Pic.ScaleHeight
BitBlt frm.hdc, i, j, Pic.ScaleWidth, Pic.ScaleHeight, Pic.hdc, 0, 0, vbSrcCopy
Next j
Next i
frm.Refresh
End Function
Private Sub MakeNoBorderForm(frm As Form)
'切除窗口的边框
Dim rctClient As RECT, rctFrame As RECT
Dim hRgn As Long
Dim lRes As Long
ReDim XY(3) As POINTAPI
Dim lpTL As POINTAPI, lpBR As POINTAPI
'获得窗口矩形区域
'将窗口矩形坐标转换为屏幕坐标
lpTL.x = frm.Left / 15
lpTL.y = frm.Top / 15
ScreenToClient frm.hwnd, lpTL
rctClient.Left = Abs(lpTL.x)
rctClient.Top = Abs(lpTL.y)
frm.ScaleMode = 1 'Twip
rctClient.Right = frm.ScaleWidth / 15 + Abs(lpTL.x)
rctClient.Bottom = frm.ScaleHeight / 15 + Abs(lpTL.y)
'建立要切割的数组
XY(0).x = rctClient.Left
XY(0).y = rctClient.Top
XY(1).x = rctClient.Right
XY(1).y = rctClient.Top
XY(2).x = rctClient.Right
XY(2).y = rctClient.Bottom
XY(3).x = rctClient.Left
XY(3).y = rctClient.Bottom
hRgn = CreatePolygonRgn(XY(0), 4, 2)
lRes = SetWindowRgn(frm.hwnd, hRgn, True)
frm.ScaleMode = 3
End Sub
Private Sub UserControl_Show()
If UserControl.Parent.MinButton = False Then
BitBlt PicMinU.hdc, 0, 0, 15, 16, PicUn.hdc, 0, 0, vbSrcCopy
PicMinU.Refresh
PicMinU.Enabled = False
End If
If UserControl.Parent.MaxButton = False Then
BitBlt PicMaxU.hdc, 0, 0, 15, 16, PicUn.hdc, 0, 0, vbSrcCopy
PicMaxU.Refresh
PicMaxU.Enabled = False
End If
LabelC.Caption = UserControl.Parent.Caption
ImageIco.Picture = UserControl.Parent.Icon
End Sub
对按钮的UI（这里也没有用VB6.0自带的默认按钮，不过，这里也需要写代码来对UI进行设计）
Option Explicit
'Default Property Values:
Const m_def_TextAlign = vbCenter
Const m_def_PictureTColor = &HFF00FF
Const m_def_PicturePos = 0
Const m_def_TextColorDisabled2 = 0
Const m_def_DrawFocus = 0
Const m_def_DisplaceText = 0
Const m_def_TextLine = 1
'Const m_def_DownTextDX = 0
'Const m_def_DownTextDY = 0
Const m_def_DisableHover = False
Const m_def_TextColorEnabled = 0
Const m_def_TextColorDisabled = 0
Const m_def_FillWithColor = False
Const m_def_SizeCW = 12
Const m_def_SizeCH = 11
Const m_def_Text = ""
'Property Variables:
Dim m_TextAlign As AlignmentConstants
Dim m_PictureTColor As Ole_Color
Dim m_TextLine As Integer
Dim m_PicturePos As Integer
Dim m_Picture As StdPicture
Dim m_TextColorDisabled2 As Ole_Color
Dim m_DrawFocus As Integer
Dim m_DisplaceText As Integer
Dim m_DisableHover As Boolean
Dim m_TextColorEnabled As Ole_Color
Dim m_TextColorDisabled As Ole_Color
Dim m_FillWithColor As Boolean
Dim m_SizeCW As Long
Dim m_SizeCH As Long
Dim m_SkinPicture As PictureBox
Dim m_Text As String
Dim m_State As Integer
Dim m_HasFocus As Boolean
Dim m_BtnDown As Boolean
Dim m_SpcDown As Boolean
Dim m_SkinPictureName As String
Public Enum EnumPicturePos
ppLeft
ppTop
ppBottom
ppRight
ppCenter
End Enum
Private Const DI_NORMAL As Long = &H3
Const BTN_NORMAL = 1
Const BTN_FOCUS = 2
Const BTN_HOVER = 3
Const BTN_DOWN = 4
Const BTN_DISABLED = 5
'Event Declarations:
Event Click() 'MappingInfo=UserControl,UserControl,-1,Click
Event MouseHover()
Event MouseOut()
Event MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Event MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Event MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
Event KeyPress(KeyAscii As Integer)
Event KeyDown(KeyCode As Integer, Shift As Integer)
Event KeyUp(KeyCode As Integer, Shift As Integer)
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Enum EnumDrawTextFormat
DT_BOTTOM = &H8
DT_CALCRECT = &H400
DT_CENTER = &H1
DT_CHARSTREAM = 4
DT_DISPFILE = 6
DT_EXPANDTABS = &H40
DT_EXTERNALLEADING = &H200
DT_INTERNAL = &H1000
DT_LEFT = &H0
DT_METAFILE = 5
DT_NOCLIP = &H100
DT_NOPREFIX = &H800
DT_PLOTTER = 0
DT_RASCAMERA = 3
DT_RASDISPLAY = 1
DT_RASPRINTER = 2
DT_RIGHT = &H2
DT_SINGLELINE = &H20
DT_TABSTOP = &H80
DT_TOP = &H0
DT_VCENTER = &H4
DT_WORDBREAK = &H10
DT_WORD_ELLIPSIS = &H40000
DT_END_ELLIPSIS = 32768
DT_PATH_ELLIPSIS = &H4000
DT_EDITCONTROL = &H2000
'===================
DT_INCENTER = DT_CENTER Or DT_VCENTER Or DT_SINGLELINE
End Enum
Private Const SRCCOPY = &HCC0020
Private Const RGN_AND = 1
Private Declare Function BeginPath Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function EndPath Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function SelectClipPath Lib "gdi32" (ByVal hdc As Long, ByVal iMode As Long) As Long
Private Declare Function SelectClipRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long) As Long
Private Declare Function apiDrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function apiTranslateColor Lib "olepro32.dll" Alias "OleTranslateColor" (ByVal clr As Ole_Color, ByVal palet As Long, Col As Long) As Long
Private Declare Function DrawFocusRect Lib "user32" (ByVal hdc As Long, lpRect As RECT) As Long
Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
'Private Declare Function TransparentBlt Lib "msimg32.dll" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal crTransparent As Long) As Boolean
'MY NOTE: TransparentBlt on Win98 leavs some garbage in memory...
'
'Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GdiTransparentBlt Lib "gdi32.dll" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal crTransparent As Long) As Boolean
Private Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long
Private Declare Function SetDIBColorTable Lib "gdi32" (ByVal hdc As Long, ByVal un1 As Long, ByVal un2 As Long, pcRGBQuad As RGBQUAD) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
'for picture
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
'Private Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long
'Private Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, ByVal lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private Declare Function RealizePalette Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DrawIconEx Lib "user32" (ByVal hdc As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
'never enough
Private Declare Function GetBkColor Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetTextColor Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Type BITMAPINFOHEADER
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
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 Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors(1) As RGBQUAD
End Type
'windows version
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
'#############################################
'//GDI + SOMETHING ELSE#######################
Private Sub TransBlt(ByVal hdcDest As Long, ByVal xDest As Long, ByVal yDest As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, ByVal hdcSrc As Long, _
ByVal xSrc As Long, ByVal ySrc As Long, ByVal clrMask As Ole_Color)
'one check to see if GdiTransparentblt is supported
'better way to check if function is suported is using LoadLibrary and GetProcAdress
'than using GetVersion or GetVersionEx
'=====================================================
Dim Lib As Long
Dim ProcAdress As Long
Dim lMaskColor As Long
lMaskColor = TranslateColor(clrMask)
Lib = LoadLibrary("gdi32.dll")
'-------------------------------->make sure to specify corect name for function
ProcAdress = GetProcAddress(Lib, "GdiTransparentBlt")
FreeLibrary Lib
If ProcAdress <> 0 Then
'works on XP
GdiTransparentBlt hdcDest, xDest, yDest, nWidth, nHeight, hdcSrc, xSrc, ySrc, nWidth, nHeight, lMaskColor
'Debug.Print "Gdi transparent blt"
Exit Sub 'make it short
End If
'=====================================================
Const DSna As Long = &H220326
Dim hdcMask As Long
Dim hdcColor As Long
Dim hbmMask As Long
Dim hbmColor As Long
Dim hbmColorOld As Long
Dim hbmMaskOld As Long
Dim hdcScreen As Long
Dim hdcScnBuffer As Long
Dim hbmScnBuffer As Long
Dim hbmScnBufferOld As Long
hdcScreen = UserControl.hdc
lMaskColor = TranslateColor(clrMask)
hbmScnBuffer = CreateCompatibleBitmap(hdcScreen, nWidth, nHeight)
hdcScnBuffer = CreateCompatibleDC(hdcScreen)
hbmScnBufferOld = SelectObject(hdcScnBuffer, hbmScnBuffer)
BitBlt hdcScnBuffer, 0, 0, nWidth, nHeight, hdcDest, xDest, yDest, vbSrcCopy
hbmColor = CreateCompatibleBitmap(hdcScreen, nWidth, nHeight)
hbmMask = CreateBitmap(nWidth, nHeight, 1, 1, ByVal 0&)
hdcColor = CreateCompatibleDC(hdcScreen)
hbmColorOld = SelectObject(hdcColor, hbmColor)
Call SetBkColor(hdcColor, GetBkColor(hdcSrc))
Call SetTextColor(hdcColor, GetTextColor(hdcSrc))
Call BitBlt(hdcColor, 0, 0, nWidth, nHeight, hdcSrc, xSrc, ySrc, vbSrcCopy)
hdcMask = CreateCompatibleDC(hdcScreen)
hbmMaskOld = SelectObject(hdcMask, hbmMask)
SetBkColor hdcColor, lMaskColor
SetTextColor hdcColor, vbWhite
BitBlt hdcMask, 0, 0, nWidth, nHeight, hdcColor, 0, 0, vbSrcCopy
SetTextColor hdcColor, vbBlack
SetBkColor hdcColor, vbWhite
BitBlt hdcColor, 0, 0, nWidth, nHeight, hdcMask, 0, 0, DSna
BitBlt hdcScnBuffer, 0, 0, nWidth, nHeight, hdcMask, 0, 0, vbSrcAnd
BitBlt hdcScnBuffer, 0, 0, nWidth, nHeight, hdcColor, 0, 0, vbSrcPaint
BitBlt hdcDest, xDest, yDest, nWidth, nHeight, hdcScnBuffer, 0, 0, vbSrcCopy
'clear
DeleteObject SelectObject(hdcColor, hbmColorOld)
DeleteDC hdcColor
DeleteObject SelectObject(hdcScnBuffer, hbmScnBufferOld)
DeleteDC hdcScnBuffer
DeleteObject SelectObject(hdcMask, hbmMaskOld)
DeleteDC hdcMask
'ReleaseDC 0, hdcScreen
End Sub
Private Function GetRgbQuad(ByVal R As Byte, ByVal G As Byte, ByVal B As Byte) As RGBQUAD
With GetRgbQuad
.rgbBlue = B
.rgbGreen = G
.rgbRed = R
End With
End Function
Private Function DrawPictureDisabled(ByVal P As StdPicture, x As Long, y As Long, _
w As Long, h As Long, _
Optional ColHighlight As Long = vb3DHighlight, _
Optional ColShadow As Long = vb3DShadow)
Dim MemDC As Long
Dim MyBmp As Long
Dim cShadow As Long
Dim cHiglight As Long
Dim ColPal(0 To 1) As RGBQUAD
Dim rgbBlack As RGBQUAD
Dim rgbWhite As RGBQUAD
Dim BI As BITMAPINFO
Dim hdc As Long
Dim hPicDc As Long
Dim hPicBmp As Long
hdc = UserControl.hdc
cHiglight = TranslateColor(vb3DHighlight)
cShadow = TranslateColor(vb3DShadow)
'rgbBlack = GetRgbQuad(0, 0, 0)
rgbWhite = GetRgbQuad(255, 255, 255)
With BI.bmiHeader
.biSize = 40 'size of bmiHeader structure
.biHeight = -h
.biWidth = w
.biPlanes = 1
.biCompression = 0 'BI_RGB
.biClrImportant = 0
.biBitCount = 1 'monohrome bitmap
End With
'color palete
With BI
.bmiColors(0) = rgbBlack
.bmiColors(1) = rgbWhite
End With
Dim hMonoSec As Long
Dim pBits As Long
Dim hdcMono As Long
hMonoSec = CreateDIBSection(hdc, BI, 0, pBits, 0&, 0&)
'Debug.Print "MonoSec:"; hMonoSec
hdcMono = CreateCompatibleDC(hdc)
SelectObject hdcMono, hMonoSec
'create dc for picture
hPicDc = CreateCompatibleDC(hdc)
If P.Type = vbPicTypeIcon Then
hPicBmp = CreateCompatibleBitmap(hdc, w, h)
SelectObject hPicDc, hPicBmp
DeleteObject hPicBmp
ClearRect hPicDc, SetRect(0, 0, w, h), TranslateColor(m_PictureTColor)
DrawIconEx hPicDc, 0, 0, P.handle, w, h, 0, 0, DI_NORMAL
'Debug.Print "DRAW ICON"
ElseIf P.Type = vbPicTypeBitmap Then
SelectObject hPicDc, P.handle
End If
'copy hPicDc to hdcMono
BitBlt hdcMono, 0, 0, w, h, hPicDc, 0, 0, SRCCOPY
DeleteDC hPicDc
Dim R As Integer, G As Integer, B As Integer
GetRgb cHiglight, R, G, B
'change black color in palete to highlight(r,g,b) color
ColPal(0) = GetRgbQuad(R, G, B)
ColPal(1) = rgbBlack 'change white color in palete to black color
SetDIBColorTable hdcMono, 0, 2, ColPal(0) 'set new palete
RealizePalette hdcMono 'update it
'BitBlt Me.hdc, 1, 1, W, H, hdcMono, 0, 0, SRCCOPY
'transparent blit to dest hDC using black as transparent colour
'x+1 and y+1 - moves down and left for 1 pixel
TransBlt hdc, x + 1, y + 1, w, h, hdcMono, 0, 0, 0
'get rgb components of shadow color
GetRgb cShadow, R, G, B
'change black color to shadow color in palete
ColPal(0) = GetRgbQuad(R, G, B)
ColPal(1) = rgbWhite 'change back to white
'set new palete
SetDIBColorTable hdcMono, 0, 2, ColPal(0)
RealizePalette hdcMono ' then update
'transparent blit do dest hdc using white color as transparent
TransBlt hdc, x, y, w, h, hdcMono, 0, 0, #ffffff
'BitBlt Me.hDC, 0, 0, W, H, hdcMono, 0, 0, SRCCOPY
'Debug.Print DeleteObject(hMonoSec)
'Debug.Print DeleteObject(hdcMono)
End Function
Sub GetRgb(Color As Long, R As Integer, G As Integer, B As Integer)
R = Color And 255 'clear bites from 9 to 32
G = (Color \ 256) And 255 'shift right 8 bits and clear
B = (Color \ 65536) And 255 'shift 16 bits and clear for any case
End Sub
Private Function GetBmpSize(Bmp As StdPicture, w As Long, h As Long) As Long
' Dim B As BITMAP
' GetBmpSize = GetObject(Bmp, Len(B), B)
w = ScaleX(Bmp.Width, vbHimetric, vbPixels)
h = ScaleY(Bmp.Height, vbHimetric, vbPixels)
' Debug.Print W, H
' W = B.bmWidth
' H = B.bmHeight
' Debug.Print B.bmType
' Debug.Print W, H
End Function
Private Sub DrawPicture(hdc As Long, P As StdPicture, x As Long, y As Long, w As Long, h As Long, TOleCol As Long)
'check picture format
If P.Type = vbPicTypeIcon Then
DrawIconEx hdc, x, y, P.handle, w, h, 0, 0, DI_NORMAL
Exit Sub
End If
'creting dc with the same format as screen dc
Dim MemDC As Long
MemDC = CreateCompatibleDC(0)
'select a picture into memdc
SelectObject MemDC, P.handle '
'tranparent blit memdc on usercontrol
TransBlt UserControl.hdc, x, y, w, h, MemDC, 0, 0, TranslateColor(TOleCol)
DeleteDC MemDC 'its clear, heh
End Sub
Private Function ModifyRect(lpRect As RECT, ByVal Left As Long, ByVal Top As Long, _
ByVal Right As Long, ByVal Bottom As Long) As RECT
With ModifyRect
.Left = lpRect.Left + Left
.Top = lpRect.Top + Top
.Right = lpRect.Right + Right
.Bottom = lpRect.Bottom + Bottom
End With
End Function
Private Function TranslateColor(ByVal Ole_Color As Long) As Long
apiTranslateColor Ole_Color, 0, TranslateColor
End Function
Private Function SetRect(ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long) As RECT
With SetRect
.Left = Left
.Top = Top
.Right = Right
.Bottom = Bottom
End With
End Function
Private Sub NormalizeRect(R As RECT)
Dim c As Long
If R.Left > R.Right Then
c = R.Right
R.Right = R.Left
R.Left = c
End If
If R.Top > R.Bottom Then
c = R.Top
R.Top = R.Bottom
R.Bottom = c
End If
End Sub
Private Function RoundUp(ByVal num As Single) As Long
If Int(num) < num Then
RoundUp = Int(num) + 1
Else
RoundUp = num
End If
End Function
Private Function RectHeight(R As RECT) As Long
RectHeight = R.Bottom - R.Top
End Function
Private Function RectWidth(R As RECT) As Long
RectWidth = R.Right - R.Left
End Function
Function TxtFix(StrText As String, MaxWidth As Long) As String
Dim i As Long, j As Long
Dim StrLeft As String, TxtTemp As String
TxtTemp = StrText
TxtFix = ""
For i = Len(TxtTemp) To 1 Step -1
For j = Len(TxtTemp) To 1 Step -1
If UserControl.TextWidth(Left(TxtTemp, j)) <= MaxWidth Then
StrLeft = Left(TxtTemp, j)
TxtTemp = Right(TxtTemp, Len(TxtTemp) - j)
If TxtFix = "" Then
TxtFix = StrLeft
Else
TxtFix = TxtFix & vbCrLf & StrLeft
End If
Exit For
End If
Next j
Next i
End Function
Private Sub DrawText(ByVal hdc As Long, ByVal StrText As String, R As RECT, ByVal Format As Long)
Dim TempText As String, TempHeight As Long, TempTop As Long, Rc As RECT
TempText = TxtFix(StrText, R.Right - R.Left)
TempHeight = UserControl.TextHeight(TempText)
TempTop = R.Top - (R.Top - R.Bottom) / 2 - TempHeight / 2
Rc = SetRect(R.Left, TempTop, R.Right, TempTop + TempHeight)
With UserControl
apiDrawText .hdc, StrText, lstrlen(StrText), Rc, Format
End With
End Sub
Private Sub TilePicture(DestRect As RECT, SrcRect As RECT, ByVal SrcDc As Long, Optional UseCliper As Boolean = True, Optional ROp As Long = SRCCOPY)
Dim i As Integer
Dim j As Integer
Dim rows As Integer
Dim ColS As Integer
Dim destW As Long
Dim destH As Long
Dim hdc As Long
hdc = UserControl.hdc
NormalizeRect DestRect
NormalizeRect SrcRect
'calculates row and cols
rows = RoundUp(RectHeight(DestRect) / RectHeight(SrcRect))
ColS = RoundUp(RectWidth(DestRect) / RectWidth(SrcRect))
destW = RectWidth(SrcRect)
destH = RectHeight(SrcRect)
'prevents drawing out of specified rectangle
If UseCliper Then
SelectClipRgn hdc, ByVal 0
BeginPath hdc
With DestRect
Rectangle hdc, .Left, .Top, .Right + 1, .Bottom + 1
End With
EndPath hdc
SelectClipPath hdc, RGN_AND
End If
For i = 0 To rows - 1
For j = 0 To ColS - 1
BitBlt hdc, j * destW + DestRect.Left, i * destH + DestRect.Top, destW, destH, SrcDc, _
SrcRect.Left, SrcRect.Top, ROp
Next
Next
If UseCliper Then
SelectClipRgn hdc, ByVal 0
End If
End Sub
Private Sub ClearRect(ByVal hdc As Long, lRect As RECT, ByVal Color As Long)
Dim Brush As Long
Dim PBrush As Long
Brush = CreateSolidBrush(Color)
PBrush = SelectObject(hdc, Brush)
FillRect hdc, lRect, Brush
DeleteObject SelectObject(hdc, PBrush)
End Sub
'//END GDI####################################
'#############################################
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=8,0,0,3
Public Property Get SizeCW() As Long
SizeCW = m_SizeCW
End Property
Public Property Let SizeCW(ByVal New_SizeCW As Long)
m_SizeCW = New_SizeCW
PropertyChanged "SizeCW"
Refresh
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=8,0,0,3
Public Property Get SizeCH() As Long
SizeCH = m_SizeCH
End Property
Public Property Let SizeCH(ByVal New_SizeCH As Long)
m_SizeCH = New_SizeCH
PropertyChanged "SizeCH"
Refresh
End Property
Public Property Get TextLine() As Integer
TextLine = m_TextLine
End Property
Public Property Let TextLine(ByVal New_TextLine As Integer)
m_TextLine = New_TextLine
PropertyChanged "TextLine"
Refresh
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=9,0,0,0
Public Property Get SkinPicture() As Object
Set SkinPicture = m_SkinPicture
End Property
Public Property Set SkinPicture(New_SkinPicture As Object)
If (TypeName(New_SkinPicture) <> "PictureBox") And _
(New_SkinPicture Is Nothing = False) Then
Err.Raise 5, "MyButton::SkinPicture", Err.Description
Exit Property
End If
Set m_SkinPicture = New_SkinPicture
If m_SkinPicture Is Nothing = False Then
m_SkinPictureName = m_SkinPicture.Name
Else
m_SkinPictureName = ""
End If
Refresh
PropertyChanged "SPN"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=13,0,0,
Public Property Get Text() As String
Text = m_Text
End Property
Public Property Let Text(ByVal New_Text As String)
m_Text = New_Text
Refresh
PropertyChanged "Text"
'setting access key (allows alt + accesskey)
Dim i As Long
Dim c As String
For i = 1 To Len(New_Text) - 1
If Mid(New_Text, i, 1) = "&" Then
c = Mid(New_Text, i + 1, 1)
If c <> "&" Or c <> " " Then
UserControl.AccessKeys = c
PropertyChanged "AccessKey"
End If
End If
Next
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=13,0,0,
Public Property Get SkinPictureName() As String
'If m_SkinPicture Is Nothing = False Then
'SkinPictureName = m_SkinPicture.Name
SkinPictureName = m_SkinPictureName
'End If
End Property
Public Property Let SkinPictureName(ByVal New_SkinPictureName As String)
On Error GoTo NotLegalName
Dim P As Object
'Debug.Print New_SkinPictureName
If New_SkinPictureName <> "" Then
Set P = UserControl.Parent.Controls(New_SkinPictureName)
If P Is Nothing = False Then
Set SkinPicture = P
'Debug.Print "Setting p"; P.Name
End If
Else
Set m_SkinPicture = Nothing
'Debug.Print "P is nothing"
Refresh
End If
' m_SkinPictureName = New_SkinPictureName
PropertyChanged "SPN"
NotLegalName:
End Property
Private Sub UserControl_DblClick()
DrawButton BTN_DOWN
End Sub
Private Sub UserControl_GotFocus()
m_HasFocus = True
If m_BtnDown = False Then DrawButton BTN_FOCUS
End Sub
Private Sub UserControl_Initialize()
' SkinPictureName = m_SkinPictureName
' MsgBox "Initialize..." + m_SkinPictureName
End Sub
'Initialize Properties for User Control
Private Sub UserControl_InitProperties()
m_SizeCW = m_def_SizeCW
m_SizeCH = m_def_SizeCH
m_Text = Extender.Name
m_FillWithColor = m_def_FillWithColor
m_TextColorEnabled = m_def_TextColorEnabled
m_TextColorDisabled = m_def_TextColorDisabled
Set UserControl.Font = Ambient.Font
m_DisableHover = m_def_DisableHover
m_DisplaceText = m_def_DisplaceText
m_TextLine = m_def_TextLine
m_DrawFocus = m_def_DrawFocus
m_TextColorDisabled2 = m_def_TextColorDisabled2
Set m_Picture = LoadPicture("")
m_PicturePos = m_def_PicturePos
m_PictureTColor = m_def_PictureTColor
m_SkinPictureName = "MyButtonDefSkin"
m_TextAlign = m_def_TextAlign
End Sub
Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
RaiseEvent KeyDown(KeyCode, Shift)
If KeyCode = vbKeySpace Then
m_SpcDown = True
DrawButton BTN_DOWN
Else
m_SpcDown = False
DrawButton BTN_FOCUS
End If
End Sub
Private Sub UserControl_KeyPress(KeyAscii As Integer)
RaiseEvent KeyPress(KeyAscii)
If KeyAscii = vbKeyReturn Then
RaiseEvent Click
End If
End Sub
Private Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)
RaiseEvent KeyUp(KeyCode, Shift)
If KeyCode = 32 And m_SpcDown And m_State = BTN_DOWN Then
m_SpcDown = False
DrawButton BTN_NORMAL
RaiseEvent Click
DrawButton BTN_FOCUS
End If
End Sub
Private Sub UserControl_LostFocus()
m_HasFocus = False
DrawButton BTN_NORMAL
End Sub
Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
RaiseEvent MouseDown(Button, Shift, x, y)
If Button = 1 Then m_BtnDown = True
UserControl_MouseMove Button, Shift, x, y
End Sub
Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
If m_SpcDown Then Exit Sub
RaiseEvent MouseMove(Button, Shift, x, y)
SetCapture hwnd
If PointInControl(x, y) Then
'if pointer is on control
If m_BtnDown Then
If m_State <> BTN_DOWN Then
DrawButton BTN_DOWN
End If
Else
If m_State <> BTN_HOVER Then
RaiseEvent MouseHover
DrawButton BTN_HOVER
End If
End If
Else
'if pointer is out of control
If m_BtnDown Then
RaiseEvent MouseHover
DrawButton BTN_HOVER
Else
RaiseEvent MouseOut
If m_HasFocus Then
DrawButton BTN_FOCUS
Else
DrawButton BTN_NORMAL
End If
ReleaseCapture
End If
End If
End Sub
Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
m_BtnDown = False
' If m_State <> BTN_NORMAL Then
DrawButton BTN_NORMAL
' End If
RaiseEvent MouseUp(Button, Shift, x, y)
If Button = vbLeftButton Then
If PointInControl(x, y) Then RaiseEvent Click
' If m_State <> BTN_FOCUS Then
DrawButton BTN_FOCUS
' End If
End If
End Sub
Private Sub UserControl_Paint()
Me.Refresh
End Sub
'Load property values from storage
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
m_SizeCW = PropBag.ReadProperty("SizeCW", m_def_SizeCW)
m_SizeCH = PropBag.ReadProperty("SizeCH", m_def_SizeCH)
m_SkinPictureName = PropBag.ReadProperty("SPN", "")
'Debug.Print "ReadProp SPN:"; m_SkinPictureName
m_TextLine = PropBag.ReadProperty("TextLine", m_def_TextLine)
m_Text = PropBag.ReadProperty("Text", m_def_Text)
m_FillWithColor = PropBag.ReadProperty("FillWithColor", m_def_FillWithColor)
UserControl.Enabled = PropBag.ReadProperty("Enabled", True)
UserControl.AccessKeys = PropBag.ReadProperty("AccessKey", "")
m_TextColorEnabled = PropBag.ReadProperty("TextColorEnabled", m_def_TextColorEnabled)
m_TextColorDisabled = PropBag.ReadProperty("TextColorDisabled", m_def_TextColorDisabled)
Set UserControl.Font = PropBag.ReadProperty("Font", Ambient.Font)
UserControl.MousePointer = PropBag.ReadProperty("MousePointer", 0)
Set MouseIcon = PropBag.ReadProperty("MouseIcon", Nothing)
m_DisableHover = PropBag.ReadProperty("DisableHover", m_def_DisableHover)
' m_DownTextDX = PropBag.ReadProperty("DownTextDX", m_def_DownTextDX)
' m_DownTextDY = PropBag.ReadProperty("DownTextDY", m_def_DownTextDY)
m_DisplaceText = PropBag.ReadProperty("DisplaceText", m_def_DisplaceText)
m_DrawFocus = PropBag.ReadProperty("DrawFocus", m_def_DrawFocus)
m_TextColorDisabled2 = PropBag.ReadProperty("TextColorDisabled2", m_def_TextColorDisabled2)
Set m_Picture = PropBag.ReadProperty("Picture", Nothing)
m_PicturePos = PropBag.ReadProperty("PicturePos", m_def_PicturePos)
m_PictureTColor = PropBag.ReadProperty("PictureTColor", m_def_PictureTColor)
m_TextAlign = PropBag.ReadProperty("TextAlign", m_def_TextAlign)
UserControl.BackColor = PropBag.ReadProperty("BackColor", &H8000000F)
End Sub
Private Sub UserControl_Resize()
Refresh
End Sub
Private Sub UserControl_Show()
SkinPictureName = m_SkinPictureName
' Refresh
End Sub
Private Sub UserControl_Terminate()
Set m_SkinPicture = Nothing
Set m_Picture = Nothing
'Set UserControl = Nothing
'Set Me = Nothing
'Debug.Print "TERMINATE"
End Sub
'Write property values to storage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
Call PropBag.WriteProperty("SizeCW", m_SizeCW, m_def_SizeCW)
Call PropBag.WriteProperty("SizeCH", m_SizeCH, m_def_SizeCH)
'If m_SkinPicture Is Nothing = False Then
Call PropBag.WriteProperty("SPN", m_SkinPictureName, "")
'End If
'Debug.Print "Write :"; m_SkinPictureName
Call PropBag.WriteProperty("TextLine", m_def_TextLine)
Call PropBag.WriteProperty("Text", m_Text, m_def_Text)
Call PropBag.WriteProperty("FillWithColor", m_FillWithColor, m_def_FillWithColor)
Call PropBag.WriteProperty("Enabled", UserControl.Enabled, True)
Call PropBag.WriteProperty("AccessKey", UserControl.AccessKeys, "")
Call PropBag.WriteProperty("TextColorEnabled", m_TextColorEnabled, m_def_TextColorEnabled)
Call PropBag.WriteProperty("TextColorDisabled", m_TextColorDisabled, m_def_TextColorDisabled)
Call PropBag.WriteProperty("Font", UserControl.Font, Ambient.Font)
Call PropBag.WriteProperty("MousePointer", UserControl.MousePointer, 0)
Call PropBag.WriteProperty("MouseIcon", MouseIcon, Nothing)
Call PropBag.WriteProperty("DisableHover", m_DisableHover, m_def_DisableHover)
Call PropBag.WriteProperty("DisplaceText", m_DisplaceText, m_def_DisplaceText)
Call PropBag.WriteProperty("DrawFocus", m_DrawFocus, m_def_DrawFocus)
Call PropBag.WriteProperty("TextColorDisabled2", m_TextColorDisabled2, m_def_TextColorDisabled2)
Call PropBag.WriteProperty("Picture", m_Picture, Nothing)
Call PropBag.WriteProperty("PicturePos", m_PicturePos, m_def_PicturePos)
Call PropBag.WriteProperty("PictureTColor", m_PictureTColor, m_def_PictureTColor)
Call PropBag.WriteProperty("TextAlign", m_TextAlign, m_def_TextAlign)
Call PropBag.WriteProperty("BackColor", UserControl.BackColor, &H8000000F)
End Sub
Private Sub DrawButton(ByVal State As Integer)
If m_DisableHover Then
If State = BTN_HOVER Then Exit Sub
'dont draw hover state if m_DisableHover is true
End If
' Debug.Print "State1 "; State
On Error GoTo UnknownError
Dim PicW As Long
Dim PicH As Long 'width and height of picture
Dim PicX As Long
Dim PicY As Long 'picture pos
Dim DH As Long 'button height
Dim dw As Long 'button width
Dim Align As Long 'text aligment
Dim bDrawText As Boolean ' if picture is in center text is not drawn
bDrawText = True
Align = DT_VCENTER Or DT_END_ELLIPSIS Or DT_WORDBREAK
Select Case m_TextAlign
Case Is = vbLeftJustify: Align = Align Or DT_LEFT
Case Is = vbRightJustify: Align = Align Or DT_RIGHT
Case Is = vbCenter: Align = Align Or DT_CENTER
End Select
dw = UserControl.ScaleWidth
DH = UserControl.ScaleHeight
m_State = State
'if skin picture is not set then just draw text on control
If m_SkinPicture Is Nothing Then
ClearRect hdc, SetRect(0, 0, dw, DH), TranslateColor(UserControl.BackColor)
DrawText hdc, m_Text, SetRect(0, 0, dw, DH), Align
If UserControl.AutoRedraw = True Then
UserControl.Refresh
End If
Exit Sub
End If
m_SkinPicture.ScaleMode = vbPixels
Dim SrcLeft As Long 'left cordinate of skin in skinpicture
Dim SrcRight As Long 'right -II-
Dim FillColor As Long 'color to fill middle area of button
'used if m_FillWithColor is true
Dim h As Long 'height of skinpicture
Dim w As Long 'width of button skin
h = m_SkinPicture.ScaleHeight
w = m_SkinPicture.ScaleWidth / 5
'Debug.Print H, W
'
SrcLeft = (State - 1) * w
SrcRight = State * w
If m_FillWithColor Then
'get color to fill with from (SrcLeft+m_SizeCW +1 , m_SizeCH+1) on
'skin picture
FillColor = m_SkinPicture.Point(SrcLeft + m_SizeCW + 1, m_SizeCH + 1)
End If
'Exit Sub
ClearRect hdc, SetRect(0, 0, dw, DH), TranslateColor(UserControl.BackColor)
If m_FillWithColor Then
'paint button with fillcolor
'NOTE: it would be nice if there is gradient file
ClearRect hdc, SetRect(m_SizeCW, m_SizeCH, dw - m_SizeCW, DH - m_SizeCH), FillColor
'ABOUT ADDING GRADIENT FILL
'read second color from skin at
'point (srcleft+cw+1, H -m_sizeCH-1)
'may be implemented in MyButton2
Else
'tile skin
TilePicture SetRect(m_SizeCW, m_SizeCH, dw - m_SizeCW, DH - m_SizeCH), _
SetRect(SrcLeft + m_SizeCW, m_SizeCH, SrcRight - m_SizeCW, h - m_SizeCH), _
m_SkinPicture.hdc, False, SRCCOPY
End If
'draws borders
If (m_SizeCH > 0 And m_SizeCW > 0) Then
TilePicture SetRect(m_SizeCW, 0, dw, m_SizeCH), _
SetRect(SrcLeft + m_SizeCW, 0, SrcRight - m_SizeCW, m_SizeCH), _
m_SkinPicture.hdc, False, SRCCOPY
TilePicture SetRect(m_SizeCW, DH - m_SizeCH, dw, DH), _
SetRect(SrcLeft + m_SizeCW, h - m_SizeCH, SrcRight - m_SizeCW, h), _
m_SkinPicture.hdc, False, SRCCOPY
TilePicture SetRect(0, 0, m_SizeCW, DH), _
SetRect(SrcLeft, m_SizeCH, SrcLeft + m_SizeCW, h - m_SizeCH), _
m_SkinPicture.hdc, False, SRCCOPY
TilePicture SetRect(dw - m_SizeCW, m_SizeCH, dw, DH - m_SizeCH), _
SetRect(SrcRight - m_SizeCW, m_SizeCH, SrcRight, h - m_SizeCH), _
m_SkinPicture.hdc, False, SRCCOPY
'draws corners
'NOTE: must chage to transparent blit (done)
TransBlt hdc, 0, 0, m_SizeCW, m_SizeCH, m_SkinPicture.hdc, SrcLeft, 0, &HFF00FF
TransBlt hdc, 0, DH - m_SizeCH, m_SizeCW, m_SizeCH, m_SkinPicture.hdc, SrcLeft, h - m_SizeCH, &HFF00FF
TransBlt hdc, dw - m_SizeCW, 0, m_SizeCW, m_SizeCH, m_SkinPicture.hdc, SrcRight - m_SizeCW, 0, &HFF00FF
TransBlt hdc, dw - m_SizeCW, DH - m_SizeCH, m_SizeCW, m_SizeCH, m_SkinPicture.hdc, SrcRight - m_SizeCW, h - m_SizeCH, &HFF00FF
End If
Dim Pcolor As Long 'previous color
Pcolor = UserControl.ForeColor
Dim TextRect As RECT
If State = BTN_DOWN Then
TextRect = SetRect(3 + m_DisplaceText, 3 + m_DisplaceText, dw - 3 + m_DisplaceText - 3, DH - 3 + m_DisplaceText)
Else
TextRect = SetRect(3, 3, dw - 3 - 3, DH - 3)
End If
If m_Picture Is Nothing Then
If m_State = BTN_DISABLED Then
'draw text only
'dont draw text2 if colors are the same
If m_TextColorDisabled <> m_TextColorDisabled2 Then
UserControl.ForeColor = m_TextColorDisabled2
TextRect = ModifyRect(TextRect, 1, 1, 1, 1)
DrawText hdc, m_Text, TextRect, Align
TextRect = ModifyRect(TextRect, -1, -1, -1, -1)
End If
UserControl.ForeColor = m_TextColorDisabled
DrawText hdc, m_Text, TextRect, Align
Else
'draw text only
UserControl.ForeColor = m_TextColorEnabled
DrawText hdc, m_Text, TextRect, Align
End If
Else
GetBmpSize m_Picture, PicW, PicH
PicY = (DH - PicH) / 2
If m_State = BTN_DOWN Then
PicY = PicY + m_DisplaceText
End If
Select Case m_PicturePos
Case Is = ppLeft
PicX = TextRect.Left + 3
TextRect.Left = PicX + PicW + TextRect.Left
Case Is = ppRight
PicX = TextRect.Right - PicW - 3 + TextRect.Left - 3
TextRect.Right = PicX - 3
Case Is = ppTop
PicX = (dw - PicW) / 2 + TextRect.Left - SizeCW
PicY = (DH - PicH - 3 - UserControl.TextHeight("I")) / 2 + TextRect.Top - SizeCH
TextRect.Top = PicY + PicW + 3
TextRect.Bottom = TextRect.Top + UserControl.TextHeight("I") * 1.2
Case Is = ppBottom
TextRect.Top = (DH - PicH - 3 - UserControl.TextHeight("I")) / 2 + TextRect.Top - SizeCH
PicX = (dw - PicW) / 2 + TextRect.Left - SizeCW
TextRect.Bottom = TextRect.Top + UserControl.TextHeight("I") * 1.2
PicY = TextRect.Bottom + 3
Case Is = ppCenter
PicX = (dw - PicW) / 2
If BTN_DOWN Then PicX = PicX + m_DisplaceText
bDrawText = False
End Select
' Debug.Print "State2 "; State
If m_State = BTN_DISABLED Then
'draw text and picture disabled
DrawPictureDisabled m_Picture, PicX, PicY, PicW, PicH
If m_TextColorDisabled <> m_TextColorDisabled2 Then
If bDrawText Then
UserControl.ForeColor = m_TextColorDisabled2
TextRect = ModifyRect(TextRect, 1, 1, 1, 1)
DrawText hdc, m_Text, TextRect, Align
TextRect = ModifyRect(TextRect, -1, -1, -1, -1)
End If
End If
UserControl.ForeColor = m_TextColorDisabled
If bDrawText Then
DrawText hdc, m_Text, TextRect, Align
End If
Else
'draw text and picture enabled
UserControl.ForeColor = m_TextColorEnabled
If bDrawText Then
DrawText hdc, m_Text, TextRect, Align
End If
DrawPicture hdc, m_Picture, PicX, PicY, PicW, PicH, m_PictureTColor
End If
End If
Dim f As Long
If m_DrawFocus > 0 Then
If State = BTN_DOWN Or State = BTN_FOCUS Then
f = CLng(m_DrawFocus)
DrawFocusRect hdc, SetRect(f, f, dw - f, DH - f)
End If
End If
UserControl.ForeColor = Pcolor
If UserControl.AutoRedraw = True Then
UserControl.Refresh
End If
Exit Sub
UnknownError:
'most important line in this function
'i about 2 hours to find out
Set m_SkinPicture = Nothing
'removing this line form will not unload properly
End Sub
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=0,0,0,True
Public Property Get FillWithColor() As Boolean
FillWithColor = m_FillWithColor
End Property
Public Property Let FillWithColor(ByVal New_FillWithColor As Boolean)
m_FillWithColor = New_FillWithColor
Refresh
PropertyChanged "FillWithColor"
End Property
Public Sub Refresh()
If m_State < 1 Or m_State > 5 Then m_State = 1
If Enabled Then
DrawButton m_State
Else
DrawButton BTN_DISABLED
End If
End Sub
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,hWnd
Public Property Get hwnd() As Long
hwnd = UserControl.hwnd
End Property
Private Function PointInControl(x As Single, y As Single) As Boolean
If x >= 0 And x <= UserControl.ScaleWidth And _
y >= 0 And y <= UserControl.ScaleHeight Then
PointInControl = True
End If
End Function
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,Enabled
Public Property Get Enabled() As Boolean
Enabled = UserControl.Enabled
End Property
Public Property Let Enabled(ByVal New_Enabled As Boolean)
UserControl.Enabled() = New_Enabled
If New_Enabled Then
DrawButton BTN_NORMAL
Else
DrawButton BTN_DISABLED
End If
PropertyChanged "Enabled"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=10,0,0,0
Public Property Get TextColorEnabled() As Ole_Color
TextColorEnabled = m_TextColorEnabled
End Property
Public Property Let TextColorEnabled(ByVal New_TextColorEnabled As Ole_Color)
m_TextColorEnabled = New_TextColorEnabled
Refresh
PropertyChanged "TextColorEnabled"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=10,0,0,0
Public Property Get TextColorDisabled() As Ole_Color
TextColorDisabled = m_TextColorDisabled
End Property
Public Property Let TextColorDisabled(ByVal New_TextColorDisabled As Ole_Color)
m_TextColorDisabled = New_TextColorDisabled
Refresh
PropertyChanged "TextColorDisabled"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,Font
Public Property Get Font() As Font
Set Font = UserControl.Font
End Property
Public Property Set Font(ByVal New_Font As Font)
Set UserControl.Font = New_Font
Refresh
PropertyChanged "Font"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,FontUnderline
Public Property Get FontUnderline() As Boolean
FontUnderline = UserControl.FontUnderline
End Property
Public Property Let FontUnderline(ByVal New_FontUnderline As Boolean)
UserControl.FontUnderline() = New_FontUnderline
Refresh
PropertyChanged "Font"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,FontStrikethru
Public Property Get FontStrikethru() As Boolean
FontStrikethru = UserControl.FontStrikethru
End Property
Public Property Let FontStrikethru(ByVal New_FontStrikethru As Boolean)
UserControl.FontStrikethru() = New_FontStrikethru
Refresh
PropertyChanged "Font"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,FontSize
Public Property Get FontSize() As Single
FontSize = UserControl.FontSize
End Property
Public Property Let FontSize(ByVal New_FontSize As Single)
UserControl.FontSize() = New_FontSize
Refresh
PropertyChanged "Font"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,FontName
Public Property Get FontName() As String
FontName = UserControl.FontName
End Property
Public Property Let FontName(ByVal New_FontName As String)
UserControl.FontName() = New_FontName
Refresh
PropertyChanged "Font"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,FontItalic
Public Property Get FontItalic() As Boolean
FontItalic = UserControl.FontItalic
End Property
Public Property Let FontItalic(ByVal New_FontItalic As Boolean)
UserControl.FontItalic() = New_FontItalic
Refresh
PropertyChanged "Font"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,FontBold
Public Property Get FontBold() As Boolean
FontBold = UserControl.FontBold
End Property
Public Property Let FontBold(ByVal New_FontBold As Boolean)
UserControl.FontBold() = New_FontBold
Refresh
PropertyChanged "Font"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,MousePointer
Public Property Get MousePointer() As MousePointerConstants
MousePointer = UserControl.MousePointer
End Property
Public Property Let MousePointer(ByVal New_MousePointer As MousePointerConstants)
UserControl.MousePointer() = New_MousePointer
PropertyChanged "MousePointer"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,MouseIcon
Public Property Get MouseIcon() As Picture
Set MouseIcon = UserControl.MouseIcon
End Property
Public Property Set MouseIcon(ByVal New_MouseIcon As Picture)
Set UserControl.MouseIcon = New_MouseIcon
PropertyChanged "MouseIcon"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=0,0,0,False
Public Property Get DisableHover() As Boolean
DisableHover = m_DisableHover
End Property
Public Property Let DisableHover(ByVal New_DisableHover As Boolean)
m_DisableHover = New_DisableHover
PropertyChanged "DisableHover"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=7,0,0,0
Public Property Get DisplaceText() As Integer
DisplaceText = m_DisplaceText
End Property
Public Property Let DisplaceText(ByVal New_DisplaceText As Integer)
m_DisplaceText = New_DisplaceText
PropertyChanged "DisplaceText"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=7,0,0,0
Public Property Get DrawFocus() As Integer
DrawFocus = m_DrawFocus
End Property
Public Property Let DrawFocus(ByVal New_DrawFocus As Integer)
m_DrawFocus = New_DrawFocus
PropertyChanged "DrawFocus"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=10,0,0,0
Public Property Get TextColorDisabled2() As Ole_Color
TextColorDisabled2 = m_TextColorDisabled2
End Property
Public Property Let TextColorDisabled2(ByVal New_TextColorDisabled2 As Ole_Color)
m_TextColorDisabled2 = New_TextColorDisabled2
Refresh
PropertyChanged "TextColorDisabled2"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=11,0,0,0
Public Property Get Picture() As StdPicture
Set Picture = m_Picture
End Property
Public Property Set Picture(ByVal New_Picture As StdPicture)
Set m_Picture = New_Picture
Refresh
PropertyChanged "Picture"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=7,0,0,0
Public Property Get PicturePos() As EnumPicturePos
PicturePos = m_PicturePos
End Property
Public Property Let PicturePos(ByVal New_PicturePos As EnumPicturePos)
m_PicturePos = New_PicturePos
Refresh
PropertyChanged "PicturePos"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=10,0,0,0
Public Property Get PictureTColor() As Ole_Color
PictureTColor = m_PictureTColor
End Property
Public Property Let PictureTColor(ByVal New_PictureTColor As Ole_Color)
m_PictureTColor = New_PictureTColor
Refresh
PropertyChanged "PictureTColor"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=8,0,0,0
Public Property Get TextAlign() As AlignmentConstants
TextAlign = m_TextAlign
End Property
Public Property Let TextAlign(ByVal New_TextAlign As AlignmentConstants)
m_TextAlign = New_TextAlign
Refresh
PropertyChanged "TextAlign"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,BackColor
Public Property Get BackColor() As Ole_Color
BackColor = UserControl.BackColor
End Property
Public Property Let BackColor(ByVal New_BackColor As Ole_Color)
UserControl.BackColor() = New_BackColor
Refresh
PropertyChanged "BackColor"
End Property
模块的实现（最后一步，最精彩的一步）：
其中，关于OCR匹配度计算的核心算法：
For i = 1 To bi24BitInfo.bmiHeader.biWidth
For j = 1 To bi24BitInfo.bmiHeader.biHeight
//对每一个取样后的宽度和高度组成的一个像素点进行相似度比对，相等的话，就将相似度++
If Pic2Bits(1, i, j) = PicBits(1, i, j) Then SameBits = SameBits + 1
Next j
Next i
AllBits = bi24BitInfo.bmiHeader.biSizeImage
//解算OCR的匹配度
OcrBits = SameBits / AllBits * 10000
（1）初始化各种变量和函数：
Public Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
Public Declare Function ExtFloodFill Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long, ByVal wFillType As Long) As Long
Public Declare Function FloodFill Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Public Declare Function Ellipse Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Public Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Public Const PS_SOLID = 0
Public Const PS_DASH = 1
Public Const FLOODFILLBORDER = 0
Public Const FLOODFILLSURFACE = 1
Public Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Public Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Public Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Public Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Public Declare Function SetStretchBltMode Lib "gdi32" (ByVal hdc As Long, ByVal nStretchMode As Long) As Long
Public Const STRETCH_ANDSCANS = 1
Public Const STRETCH_DELETESCANS = 3
Public Const STRETCH_HALFTONE = 4
Public Const STRETCH_ORSCANS = 2
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (Destination As Any, ByVal Length As Long)
Public Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Public Declare Function FillRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long, ByVal hBrush As Long) As Long
Public Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As POINTAPI, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
Public Const WINDING = 2
Public Const ALTERNATE = 1
Public Type POINTAPI
x As Long
y As Long
End Type
Public Type OcrType
SameBits As Long
ModeText As String
End Type
Public Type SAFEARRAY2
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As Long
CE0 As Long
LB0 As Long
CE1 As Long
LB1 As Long
End Type
Public Type BITMAPINFOHEADER '40 bytes
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Public Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
Public 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
Public Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Declare Function TransparentBlt Lib "msimg32.dll" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal crTransparent As Long) As Boolean
Public Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Public Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function GetTickCount Lib "kernel32" () As Long
Public Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, ByVal lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Public Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Public Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long
Public Const BI_RGB = 0&
Public Const DIB_RGB_COLORS = 0
Public Const IMAGE_BITMAP As Long = 0
Public Const LR_LOADFROMFILE As Long = &H10
Public Const LR_CREATEDIBSECTION As Long = &H2000
Public Const LR_DEFAULTCOLOR As Long = &H0
Public Const LR_COLOR As Long = &H2
Public Const SRCAND = &H8800C6
Public Const SRCCOPY = &HCC0020
Public Const SRCERASE = &H440328
Public Const SRCPAINT = &HEE0086
Public Const SRCINVERT = &H660046
Public Declare Function GetObjectA Lib "gdi32" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Public Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Public Declare Function SetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
//该函数设置边界值,color的边界值不能超过255，由于一个（R,G,B）的每一个单元只能在0--255之间
Public Function ksCheckBounds(ByVal Color As Long) As Byte
If Color > 255 Then
ksCheckBounds = 255
ElseIf Color > -1 Then
ksCheckBounds = Color
End If
End Function
//分别得到Red,Blue,Green的值，利用位运算
Public Function GetRedValue(Color As Long) As Integer
GetRedValue = Color And &HFF
End Function
Public Function GetGreenValue(Color As Long) As Integer
GetGreenValue = (Color And 65280) \ 256
End Function
Public Function GetBlueValue(Color As Long) As Integer
GetBlueValue = (Color And &HFF0000) \ 65536
End Function
//这个应该是一个排序的算法吧，研究中……
Function Kspxd(R() As OcrType, t As Long, w As Long)
Dim i As Long, j As Long, k As Long, x As Long, XType As OcrType
i = t
j = w
x = R(i).SameBits
XType = R(i)
Do
Do While (R(j).SameBits >= x) And (j > i)
j = j - 1
' DoEvents
Loop
If i < j Then
R(i) = R(j)
i = i + 1
End If
Do While (R(i).SameBits <= x) And (j > i)
i = i + 1
' DoEvents
Loop
If i < j Then
R(j) = R(i)
j = j - 1
End If
' DoEvents
Loop While i < j
R(i) = XType
If j - 1 > t Then Kspxd R, t, j - 1
If j + 1 < w Then Kspxd R, j + 1, w
End Function
//这是一个修正函数，如果num是一个double型浮点数的话，将其修正为整型的
Public Function LargeFix(num As Double)
LargeFix = Int(num) + 1
End Function
(2)最后一步，实现具体的OCR算法
为了增大OCR匹配度的准确率，增加两个小插件（过程），（1）考虑到颜色的不同模糊识别，加入二值化处理（2）去除文字外的一些多余部分
Public Function OcrBits(Pic1 As PictureBox, Pic2 As PictureBox) As Long '实际进行OCR识别的模块
Dim i As Long, j As Long
Dim hOldMap As Long
Dim PicBits() As Byte
Dim iBitmap As Long, iDC As Long
Dim bi24BitInfo As BITMAPINFO
Dim Pic2Bits() As Byte
Dim i2Bitmap As Long, i2DC As Long
Dim bi24Bit2Info As BITMAPINFO
Dim AllBits As Long, SameBits As Long
With bi24BitInfo.bmiHeader
.biBitCount = 32
.biCompression = BI_RGB
.biPlanes = 1
.biSize = Len(bi24BitInfo.bmiHeader)
.biWidth = Pic1.ScaleWidth
.biHeight = Pic1.ScaleHeight
.biSizeImage = .biWidth * 4 * .biHeight
End With
iDC = CreateCompatibleDC(0)
iBitmap = CreateDIBSection(iDC, bi24BitInfo, DIB_RGB_COLORS, ByVal 0&, ByVal 0&, ByVal 0&)
If iBitmap Then
hOldMap = SelectObject(iDC, iBitmap)
Else
DeleteObject iDC
Exit Function
End If
BitBlt iDC, 0, 0, bi24BitInfo.bmiHeader.biWidth, bi24BitInfo.bmiHeader.biHeight, Pic1.hdc, 0, 0, vbSrcCopy
ReDim PicBits(1 To 4, 1 To bi24BitInfo.bmiHeader.biWidth, 1 To bi24BitInfo.bmiHeader.biHeight) As Byte
GetBitmapBits iBitmap, bi24BitInfo.bmiHeader.biSizeImage, PicBits(1, 1, 1)
With bi24Bit2Info.bmiHeader
.biBitCount = 32
.biCompression = BI_RGB
.biPlanes = 1
.biSize = Len(bi24BitInfo.bmiHeader)
.biWidth = Pic2.ScaleWidth
.biHeight = Pic2.ScaleHeight
.biSizeImage = .biWidth * 4 * .biHeight
End With
i2DC = CreateCompatibleDC(0)
i2Bitmap = CreateDIBSection(i2DC, bi24Bit2Info, DIB_RGB_COLORS, ByVal 0&, ByVal 0&, ByVal 0&)
If i2Bitmap Then
hOldMap = SelectObject(i2DC, i2Bitmap)
Else
DeleteObject i2DC
Exit Function
End If
BitBlt i2DC, 0, 0, bi24Bit2Info.bmiHeader.biWidth, bi24Bit2Info.bmiHeader.biHeight, Pic2.hdc, 0, 0, vbSrcCopy
ReDim Pic2Bits(1 To 4, 1 To bi24Bit2Info.bmiHeader.biWidth, 1 To bi24Bit2Info.bmiHeader.biHeight) As Byte
GetBitmapBits i2Bitmap, bi24Bit2Info.bmiHeader.biSizeImage, Pic2Bits(1, 1, 1)
AreaHeight = LargeFix(Pic2.ScaleHeight / 4)
AreaWidth = LargeFix(Pic2.ScaleWidth / 4)
For i = 1 To bi24BitInfo.bmiHeader.biWidth
For j = 1 To bi24BitInfo.bmiHeader.biHeight
//对每一个取样后的宽度和高度组成的一个像素点进行相似度比对，相等的话，就将相似度++
If Pic2Bits(1, i, j) = PicBits(1, i, j) Then SameBits = SameBits + 1
Next j
Next i
AllBits = bi24BitInfo.bmiHeader.biSizeImage
//解算OCR的匹配度
OcrBits = SameBits / AllBits * 10000
If hOldMap Then DeleteObject SelectObject(iDC, hOldMap)
DeleteObject iDC
If hOldMap Then DeleteObject SelectObject(i2DC, hOldMap)
DeleteObject i2DC
End Function
Public Function BlackBits(Pic As PictureBox) '将图象简单二值化，主要是因为实时生成的文字不是纯黑色
Dim i As Long
Dim hOldMap As Long
Dim PicBits() As Byte
Dim iBitmap As Long, iDC As Long
Dim bi24BitInfo As BITMAPINFO
With bi24BitInfo.bmiHeader
.biBitCount = 32
.biCompression = BI_RGB
.biPlanes = 1
.biSize = Len(bi24BitInfo.bmiHeader)
.biWidth = Pic.ScaleWidth
.biHeight = Pic.ScaleHeight
.biSizeImage = .biWidth * 4 * .biHeight
End With
iDC = CreateCompatibleDC(0)
iBitmap = CreateDIBSection(iDC, bi24BitInfo, DIB_RGB_COLORS, ByVal 0&, ByVal 0&, ByVal 0&)
If iBitmap Then
hOldMap = SelectObject(iDC, iBitmap)
Else
DeleteObject iDC
Exit Function
End If
BitBlt iDC, 0, 0, bi24BitInfo.bmiHeader.biWidth, bi24BitInfo.bmiHeader.biHeight, Pic.hdc, 0, 0, vbSrcCopy
ReDim PicBits(0 To bi24BitInfo.bmiHeader.biSizeImage) As Byte
GetBitmapBits iBitmap, bi24BitInfo.bmiHeader.biSizeImage, PicBits(0)
For i = 0 To bi24BitInfo.bmiHeader.biSizeImage
If PicBits(i) <> 255 Then PicBits(i) = 0
Next i
SetBitmapBits iBitmap, bi24BitInfo.bmiHeader.biSizeImage, PicBits(0)
BitBlt Pic.hdc, 0, 0, bi24BitInfo.bmiHeader.biWidth, bi24BitInfo.bmiHeader.biHeight, iDC, 0, 0, vbSrcCopy
Pic.Refresh
If hOldMap Then DeleteObject SelectObject(iDC, hOldMap)
DeleteObject iDC
BlackBits = True
End Function
Function CutLetters(Pic As PictureBox) As RECT '切掉文字旁边不需要的部分，以提高识别率
Dim i As Long, j As Long
CutLetters.Left = -1
CutLetters.Right = -1
CutLetters.Top = -1
CutLetters.Bottom = -1
For i = 0 To Pic.ScaleWidth
For j = 0 To Pic.ScaleHeight
If GetPixel(Pic.hdc, i, j) = &H0& Then CutLetters.Left = i
Next j
If CutLetters.Left <> -1 Then Exit For
Next i
For i = Pic.ScaleWidth To 0 Step -1
For j = Pic.ScaleHeight To 0 Step -1
If GetPixel(Pic.hdc, i, j) = &H0& Then CutLetters.Right = i + 1
Next j
If CutLetters.Right <> -1 Then Exit For
Next i
For j = 0 To Pic.ScaleHeight
For i = 0 To Pic.ScaleWidth
If GetPixel(Pic.hdc, i, j) = &H0& Then CutLetters.Top = j
Next i
If CutLetters.Top <> -1 Then Exit For
Next j
For j = Pic.ScaleHeight To 0 Step -1
For i = Pic.ScaleWidth To 0 Step -1
If GetPixel(Pic.hdc, i, j) = &H0& Then CutLetters.Bottom = j + 1
Next i
If CutLetters.Bottom <> -1 Then Exit For
Next j
End Function
扫一扫
210
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
