vb手写笔迹源代码.frm

VERSION 5.00
Begin VB.Form Form1
AutoRedraw = -1 'True
Caption = "原笔迹"
ClientHeight = 5010
ClientLeft = 60
ClientTop = 450
ClientWidth = 8805
LinkTopic = "Form1"
ScaleHeight = 5010
ScaleWidth = 8805
StartUpPosition = 2 '屏幕中心
Begin mandButton Command2
Caption = "删除"
Height = 615
Left = 4320
TabIndex = 5
Top = 3840
Width = 2175
End
Begin mandButton Command1
BackColor = &H8000000E&
Caption = "复制"
Height = 615
Left = 6840
Style = 1 'Graphical
TabIndex = 4
Top = 3840
Width = 1815
End
Begin VB.PictureBox Picture1
AutoRedraw = -1 'True
AutoSize = -1 'True
BackColor = &H8000000E&
BorderStyle = 0 'None
FillStyle = 0 'Solid
Height = 3615
Left = 0
ScaleHeight = 3615
ScaleWidth = 8775
TabIndex = 3
Top = 120
Width = 8775
End
Begin VB.TextBox TextAdd
Height = 375
Left = 4080
TabIndex = 2
Text = "0.1"
ToolTipText = "笔画粗细增加量"
Top = 4560
Width = 975
End
Begin VB.TextBox TextLineWidth
Height = 375
Left = 2640
TabIndex = 1
Text = "5"
ToolTipText = "笔画最大宽度"
Top = 4560
Width = 975
End
Begin VB.TextBox TextSpeed
Height = 375
Left = 1080
TabIndex = 0
Text = "10"
ToolTipText = "平均书写速度"
Top = 4560
Width = 975
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Rem 转移输入焦点的声明
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Rem 窗口置顶的声明
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

Rem 移动没有标题栏窗体的声明
Private Declare Function ReleaseCapture Lib "u

ser32" () 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

Rem 模拟按键声明
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Rem 禁止本窗体拥有输入焦点的常数
Private Const HWND_NOTOPMOST = -2
Private Const WS_DISABLED = &H8000000
Private Const GWL_EXSTYLE = (-20)
Private Const GWL_STYLE = (-16)

Rem 窗口置顶的常数
Private Const HWND_TOPMOST = -1
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Const SWP_SHOWWINDOW = &H40

Rem 移动没有标题栏窗体的常数
Private Const HTCAPTION = 2
Private Const WM_NCLBUTTONDOWN = &HA1

Rem 模拟按钮常数
Private Const KEYEVENTF_KEYUP = &H2

Dim IsMouseDown As Boolean
Dim lastX, lastY As Single
Dim LineWidth As Single
Dim lastWidth As Single
Dim SpeedDoor As Single
Dim widthAdd As Single
Dim lastSpeed As Single
Dim times As Integer
Private Declare Function GetForegroundWindow Lib "user32" () As Long

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Sub Command2_Click()
SendKeys "{BKSP}"
Clipboard.Clear
Picture1.Picture = Nothing
End Sub

Rem 以下是程序执行主体部分
Rem 窗体调用时置顶，且禁止拥有输入焦点
Private Sub Form_Load()
Me.Show
SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOACTIVATE Or SWP_SHOWWINDOW Or SWP_NOMOVE Or SWP_NOSIZE

SetWindowLong Me.hwnd, GWL_EXSTYLE, GetWindowLong(Me.hwnd, GWL_EXSTYLE) Or WS_DISABLED

SpeedDoor = Val(TextSpeed.Text)
LineWidth = Val(TextLineWidth.Text)
widthAdd = Val(TextAdd.Text)

Picture1.DrawWidth = LineWidth
IsMouseDown = False
times = 0

End Sub

Rem 鼠标移动到窗体上时，窗体置顶
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOACTIVATE Or SWP_SHOWWINDOW Or SWP_NOMOVE Or SWP_NOSIZE
End Sub



Rem 防止执行多次
Private Sub Form_Initialize()
If App.PrevInstance Then End
End Sub



Private Sub Command1_Click()
' Picture1.PaintPicture Picture1.Image, 0, 0, Picture1.width / 2, Picture1.Height / 2, 0, 0, Picture1.width / 3, Picture1.Height / 3
Picture1.Picture = Picture1.Image
'Picture1.AutoRedraw = True
Clipboard.Clear
Clipboard.SetData Picture1.Image, vbCFBitmap

Picture1.Picture = Nothing
SendKeys "^V"
End Sub


Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
IsMouseDown = True
lastWidth = 1
lastSpeed = SpeedDoor
Picture1.DrawWidth = lastWidth
lastX = X
lastY = Y
End Sub

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Si

ngle, Y As Single)
Dim speed As Single
times = times + 1

If IsMouseDown Then
If times >= 2 Then
times = 0
speed = Abs(lastX - X) + Abs(lastY - Y)


If speed > SpeedDoor Then
lastWidth = lastWidth - widthAdd
ElseIf speed < SpeedDoor Then
lastWidth = lastWidth + widthAdd
End If

If lastWidth < 1 Then lastWidth = 1
If lastWidth > LineWidth Then lastWidth = LineWidth '最粗是linewith 最细是1
Picture1.DrawWidth = lastWidth


Picture1.Line (lastX, lastY)-(X, Y), vbBlue
lastX = X
lastY = Y

End If
End If
End Sub

Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
IsMouseDown = False

' Picture1.DrawWidth = 1
' Picture1.Line (lastX, lastY)-(X, Y), vbBlue
End Sub

Private Sub TextAdd_Change()
widthAdd = Val(TextAdd.Text)
End Sub

Private Sub TextLineWidth_Change()
LineWidth = Val(TextLineWidth.Text)
End Sub

Private Sub TextSpeed_Change()
SpeedDoor = Val(TextSpeed.Text)
End Sub