Enkripsi Dekripsi Full Project
Enkripsi Dekripsi Full Project
Dalam kesempatan ini, penulis akan meng-ekspos bagaimana cara membuat project File Encrypter yang berfungsi untuk keamanan file dari akses pihak/ user lain. File Encrypter mengubah file yang bisa dibaca oleh user menjadi tak terbaca, terdeteksi sebagai file korup tapi yang sebenarnya tidak demikian. Untuk mengembalikan file yang terenkripsi tersebut, maka file tersebut harus di-Dekripsi atau kebalikannya dari Enkripsi.Hal pertama yang harus anda siapkan adalah sebagai berikut:
1. Buatlah sebuah project baru di IDE Environment Visual Basic 6.0 Anda
2. Komponen/ ActiveX Component yang dibutuhkan sbb:
A. Form Utama (Name: frmUtama)
- 1 Timer, Name tidak berubah (Aturlah Interval ke 1000)
- 1 Frame, Name: frameOpsi
- 7 CommandButton dan masing-masing diberi Name:
- cmdFile - Caption: "File/ File Zip"
- cmdFolder - Caption: "Folder"
- cmdEncrypt - Caption: "Execute (Encrypt/Decrypt)"
- cmdHidden - Caption: "Set to Super Hidden"
- cmdNormal - Caption: "Set to Normal Attribute"
- cmdOff - Caption: "Off"
- LaVolpeButton1 - Caption: "About"
- Tambahkan gambar untuk Background di Form tersebut (apa saja)
- 1 Textbox, Name : txtPath
- 1 Label, Name: cmdQuit
- 1 CommandDialog, Name: cdBrowse
- 1 Label, Name: lblData
- 1 Windows Media Player, Name: wmp1
Saran:
Untuk hasil yang bagus pada tampilan project anda, download dan cantumkan ActiveX Component LVButtons (CommandButton) yang bisa dilihat disini:
Download LVButtons
Form about berisi tentang nama software, versi, dan identitas programmernya, jadi bisa diisi apa saja.
Here we go!
Source Code frmUtama.FRM:
Option Explicit
Private WithEvents mEncryption As CEncryption
Dim strPath As String
Dim Tanya As String
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Sub cmdEncrypt_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
cmdEncrypt.ForeColor = &HC0C0&
End Sub
Private Sub cmdFile_Click()
On Error GoTo errPesan
Dim sFoldername As String
Dim sFilename As String
frameOpsi.Visible = False
With cdBrowse
.ShowOpen
.DialogTitle = " Pilih File yang akan di-Enkrip/Dekrip ..."
.Filter = "Semua Tipe File .*|*.*"
txtPath.Text = .FileName
Exit Sub
End With
Exit Sub
errPesan:
MsgBox "Folder tidak dapat diakses; Korup atau Drive Tidak Ditemukan!", vbCritical, " Unknown Error"
End Sub
Private Sub cmdFolder_Click()
frameOpsi.Visible = False
cmdBrowse_Click
End Sub
Private Sub cmdHidden_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
cmdHidden.ForeColor = &H8000&
End Sub
Private Sub cmdNormal_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
cmdNormal.ForeColor = &H8000&
End Sub
Private Sub cmdOff_Click()
On Error GoTo errPesan
If cmdOff.Caption = "Off" Then
cmdOff.Caption = "On"
wmp1.URL = App.Path + "\01 Metallica.mp3"
Exit Sub
ElseIf cmdOff.Caption = "On" Then
cmdOff.Caption = "Off"
wmp1.URL = ""
Exit Sub
End If
Exit Sub
errPesan:
MsgBox "Background Music File Not Found!", vbExclamation, " Not Found"
End Sub
Private Sub cmdQuit_Click()
End
End Sub
Private Sub cmdQuit_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
cmdQuit.ForeColor = &H80FFFF
End Sub
Private Sub Form_Load()
On Error Resume Next
ActiveTransparency Me, True, False, 240
Me.Refresh
Set mEncryption = New CEncryption
frameOpsi.Visible = False
cmdOff.Caption = "On"
wmp1.URL = App.Path + "\01 Metallica.mp3"
Shape2.Visible = False
End Sub
Private Sub Form_Resize()
frameOpsi.Width = 5805
frameOpsi.Left = 1320
frameOpsi.Height = 1155
frameOpsi.Top = 1680
End Sub
Private Sub Form_Unload(Cancel As Integer)
cmdQuit_Click
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim lngReturnValue As Long
cmdQuit.ForeColor = &HFF8080
cmdEncrypt.ForeColor = &H808080
cmdHidden.ForeColor = &H404040
cmdNormal.ForeColor = &H404040
frameOpsi.Visible = False
If Button = 1 Then
Call ReleaseCapture
lngReturnValue = SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
End If
End Sub
Private Sub cmdBrowse_Click()
On Error Resume Next
Dim i As Integer
Dim s As String
Dim sFoldername As String
Dim sFilename As String
Dim strReady As String
List1.Clear
List1.Refresh
With cdBrowse
sFoldername = GetFolder(Me.hwnd, sFoldername, " Pilih Folder yang akan di enkrip/dekrip " & vbCrLf & _
"All Rights Reserved. (C) AppaCyber Network. 2014", True, False)
txtPath.Text = sFoldername + "\"
If txtPath.Text = "C:\\" Or txtPath.Text = "D:\\" Or txtPath.Text = "E:\\" Or txtPath.Text = "F:\\" Or txtPath.Text = "G:\\" Or txtPath.Text = "H:\\" Then
MsgBox "Anda akan meng-Enkrip/Dekrip Seluruh File yang ada dalam Drive " & txtPath.Text & vbCrLf & _
"Oleh karena itu, Proses Enkrip/Dekrip dibatalkan!", vbCritical, " Fatal Error"
txtPath.Text = ""
txtPath.SetFocus
Exit Sub
Else
Tanya = MsgBox("Anda akan meng-Enkrip/Dekrip seluruh file yang ada di path " & txtPath.Text & vbCrLf & _
"Apakah anda yaking ingin melanjutkan?", vbQuestion + vbYesNo, " Konfirmasi")
If Tanya = vbYes Then
Shape2.Visible = True
MsgBox "Please wait ...", vbCritical, " Processing ..."
Me.Visible = False
Timer1.Enabled = True
If txtPath.Text = "" Then Exit Sub
sFilename = Dir(txtPath.Text)
Do While sFilename > ""
strReady = txtPath.Text & sFilename
mEncryption.Password = "password"
mEncryption.OutputFileName = strReady
mEncryption.InputFileName = strReady
mEncryption.EncryptFile
sFilename = Dir()
Call Sleep(5000)
Loop
MsgBox "Enkripsi/Dekripsi Seluruh File Sukses!", vbInformation, " En/De-cryption Success"
Timer1.Enabled = False
Shape2.Visible = False
txtPath.Text = ""
Me.Visible = True
Exit Sub
ElseIf Tanya = vbNo Then
Exit Sub
End If
Exit Sub
End If
End With
End Sub
Private Sub cmdEncrypt_Click()
On Error GoTo errPesan
If txtPath.Text = "" Then Exit Sub
strPath = txtPath.Text
mEncryption.Password = "password"
mEncryption.OutputFileName = strPath
mEncryption.InputFileName = strPath
mEncryption.EncryptFile
MsgBox "Proses Enkripsi/Dekripsi Berhasil!", vbInformation, " Success"
Exit Sub
errPesan:
MsgBox "Proses Enkripsi/Deskripsi Gagal!", vbExclamation, " Error"
End Sub
Private Sub cmdExit_Click()
End
End Sub
Private Sub cmdHidden_Click()
On Error GoTo errPesan
If txtPath.Text = "" Then Exit Sub
SetAttr txtPath.Text, vbSystem + vbHidden
txtPath.Text = ""
MsgBox "Proses Super Hidden atas File Berhasil!", vbInformation, " Success"
Exit Sub
errPesan:
MsgBox "Gagal di-Hidden!", vbExclamation, " Error"
End Sub
Private Sub cmdNormal_Click()
On Error GoTo errPesan
If txtPath.Text = "" Then Exit Sub
SetAttr txtPath.Text, vbNormal
txtPath.Text = ""
MsgBox "Proses Normalisasi File Berhasil!", vbInformation, " Success"
Exit Sub
errPesan:
MsgBox "Gagal dinormalkan!", vbExclamation, " Error"
End Sub
Private Sub cmdOUT_Click()
End
End Sub
Private Sub LaVolpeButton1_Click()
On Error Resume Next
wmp1.URL = ""
Me.Hide
frmAbout.Show
End Sub
Private Sub Timer1_Timer()
If Shape2.Visible = True Then
Shape2.Visible = False
ElseIf Shape2.Visible = False Then
Shape2.Visible = True
End If
End Sub
Private Sub txtPath_Click()
frameOpsi.Visible = True
frameOpsi.Width = 5805
frameOpsi.Left = 1320
frameOpsi.Height = 1155
frameOpsi.Top = 1680
End Sub
Source Code modFolder.BAS:
Option Explicit
Private Type BrowseInfo
hWndOwner As Long
pIDLRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Public Const BIF_RETURNONLYFSDIRS = &H1
Public Const BIF_DONTGOBELOWDOMAIN = &H2
Public Const BIF_STATUSTEXT = &H4
Public Const BIF_RETURNFSANCESTORS = &H8
Public Const BIF_EDITBOX = &H10
Public Const BIF_VALIDATE = &H20
Public Const BIF_NEWDIALOGSTYLE = &H40
Public Const BIF_USENEWUI = (BIF_NEWDIALOGSTYLE Or BIF_EDITBOX)
Public Const BIF_BROWSEINCLUDEURLS = &H80
Public Const BIF_UAHINT = &H100
Public Const BIF_NONEWFOLDERBUTTON = &H200
Public Const BIF_NOTRANSLATETARGETS = &H400
Public Const BIF_BROWSEFORCOMPUTER = &H1000
Public Const BIF_BROWSEFORPRINTER = &H2000
Public Const BIF_BROWSEINCLUDEFILES = &H4000
Public Const BIF_SHAREABLE = &H8000
Private Const MAX_PATH = 260
Private Const WM_USER = &H400
Private Const BFFM_INITIALIZED = 1
Private Const BFFM_SELCHANGED = 2
Private Const BFFM_SETSTATUSTEXT = (WM_USER + 100)
Private Const BFFM_SETSELECTION = (WM_USER + 102)
Public Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Public Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BrowseInfo) As Long
Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Private mstrSTARTFOLDER As String
Public Function GetFolder(ByVal hWndModal As Long, Optional StartFolder As String, Optional Title As String = "Please select a folder:", _
Optional IncludeFiles As Boolean = False, Optional IncludeNewFolderButton As Boolean = False) As String
Dim bInf As BrowseInfo
Dim RetVal As Long
Dim PathID As Long
Dim RetPath As String
Dim Offset As Integer
'Set the properties of the folder dialog
bInf.hWndOwner = hWndModal
bInf.pIDLRoot = 0
bInf.lpszTitle = Title
bInf.ulFlags = BIF_RETURNONLYFSDIRS Or BIF_STATUSTEXT
If IncludeFiles Then bInf.ulFlags = bInf.ulFlags Or BIF_BROWSEINCLUDEFILES
If IncludeNewFolderButton Then bInf.ulFlags = bInf.ulFlags Or BIF_NEWDIALOGSTYLE
If StartFolder <> "" Then
mstrSTARTFOLDER = StartFolder & vbNullChar
bInf.lpfnCallback = GetAddressofFunction(AddressOf BrowseCallbackProc) 'get address of function.
End If
'Show the Browse For Folder dialog
PathID = SHBrowseForFolder(bInf)
RetPath = Space$(512)
RetVal = SHGetPathFromIDList(ByVal PathID, ByVal RetPath)
If RetVal Then
'Trim off the null chars ending the path
'and display the returned folder
Offset = InStr(RetPath, Chr$(0))
GetFolder = Left$(RetPath, Offset - 1)
'Free memory allocated for PIDL
CoTaskMemFree PathID
Else
GetFolder = ""
End If
End Function
Private Function BrowseCallbackProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long
On Error Resume Next
Dim lpIDList As Long
Dim ret As Long
Dim sBuffer As String
Select Case uMsg
Case BFFM_INITIALIZED
Call SendMessage(hwnd, BFFM_SETSELECTION, 1, mstrSTARTFOLDER)
Case BFFM_SELCHANGED
sBuffer = Space(MAX_PATH)
ret = SHGetPathFromIDList(lp, sBuffer)
If ret = 1 Then
Call SendMessage(hwnd, BFFM_SETSTATUSTEXT, 0, sBuffer)
End If
End Select
BrowseCallbackProc = 0
End Function
Private Function GetAddressofFunction(add As Long) As Long
GetAddressofFunction = add
End Function
Source Code modTransparant.BAS:
Option Explicit
'====DETEKSI DRIVE(S) AVAILABLE SAAT INI ====
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
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bDefaut As Byte, ByVal dwFlags As Long) As Long
Private Const GWL_EXSTYLE As Long = (-20)
Private Const LWA_COLORKEY As Long = &H1
Private Const LWA_Defaut As Long = &H2
Private Const WS_EX_LAYERED As Long = &H80000
Dim VoirStyle As String
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Sub ReleaseCapture Lib "user32" ()
Public Const WM_NCLBUTTONDOWN = &HA1
Public Const HTCAPTION = 2
Public Function Transparency(ByVal hwnd As Long, Optional ByVal Col As Long = vbBlack, Optional ByVal PcTransp As Byte = 255, Optional ByVal TrMode As Boolean = True) As Boolean
' Return : True if there is no error.
' hWnd : hWnd of the window to make transparent
' Col : Color to make transparent if TrMode=False
' PcTransp : 0 Ã 255 >> 0 = transparent -:- 255 = Opaque
Dim DisplayStyle As Long
On Error GoTo errOK
VoirStyle = GetWindowLong(hwnd, GWL_EXSTYLE)
If DisplayStyle <> (DisplayStyle Or WS_EX_LAYERED) Then
DisplayStyle = (DisplayStyle Or WS_EX_LAYERED)
Call SetWindowLong(hwnd, GWL_EXSTYLE, DisplayStyle)
End If
Transparency = (SetLayeredWindowAttributes(hwnd, Col, PcTransp, IIf(TrMode, LWA_COLORKEY Or LWA_Defaut, LWA_COLORKEY)) <> 0)
errOK:
If Not Err.Number = 0 Then Err.Clear
End Function
Public Sub ActiveTransparency(M As Form, d As Boolean, F As Boolean, T_Transparency As Integer, Optional Color As Long)
Dim B As Boolean
If d And F Then
'Makes color (here the background color of the shape) transparent
'upon value of T_Transparency
B = Transparency(M.hwnd, Color, T_Transparency, False)
ElseIf d Then
'Makes form, including all components, transparent
'upon value of T_Transparency
B = Transparency(M.hwnd, 0, T_Transparency, True)
Else
'Restores the form opaque.
B = Transparency(M.hwnd, , 255, True)
End If
End Sub
Source Code CEncryption.CLS:
Option Explicit
Event FileProgress(sngPercentage As Single)
Private m_strInputFileName As String
Private m_strOutputFileName As String
Private m_strPassword As String
Private mintPassWordIndex As Integer
Private mabytePassword() As Byte
Public Property Get InputFileName() As String
InputFileName = m_strInputFileName
End Property
Public Property Let InputFileName(ByVal strValue As String)
m_strInputFileName = strValue
End Property
Public Property Get OutputFileName() As String
OutputFileName = m_strOutputFileName
End Property
Public Property Let OutputFileName(ByVal strValue As String)
m_strOutputFileName = strValue
End Property
Public Property Get Password() As String
Password = m_strPassword
End Property
Public Property Let Password(ByVal strValue As String)
m_strPassword = strValue
ReDim mabytePassword(LenB(m_strPassword)) As Byte
End Property
Public Sub EncryptFile()
On Error Resume Next
Dim lngFileLength As Long
Dim lngTotalBytesRead As Long
Dim lngBytesRead As Long
Dim intInputFile As Integer
Dim intOutputFile As Integer
Dim lngCounter As Long
Dim abytBuffer() As Byte
Const cbufferSize As Integer = &H7FFF
'On Error GoTo PROC_ERR
mabytePassword = m_strPassword
intInputFile = FreeFile
Open m_strInputFileName For Binary Access Read As intInputFile
lngFileLength = LOF(intInputFile)
On Error Resume Next
Kill m_strOutputFileName
'On Error GoTo PROC_ERR
intOutputFile = FreeFile
Open m_strOutputFileName For Binary As intOutputFile
mintPassWordIndex = 0
RaiseEvent FileProgress(0)
lngBytesRead = ReadFile(intInputFile, abytBuffer, cbufferSize)
Do While lngBytesRead > 0
For lngCounter = 0 To lngBytesRead - 1
EncryptByte abytBuffer(lngCounter)
Next lngCounter
Put intOutputFile, , abytBuffer
lngTotalBytesRead = lngTotalBytesRead + lngBytesRead
RaiseEvent FileProgress(lngTotalBytesRead / lngFileLength)
lngBytesRead = ReadFile(intInputFile, abytBuffer, cbufferSize)
Loop
Close intOutputFile
Close intInputFile
End Sub
Function EncryptString(strIn As String) As String
Dim intCounter As Long
On Error GoTo PROC_ERR
mabytePassword = m_strPassword
ReDim abytIn(LenB(strIn)) As Byte
abytIn = strIn
mintPassWordIndex = 0
For intCounter = 0 To LenB(strIn) - 1
EncryptByte abytIn(intCounter)
Next
EncryptString = abytIn
PROC_EXIT:
Exit Function
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"EncryptString"
Resume PROC_EXIT
End Function
Private Function EncryptByte(bytIn As Byte) As Byte
On Error GoTo PROC_ERR
bytIn = (bytIn Xor CInt(mabytePassword(mintPassWordIndex)) * mintPassWordIndex) And &HFF
EncryptByte = bytIn
If mintPassWordIndex < UBound(mabytePassword) Then
mabytePassword(mintPassWordIndex) = (CInt(mabytePassword(mintPassWordIndex)) + mabytePassword(mintPassWordIndex + 1)) And &HFF
mintPassWordIndex = mintPassWordIndex + 1
Else
mabytePassword(mintPassWordIndex) = (CInt(mabytePassword(mintPassWordIndex)) + mabytePassword(1)) And &HFF
mintPassWordIndex = 1
End If
PROC_EXIT:
Exit Function
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"EncryptByte"
Resume PROC_EXIT
End Function
Private Function ReadFile(ByVal intFile As Integer, ByRef abytBuffer() As Byte, ByVal lngNumberOfBytes As Long) As Long
Dim lngLen As Long
Dim lngActualBytesRead As Long
Dim lngStart As Long
On Error GoTo PROC_ERR
lngStart = Loc(intFile) + 1
lngLen = LOF(intFile)
If lngStart < lngLen Then
If lngStart + lngNumberOfBytes < lngLen Then
lngActualBytesRead = lngNumberOfBytes
Else
lngActualBytesRead = lngLen - (lngStart - 1)
End If
ReDim abytBuffer(lngActualBytesRead - 1) As Byte
Get intFile, lngStart, abytBuffer
Else
lngActualBytesRead = 0
End If
ReadFile = lngActualBytesRead
PROC_EXIT:
Exit Function
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"ReadFile"
Resume PROC_EXIT
End Function
Kemudian, simpan dan compile-lah file project ini dan selamat mencoba!
Semoga bermanfaat!. Amin
#Note: Bila ada yang kurang dimengerti / ditemukan Error didalamnya, silahkan tinggalkan komentar atau kirim ke alamat Email barney.lordsync@gmail.com
Post a Comment for "Enkripsi Dekripsi Full Project"