VBA-Excel : Aplikasi Sederhana Menyembunyikan Folder

Langkah-langkah :

1. Buka MS-Excel, buat Modul baru dan Copy-Paste Kode berikut ke dalam modul


2. Password dan Lock modul tersebut


3. Simpan file dan jadikan sebagai Add-Ins


4. Password default adalah "member", silahkan diganti sesuai kebutuhan

Penggunaan :
Untuk menu pertolongan ketik =tentang() pada sembarang sel

Kode :


'///////////////////////////////////////////////////////////////////////////////////
'Aplikasi untuk menyembunyikan folder, kode oleh xantov
'kode ini mungkin masih terdapat bug, silahkan disempurnakan lagi
'jika hendak menyebarkan fungsi ini harap tidak menghapus komentar ini
'///////////////////////////////////////////////////////////////////////////////////

Function kunci(xx As String)
'kunci folder
On Error Resume Next
Dim x, nm, cpd
Dim cekPwd
Dim sc
Dim nHistori
nHistori = GetSetting("Flock", "histori", "nhis", 0)

sc = "8c35e8b53c6be62b23686f8c757b6292"

cekPwd = dekrip(GetSetting("Flock", "setting", "passwd", ""), sc)
If cekPwd = "" Then
cekPwd = "member"
End If

cpd = InputBox("Masukkan password anda", "Password", "")
If cpd = cekPwd Then

nm = ".{00EEBF57-477D-4084-9921-7AB3C2C9459D}"
x = GetAttr(xx)

If x = "" Then
MsgBox "Folder tidak ada", vbCritical, "Error"
Else
Name xx As xx & nm
SetAttr xx & nm, vbHidden + vbSystem

SaveSetting "Flock", "histori", nHistori + 1, enkrip(xx, sc)
SaveSetting "Flock", "histori", "nhis", nHistori + 1
End If
Else
MsgBox "Anda tidak memiliki hak akses!", vbCritical, "Error"
End If

End Function

Function buka(yy As String)
'buka folder

On Error Resume Next
Dim tt, rm, cpx

Dim cekPwd
Dim sc
sc = "8c35e8b53c6be62b23686f8c757b6292"

cekPwd = dekrip(GetSetting("Flock", "setting", "passwd", ""), sc)
If cekPwd = "" Then
cekPwd = "member"
End If


cpx = InputBox("Masukkan password anda", "Password", "")
If cpx = cekPwd Then

rm = ".{00EEBF57-477D-4084-9921-7AB3C2C9459D}"
tt = GetAttr(yy & rm)

If tt = "" Then
MsgBox "Folder tidak ada", vbCritical, "Error"
Else
Name yy & rm As yy
SetAttr yy, vbNormal
End If
Else
MsgBox "Anda tidak memiliki hak akses!", vbCritical, "Error"

End If

End Function

Function set_password()
'set password baru atau merubah password lama
Dim pw, pb, pw1
Dim cekPwd
Dim sc
sc = "8c35e8b53c6be62b23686f8c757b6292"

cekPwd = dekrip(GetSetting("Flock", "setting", "passwd", ""), sc)
If cekPwd = "" Then
cekPwd = "member"
End If

If cekPwd = "member" Then
pb = InputBox("Masukkan password BARU anda", "Password Baru", "")
SaveSetting "Flock", "setting", "passwd", enkrip(pb, sc)
Else
pw = InputBox("Masukkan password lama anda", "Password Lama", "")
pw1 = GetSetting("Flock", "setting", "passwd", "xyz")
If pw = dekrip(pw1, sc) Then
pb = InputBox("Masukkan password BARU anda", "Password Baru", "")
SaveSetting "Flock", "setting", "passwd", enkrip(pb, sc)
End If
End If

End Function

Function enkrip(x, security_cek)
'fungsi enkripsi sederhana
'security_cek berguna untuk melindungi fungsi enkrip/dekrip agar tidak bisa digunakan dalam mode sel

Dim n

If security_cek = "8c35e8b53c6be62b23686f8c757b6292" Then

For n = 1 To Len(x)
enkrip = enkrip & Chr(Asc(Mid(x, n, 1)) + 10)
Next

Else
enkrip = 0
End If
End Function

Function dekrip(x1, security_cek)
'fungsi dekripsi sederhana
Dim n1

If security_cek = "8c35e8b53c6be62b23686f8c757b6292" Then

For n1 = 1 To Len(x1)
dekrip = dekrip & Chr(Asc(Mid(x1, n1, 1)) - 10)
Next

Else
dekrip = 0
End If
End Function

Function tentang()
MsgBox "FLock" & vbCrLf & "Program untuk menyembunyikan folder by xantov" _
& vbCrLf & vbCrLf _
& "Penggunaan :" & vbCrLf _
& "=kunci(" & Chr(34) & "C:\coba dong" & Chr(34) & ")" & vbTab & "Mengunci folder C:\coba dong" & vbCrLf _
& "=buka(" & Chr(34) & "C:\coba dong" & Chr(34) & ")" & vbTab & "Membuka folder C:\coba dong" & vbCrLf _
& "=set_password()" & vbTab & vbTab & "Membuat atau mengubah password" & vbCrLf _
& "=jejak()" & vbTab & vbTab & vbTab & "Melihat daftar folder terkunci" & vbCrLf _
& "=tentang()" & vbTab & vbTab & "Cara Penggunaan aplikasi", vbInformation, "Tentang Aku"

End Function

Function jejak()
'daftar folder terkunci
Dim cps
Dim c, b
Dim buff
Dim sc
sc = "8c35e8b53c6be62b23686f8c757b6292"

b = GetSetting("Flock", "histori", "nhis", 0)

Dim cekPwd

cekPwd = dekrip(GetSetting("Flock", "setting", "passwd", ""), sc)
If cekPwd = "" Then
cekPwd = "member"
End If

cps = InputBox("Masukkan password anda", "Password", "")
If cps = cekPwd Then
If b > 0 Then
For c = 1 To b
buff = buff & vbCrLf & dekrip(GetSetting("Flock", "histori", c, ""), sc)

Next
MsgBox buff, vbInformation, "Daftar Folder Terkunci"
End If
Else
MsgBox "Anda tidak memiliki hak akses!", vbCritical, "error"
End If


End Function