PadaKesempatan kali kembalisayamengembangkanbeberapa project Open Source VB 6 yang sayagabungkanuntukmenghasilkansesuatu yang baru,padamateriberikutinisayamembuatSingnature capture denganmenggabungkankonsep Pain Picture , Crop dan Capture Screen untukmerekamtandatangan
Tabel tool
Option Explicit
Private XX As Long
Private YY As Long
Private XX2 As Long
Private YY2 As Long
Private isBoxExist As Boolean
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type PALETTEENTRY
peRed As Byte
peGreen As Byte
peBlue As Byte
peFlags As Byte
End Type
Private Type LOGPALETTE
palVersion As Integer
palNumEntries As Integer
palPalEntry(255) As PALETTEENTRY
End Type
Private Type PicBmp
PicSize As Long
PicType As Long
PichBmp As Long
PichPal As Long
PicReserved As Long
End Type
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC 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 SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Const RASTERCAPS As Long = 38
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC&, ByVal iCapabilitiy&) As Long
Private Const RC_PALETTE As Long = &H100
Private Const SIZEPALETTE As Long = 104
Private Declare Function GetSystemPaletteEntries Lib "gdi32" (ByVal hDC As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
Private Declare Function CreatePalette Lib "gdi32" (lpLogPalette As LOGPALETTE) As Long
Private Declare Function SelectPalette Lib "gdi32" (ByVal hDC&, ByVal HPALETTE&, ByVal bForceBackground&) As Long
Private Declare Function RealizePalette Lib "gdi32" (ByVal hDC&) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC&, ByVal X&, ByVal Y&, ByVal nWidth&, ByVal nHeight&, ByVal hSrcDC&, ByVal XSrc&, ByVal YSrc&, ByVal dwRop&) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC&) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "OLEPRO32.DLL" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
'---------------------------------------------------------------------------
Dim Pen As Boolean
Dim Px, Py As Integer
Dim Na, Nb, Ma, Mb, Min, Max As Double
Dim Xa, Xb, Ya, Yb, MinX, MaxX As Double
Dim Ambil As Boolean
Private InData(0 To 511) As Byte
Sub scalaCrop()
Shp1.Top = Min
Shp1.Left = MinX
Shp1.Width = (MaxX + 20) - MinX
Shp1.Height = (Max + 20) - Min
End Sub
Sub AutoCrop()
Picture3.Visible = True
Picture3.Height = Shp1.Height
Picture3.Width = Shp1.Width
Picture3.Refresh
Picture3.PaintPicture Picture1.Image, 0, 0, Shp1.Width, Shp1.Height, Shp1.Left, Shp1.Top, Shp1.Width, Shp1.Height, vbSrcCopy
'_________________Save Pain to Image_______________________________
SavePictureAPI Picture3, App.Path & "\Signature.jpg"
'picResize.Tag = App.Path & "\cropped.jpg"
'_______________ Load Image_____________________
Image1.Picture = LoadPicture(App.Path & "\Signature.jpg")
Picture3.Visible = False
End Sub
Private Sub BotClose_Click()
Unload Me
FrmSave.Show
End Sub
Private Sub BotRekam_Click()’Mengaktifkan Perekaman Pain
If BotRekam.Caption = "Mulai Merekam" Then
BotRekam.Caption = "Menerima"
Picture1.Enabled = True
Ambil = True ‘ Mengaktifkan pengambilan nilai awal koordinat X dan Y
Lbtitle.BackColor = &HFF00&
Else
LbX.Caption = "PainX : " & Picture1.CurrentX
LbY.Caption = "PainY : " & Picture1.CurrentY
scalaCrop ‘ Memanggil Prosedure pemotongan Image TTD
AutoCrop ‘ Memotong dam Menjadikan File Image
BotRekam.Caption = "Mulai Merekam"
BotClose.Caption = "OK"
Picture1.Enabled = False
Lbtitle.BackColor = &HC0C0C0
End If
End Sub
Private Sub BotUlang_Click() ‘ Merekam Ualng pain
Picture1.Refresh
Picture1.Cls
Shp1.Width = 1
Shp1.Height = 1
Image1.Picture = LoadPicture("")
End Sub
Private Sub Form_Load() ‘ mengatur skala awal pemoto
Shp1.Width = 1
Shp1.Height = 1
End Sub
Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
’Mengambil nilai wawal Koordinat X dan Y
If Ambil = True Then
Na = Y
Ma = Y
Xa = X
Ya = X
Ambil = False
End If
End Sub
Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Px = X + 20 ‘atur tebal garis di sini
Py = Y + 20 ‘mengatur tebal garis
Label1.Caption = "Koordinat X = " & Px
Label2.Caption = "Koordinat Y = " & Py
If Button = 1 Then ‘ Jika Mouse Kiri di Klick maka
Picture1.Line (X, Y)-(Px, Py)
'==============Nilai Minimum Y==============
Nb = Y
If Na > Nb Then
Min = Nb
Na = Nb
End If
If Nb > Na Then
Min = Na
End If
LbTop.Caption = "Top : " & Min
'============Nilai Maximum Y===============
Mb = Y
If Ma < Mb Then
Max = Mb
Ma = Mb
End If
If Mb < Ma Then
Max = Ma
End If
LbHaight.Caption = "Height : " & Max
'================Nilaim Minimum X==========
Xb = X
If Xa > Xb Then
MinX = Xb
Xa = Xb
End If
If Xb > Xa Then
MinX = Xa
End If
LBLeft.Caption = "Left : " & MinX
'===============Nilai Maximum X==========
Yb = X
If Ya < Yb Then
MaxX = Yb
Ya = Yb
End If
If Mb < Ma Then
MaxX = Ya
End If
LbWidth.Caption = "Width : " & MaxX
End If
End Sub
'===================================================================
Private Function StrParse(retarray() As String, ByVal strText As String, ByVal Delim As String, Optional PreserveSize As Long = -1) As Long
On Error Resume Next
' this is the same as the split function, however starts at 1 and returns the number
' of delimiters counted
Dim varArray() As String
Dim varCnt As Long
Dim VarS As Long
Dim VarE As Long
Dim varA As Long
If Len(Delim) = 0 Then
Delim = Chr$(253)
End If
varArray = Split(strText, Delim)
VarS = LBound(varArray)
VarE = UBound(varArray)
ReDim retarray(VarE + 1)
For varCnt = VarS To VarE
varA = varCnt + 1
retarray(varA) = varArray(varCnt)
Next
If PreserveSize <> -1 Then ReDim Preserve retarray(PreserveSize)
StrParse = UBound(retarray)
Err.Clear
End Function
Private Function ArraySearch(varArray() As String, ByVal StrSearch As String) As Long
On Error Resume Next
' search an array and return the index position
ArraySearch = 0
Dim ArrayTot As Long
Dim arrayCnt As Long
Dim strCur As String
StrSearch = LCase$(Trim$(StrSearch))
ArrayTot = UBound(varArray)
For arrayCnt = 1 To ArrayTot
strCur = varArray(arrayCnt)
strCur = LCase$(Trim$(strCur))
Select Case strCur
Case StrSearch
ArraySearch = arrayCnt
Exit For
End Select
Next
Err.Clear
End Function
Private Sub PictureCopy(NewPicBox As Variant, ByVal ActualPic As StdPicture)
On Error Resume Next
' this copies a picturebox frome one to another and resizes the picture to fit the height and width of new picture box
Dim NewH As Long ' new height
Dim NewW As Long 'New Width
NewH = NewPicBox.Height 'actual image height
NewW = NewPicBox.Width 'actual image width
With NewPicBox
.AutoRedraw = True 'set needed properties
.Cls 'clear picture box
.PaintPicture ActualPic, 0, 0, NewW, NewH 'paint new picture size in picturebox
End With
Err.Clear
End Sub
Private Function CaptureWindow(ByVal hWndSrc As Long, ByVal Client As Boolean, ByVal LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long) As Picture
On Error Resume Next
Dim hDCMemory As Long
Dim hBmp As Long
Dim hBmpPrev As Long
Dim R As Long
Dim hDCSrc As Long
Dim hPal As Long
Dim hPalPrev As Long
Dim RasterCapsScrn As Long
Dim HasPaletteScrn As Long
Dim PaletteSizeScrn As Long
Dim LogPal As LOGPALETTE
' Depending on the value of Client get the proper device context.
If Client Then
hDCSrc = GetDC(hWndSrc) ' Get device context for client area.
Else
hDCSrc = GetWindowDC(hWndSrc) ' Get device context for entire
' window.
End If
' Create a memory device context for the copy process.
hDCMemory = CreateCompatibleDC(hDCSrc)
' Create a bitmap and place it in the memory DC.
hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
hBmpPrev = SelectObject(hDCMemory, hBmp)
' Get screen properties.
RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS) ' Raster
' capabilities.
HasPaletteScrn = RasterCapsScrn And RC_PALETTE ' Palette
' support.
PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE) ' Size of
' palette.
' If the screen has a palette make a copy and realize it.
If HasPaletteScrn And (PaletteSizeScrn = 256) Then
' Create a copy of the system palette.
LogPal.palVersion = &H300
LogPal.palNumEntries = 256
R = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
hPal = CreatePalette(LogPal)
' Select the new palette into the memory DC and realize it.
hPalPrev = SelectPalette(hDCMemory, hPal, 0)
R = RealizePalette(hDCMemory)
End If
' Copy the on-screen image into the memory DC.
R = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, vbSrcCopy)
' Remove the new copy of the on-screen image.
hBmp = SelectObject(hDCMemory, hBmpPrev)
' If the screen has a palette get back the palette that was
' selected in previously.
If HasPaletteScrn And (PaletteSizeScrn = 256) Then
hPal = SelectPalette(hDCMemory, hPalPrev, 0)
End If
' Release the device context resources back to the system.
R = DeleteDC(hDCMemory)
R = ReleaseDC(hWndSrc, hDCSrc)
' bitmap and palette handles. Then return the resulting picture
' object.
Set CaptureWindow = CreateBitmapPicture(hBmp, hPal)
Err.Clear
End Function
Private Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture
On Error Resume Next
Dim Pic As PicBmp
' IPicture requires a reference to "Standard OLE Types."
Dim iPic As IPicture
Dim IID_IDispatch As GUID
Dim R As Long
' Fill in with IDispatch Interface ID.
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
' Fill Pic with necessary parts.
With Pic
.PicSize = Len(Pic) ' Length of structure.
.PicType = vbPicTypeBitmap ' Type of Picture (bitmap).
.PichBmp = hBmp ' Handle to bitmap.
.PichPal = hPal ' Handle to palette (may be null).
End With
' Create Picture object.
R = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, iPic)
' Return the new Picture object.
Set CreateBitmapPicture = iPic
Err.Clear
End Function
Private Sub SavePictureAPI(picHwnd As PictureBox, ByVal strFileName As String)
On Error Resume Next
Dim myX As Picture
Dim RectActive As RECT
Dim R As Long
R = GetWindowRect(picHwnd.hwnd, RectActive)
Set myX = CaptureWindow(picHwnd.hwnd, False, 1, 1, RectActive.Right - RectActive.Left, RectActive.Bottom - RectActive.Top)
SavePicture myX, strFileName
Err.Clear
End Sub
Signature Capture.rar
Terimakasih Banyak Atas Penjelasan Nya yg sangat Rinci sekali saya sangat benar benar terbantu oleh anda
BalasHapusTERIMA KASIH SEBANYAK BANYAKNYA
yup sama -sama
BalasHapusterimakasih telah berkunjuung.....
nomor hp nya berapa ?
BalasHapusbalas
Krim ke email saya saja Hidayatul.rahman0097@gmail.com, atau ke facebook saya
Hapus