Create Form Signature Simple Visual Basic

 

  SIGNATURE SIMPLE FORM VISUAL BASIC

 

 1. Project Form Simple Signature With Visual Basic 

         

     

Design Form

2. Source Form FrmSignature

Option Explicit
Private DBCon As New ADODB.Connection
Private rsTemp As New ADODB.Recordset

Private Type PointApi
   x As Double
   y As Double
End Type

Private Point1 As PointApi
Private Point2 As PointApi
Private blnMouseDown As Boolean
Private strSQL As String
Dim theFile As String
Dim intResponse As Integer

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

Private Declare Sub ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINT)
Private Declare Sub ClipCursor Lib "user32" (lpRect As Any)
Private Declare Sub OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long)
Private Declare Sub GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT)

Private Type RECT
left As Integer
top As Integer
right As Integer
bottom As Integer
End Type

Private Type POINT
x As Long
y As Long
End Type



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



Private Sub cmdReset_Click()
    intResponse = MsgBox("Reset the signature?", vbQuestion + vbYesNo, "Confirm Reset")
    If intResponse = 7 Then Exit Sub
    picSignature.BackColor = vbWhite
    blnMouseDown = False
    Point1.x = 0
    Point2.x = 0
    Point1.y = 0
    Point2.y = 0
    picSignature.Picture = LoadPicture("")
    Me.txtPath.Text = ""
End Sub

Private Sub cmdSave_Click()
    If Len(txtPath) <= 0 Then
        MsgBox "Please input your filename here!"
        Exit Sub
    End If
    intResponse = MsgBox("Save this signature?", vbQuestion + vbYesNo, "Confirm")
    If intResponse = 7 Then Exit Sub
    SavePicture picSignature.Image, App.Path & "\Signatures\" & txtPath.Text & ".bmp"
    
    Open txtPath & ".bmp" For Binary Access Read As #1
        theFile = Space$(LOF(1))
        Get #1, , theFile
    Close #1
    picSignature.Picture = LoadPicture(App.Path & "\Signatures\" & txtPath.Text & ".bmp")
   ' SaveToDBase
    MsgBox "File Name: " & App.Path & "\Signatures\" & txtPath & ".bmp was successfully saved!" & vbNewLine & _
            "Picture file was also saved on the database as an OLE object!"
End Sub

Private Sub Command1_Click()
Dim client As RECT
Dim up As POINT
ClientToScreen Me.picSignature.hwnd, up
GetClientRect Me.picSignature.hwnd, client
OffsetRect client, up.x, up.y
up.x = client.left
up.y = client.top
ClipCursor client
End Sub

Private Sub Command2_Click()
ClipCursor ByVal 0&
End Sub



Private Sub picSignature_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    blnMouseDown = True
    If blnMouseDown = True Then
        Point1.x = x
        Point1.y = y
    End If
    picSignature.Line (x, y)-(x, y)
End Sub

Private Sub picSignature_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    If blnMouseDown = True Then
        Point2 = Point1
        Point1.x = x
        Point1.y = y
    End If
    picSignature.Line (Point1.x, Point1.y)-(Point2.x, Point2.y)
End Sub

Private Sub picSignature_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    blnMouseDown = False
End Sub

Private Sub SaveToDBase()
    Dim strCriteria As String
    LoadDBase
    strCriteria = "SELECT * FROM tblSignatures"

    
    With rsTemp
        If .State <> 0 Then .Close
        .Open strCriteria, strSQL, 3, 3
        .AddNew
        !SignName = txtPath
        SavePictureToDB picSignature, rsTemp, "SignPict"
        .Update
    End With
End Sub

Private Sub LoadDBase()
    Set DBCon = New ADODB.Connection
    With DBCon
        If .State <> 0 Then .Close
            strSQL = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\Dbase\Signatures.mdb;Persist Security Info=False"
        .Open strSQL
    End With
End Sub
 

 

3. Source ModulePictSaving

 Option Explicit

Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long

Public Function SavePictureToDB(oPictureControl As Object, adoRS As ADODB.Recordset, sFieldName As String) As Boolean
    Dim oPict As StdPicture
    Dim sDir As String, sTempFile As String
    Dim iFileNum As Integer
    Dim lFileLength As Long
    Dim abBytes() As Byte
    Dim iCtr As Integer

    On Error GoTo ErrHandler

    Set oPict = oPictureControl.Picture
    If oPict Is Nothing Then
        SavePictureToDB = False
        Exit Function
    End If
    'Save picture to temp file
    sTempFile = FileGetTempName
    SavePicture oPict, sTempFile

    'read file contents to byte array
    iFileNum = FreeFile
    Open sTempFile For Binary Access Read As #iFileNum
    lFileLength = LOF(iFileNum)
    ReDim abBytes(lFileLength)
    Get #iFileNum, , abBytes()
    'put byte array contents into db field
    adoRS.Fields(sFieldName).AppendChunk abBytes()
    Close #iFileNum

    'Don't return false if file can't be deleted
    On Error Resume Next
    Kill sTempFile
    SavePictureToDB = True
    Exit Function
    
ErrHandler:
    SavePictureToDB = False
    Debug.Print Err.Description
End Function

Function FileGetTempName(Optional sFilePrefix As String = "TMP") As String
    Dim sTemp As String * 260, lngLen As Long
    Static ssTempPath As String

    If LenB(ssTempPath) = 0 Then
        'Get the temporary path
        lngLen = GetTempPath(260, sTemp)
        'strip the rest of the buffer
        ssTempPath = left$(sTemp, lngLen)
        If right$(ssTempPath, 1) <> "\" Then
            ssTempPath = ssTempPath & "\"
        End If
    End If

    'Get a temporary filename
    lngLen = GetTempFileName(ssTempPath, sFilePrefix, 0, sTemp)
    'Remove all the unnecessary chr$(0)'s
    FileGetTempName = left$(sTemp, InStr(1, sTemp, Chr$(0)) - 1)
End Function