Source Code VB

DefLng A-Z
Private m_bEditing As Boolean
Private m_lngCurrIndex As Long
Dim totalRecords As Integer
Dim RecordAktif As Integer
Dim PosisiKetemu As Integer
Dim KriteriaCari As String
Dim StatusEdit As Boolean
Dim StatusAdd As Boolean
Private Type MyPasswordData
    Password As String * 15
    Description As String * 30
    Location As String * 30
    Expiry As Date
End Type

Dim MPD As MyPasswordData
Dim tabMPD() As MyPasswordData

Private Sub cmdBantuan_Click()
  MsgBox “Contoh Penggunaan File Teks untuk Database” & vbCrLf & _
         “1. Untuk menambah data, klik Tambah.” & vbCrLf & _
         “2. Klik Update untuk menyimpan data baru.” & vbCrLf & _
         “3. Klik Edit jika ingin mengedit data.” & vbCrLf & _
         “4. Untuk mengedit data, bisa dilakukan dari textbox” & vbCrLf & _
         “   atau langsung di daftar (Listbox).” & vbCrLf & _
         “   Setelah mengedit di listbox, tekan Enter.” & vbCrLf & _
         “5. Klik Save All jika ingin menyimpan ” & vbCrLf & _
         “   perubahan yang terjadi di Listbox.” & vbCrLf & _
         “6. Untuk menghapus data yg terpilih, klik Hapus.” & vbCrLf & _
         “7. Untuk menghapus semua data, klik Del All.” & vbCrLf & _
         “8. Untuk mencari data, klik Find First.” & vbCrLf & _
         “9. Jika ingin mencari data selanjutnya, klik” & vbCrLf & _
         “   Find Next.” & vbCrLf & _
         “10. Klik Del Kriteria jika ingin menghapus kriteria” & vbCrLf & _
         “   pencarian sebelumnya.” & vbCrLf & _
         “” & vbCrLf & _
         “                        ” & vbCrLf & _
         “”, vbInformation, “Petunjuk”
End Sub

Private Sub cmdCancel_Click()
  SetButtons True
  cmdRefresh_Click
  List1.Enabled = True
  KunciTeks
  If List1.ListCount > 0 Then _
  List1.Selected(0) = True
  ‘SendKeys “{Esc}”
End Sub

Private Sub cmdClose_Click()
  End
End Sub

Private Sub cmdDelAll_Click()
  If List1.ListCount = 0 Then
     MsgBox “Data masih kosong!”, vbCritical, “Data Kosong”
     Exit Sub
  Else
     List1.Clear
     SetButtons False
  End If
End Sub

Private Sub cmdDelete_Click()
Dim i, j As Integer
Dim sFileName As String
Dim fileNo As Integer
On Error Resume Next
  j = 0
  If List1.ListCount > 0 Then
    For i = 0 To List1.ListCount - 1
      If List1.Selected(i) = True Then
         j = j + 1
      End If
    Next i
    If j = 0 Then
       MsgBox “Pilih record yang akan dihapus!”, vbCritical, “Pilih Record”
       Exit Sub
    End If
    If MsgBox(”Yakin mau dihapus?”, _
            vbQuestion + vbYesNo, _
            “Hapus Record”) = vbYes Then
      If List1.Selected(List1.ListIndex) = True Then
         List1.RemoveItem (List1.ListIndex)
      End If
      If List1.ListCount > 0 Then
         List1.Selected(List1.ListCount - 1) = True
      End If
      SetButtons False
      cmdUpdate.Enabled = False
      cmdDelete.Enabled = True
      cmdDelete.SetFocus
      Exit Sub
    End If
  Else
    MsgBox “Data masih kosong!”, vbCritical, “Kosong”
  End If
  Exit Sub
Pesan:
  MsgBox “Pilih record yang akan dihapus!”, vbCritical, “Pilih”
End Sub

Private Sub cmdDelKriteria_Click()
  If KriteriaCari = “” Then
     MsgBox “Belum ada kriteria pencarian!”, vbCritical, “Belum Pernah Cari”
     Exit Sub
  End If
  If MsgBox(”Kriteria pencarian = ” & KriteriaCari & “” & vbCrLf & _
            “Anda yakin ingin menghapusnya?”, vbQuestion + vbYesNo, _
            “Hapus Kriteria Pencarian”) = vbYes Then
     KriteriaCari = “”
     PosisiKetemu = 0
  End If
End Sub
Private Sub cmdFindFirst_Click()
Dim i As Integer
Dim ada As Integer
  If KriteriaCari = “” Then
     KriteriaCari = InputBox(”Masukkan data yang akan dicari”, “Cari Data”)
     If StrPtr(KriteriaCari) = 0 Then Exit Sub
     If KriteriaCari = “” Then Exit Sub
  End If
  For i = 0 To List1.ListCount - 1
     List1.Selected(i) = True
     ada = InStr(1, UCase(List1.Text), UCase(KriteriaCari))
     If ada > 0 Then
        PosisiKetemu = i
        Exit Sub
     End If
  Next i
  PosisiKetemu = 0
  MsgBox “Data tidak ditemukan!”, vbCritical, “Tidak Ada”
End Sub
Private Sub cmdFindNext_Click()
Dim i As Integer
Dim ada As Integer
  If PosisiKetemu = -1 Or KriteriaCari = “” Then
     cmdFindFirst_Click
     Exit Sub
  End If
  For i = PosisiKetemu + 1 To List1.ListCount - 1
     List1.Selected(i) = True
     ada = InStr(1, UCase(List1.Text), UCase(KriteriaCari))
     PosisiKetemu = i
     If ada > 0 Then
        Exit Sub
     End If
  Next i
  MsgBox “Data tidak ditemukan!”, vbCritical, “Tidak Ada”
End Sub

Private Sub cmdFirst_Click()
On Error Resume Next
  lblStatus.Caption = “Record pertama”
  List1.Selected(0) = True
End Sub

Private Sub cmdLast_Click()
On Error Resume Next
  lblStatus.Caption = “Record terakhir”
  List1.Selected(List1.ListCount - 1) = True
End Sub
Private Sub cmdNext_Click()
On Error Resume Next
  If RecordAktif >= 0 And _
     RecordAktif < List1.ListCount Then
     List1.Selected(RecordAktif + 1) = True
  End If
End Sub

Private Sub cmdPrevious_Click()
  If RecordAktif > 0 And _
     RecordAktif < List1.ListCount Then
     List1.Selected(RecordAktif - 1) = True
  End If
End Sub

Private Sub cmdUpdateAll_Click()
Dim sFileName As String
Dim fileNo As Integer
Dim i As Integer
Dim sPassword As String
Dim sDesc As String
Dim sLocation As String
Dim sExpiry As String
Dim baca As String

  On Error Resume Next
 
  For i = 0 To List1.ListCount - 1
    baca = Left(List1.List(i), InStr(List1.List(i), “,”) - 1)
      If baca = txtPassword.Text And baca <> lblTampung.Caption Then
         MsgBox “Data sudah ada, ganti dengan yang lain!”, vbCritical, “Password Sudah Ada”
         txtPassword.SetFocus: SendKeys “{Home}+{End}”
         Exit Sub
      End If
  Next i
 
  If StatusEdit = True Then
    sPassword = txtPassword.Text
    sDesc = txtDescription.Text
    sLocation = txtLocation.Text
    sExpiry = txtExpiry.Text
    List1.RemoveItem RecordAktif
    List1.AddItem sPassword & “,” & sDesc & “,” & sLocation & “,” & sExpiry
    SetButtons True
  End If
 
 
  sFileName = App.Path & “\password.txt”
 
   fileNo = FreeFile

  prgBar1.Min = 0
  prgBar1.Max = List1.ListCount - 1
  Open sFileName For Output As #fileNo
     For i = 0 To List1.ListCount - 1
       DoEvents
       prgBar1.Value = i
       lblPersen.Caption = Format(CInt((((List1.ListCount - 1) - i) _
                        / (List1.ListCount - 1)) * 100), “###”)
       Print #fileNo, List1.List(i)
     Next i
  Close #fileNo
   
  prgBar1.Value = 0
  List1.Enabled = True
  SetButtons True
  KunciTeks
End Sub

Private Sub cmdAdd_Click()
   SetButtons False
   cmdUpdateAll.Enabled = False
   If List1.ListCount > 0 Then _
   List1.Selected(List1.ListCount - 1) = True
   txtPassword.Text = “”
   txtDescription.Text = “”
   txtLocation.Text = “”
   txtExpiry.Text = “”
   List1.Enabled = False
   BukaKunciTeks
   txtPassword.SetFocus
End Sub

‘Add only 4 textboxes in total …. that’s all you’ll need; name them
‘txtPassword, txtDescription, txtLocation, and txtExpiry
‘————————————————————————–
‘1. A Plain Old Sequential File - 1 line = 1 record

‘File format for 1 “entry” will look like:
‘bluto,Microsoft VB Home,www.microsoft.com/vbasic,97/12/31
‘————————————————————————–

Private Sub cmdUpdate_Click()
‘WRITE A LINE TO THE FILE
   Dim fileNo As Integer
   Dim sFileName As String
   Dim sPassword As String
   Dim sDesc As String
   Dim sLocation As String
   Dim sExpiry As String
   Dim i As Integer
   Dim panjang As Integer
  
   On Error GoTo Pesan

   If txtPassword.Text = “” Then
      MsgBox “Password harus diisi!”, vbCritical, “Password”
      txtPassword.SetFocus
      Exit Sub
   ElseIf txtDescription.Text = “” Then
      MsgBox “Deskripsi harus diisi!”, vbCritical, “Deskripsi”
      txtDescription.SetFocus
      Exit Sub
   ElseIf txtLocation.Text = “” Then
      MsgBox “Lokasi harus diisi!”, vbCritical, “Lokasi”
      txtLocation.SetFocus
      Exit Sub
   ElseIf txtExpiry.Text = “” Then
      MsgBox “Tanggal expiry harus diisi!”, vbCritical, “Expiry”
      txtExpiry.SetFocus
      Exit Sub
   End If
   panjang = Len(Trim(txtPassword.Text))
   For i = 0 To List1.ListCount - 1
       If txtPassword.Text = Left(List1.List(i), panjang) Then
          MsgBox “Password sudah ada, ganti dgn yang lain!”, vbCritical, “Sudah Ada”
          Exit Sub
       End If
   Next i
  
  ‘retrieve the typed-in values
   sPassword = txtPassword.Text
   sDesc = txtDescription.Text
   sLocation = txtLocation.Text
   sExpiry = txtExpiry.Text

  ‘this is the file to save to
  sFileName = App.Path & “\password.txt”

  ‘get the next free file handle from Windows
   fileNo = FreeFile

  ’save to disk using Append to allow new additions
  ‘We’ll use a comma to separate each item
   Open sFileName For Append As #fileNo

       Print #fileNo, sPassword & “,” & sDesc & “,” & sLocation & “,” & sExpiry

   Close #fileNo
   List1.AddItem sPassword & “,” & sDesc & “,” & sLocation & “,” & sExpiry
   SetButtons True
   List1.Enabled = True
   KunciTeks
   Exit Sub
Pesan:
   MsgBox Err.Number & ” - ” & Err.Description
End Sub

Private Sub cmdLoadFirst_Click()
‘READ A LINE TO THE FILE
   Dim fileNo As Integer
   Dim sFileName As String
   Dim tmp As String
   Dim pos As Integer
   Dim sPassword As String
   Dim sDesc As String
   Dim sLocation As String
   Dim sExpiry As String
  
   On Error GoTo Pesan
  
   If List1.ListCount > 0 Then
    sFileName = App.Path & “\password.txt”
    ‘get the next free file handle
    fileNo = FreeFile
    ’save to disk using Append to allow new additions
    Open sFileName For Input As #fileNo

       Line Input #fileNo, tmp

      ‘find the first comma
       pos = InStr(tmp, “,”)

      ‘extract the string up to the comma
       sPassword = Left$(tmp, pos - 1)

      ’shorten the string by removing the item
      ‘ready to find the next comma
       tmp = Mid$(tmp, pos + 1, Len(tmp))

      ‘do it again
       pos = InStr(tmp, “,”)
       sDesc = Left$(tmp, pos - 1)
       tmp = Mid$(tmp, pos + 1, Len(tmp))

      ‘do it again
       pos = InStr(tmp, “,”)
       sLocation = Left$(tmp, pos - 1)
       tmp = Mid$(tmp, pos + 1, Len(tmp))

      ‘the remainder is the expiry
       sExpiry = tmp
    Close #fileNo

   ‘display the retrieved values
    txtPassword.Text = sPassword
    txtDescription.Text = sDesc
    txtLocation.Text = sLocation
    txtExpiry.Text = sExpiry
    List1.Enabled = True
    List1.Selected(0) = True
    Exit Sub
  Else
    MsgBox “Data masih kosong!”, vbCritical, “Kosong”
    Exit Sub
  End If
Pesan:
   MsgBox Err.Number & ” - ” & Err.Description
End Sub

‘————————————————————————–
‘Pretty simple eh?  The disadvantage to a sequential file is that it must
‘always be read from the beginning every time you read it.  It is also
‘difficult to retrieve specific entries … you have to read a line, see if
‘what you want is in the line, and if not, read the next.

‘————————————————————————–
‘This should get you going.  Remember to set the file paths in the buttons
‘to the right drive.  You can view either file with notepad; not the
‘differences between the two.

Private Sub cmdRefresh_Click()
    Dim sfile As String
    Dim NextLine As String
   
    ‘On Error GoTo Pesan
    ‘ clear the List Box
    List1.Clear
    ‘ replace the “c:\autoexec.bat” below with the name of the file
    ‘ you want to load to the list box
    sfile = App.Path & “\password.txt”
    ‘ the FreeFile function assign unique number to the Filenum variable,
    ‘ to avoid collision with other opened file
    Filenum = FreeFile
    Open sfile For Input As Filenum
    ‘ do until the file reach to its end
    Do Until EOF(Filenum)
    ‘ read one line from the file to the NextLine String
        Line Input #Filenum, NextLine
    ‘ add the line to the List Box
        List1.AddItem NextLine
    Loop
    ‘ Close the file
    Close
    If List1.ListCount > 0 Then _
       List1.Selected(0) = True
    Exit Sub
Pesan:
    MsgBox Err.Number & ” - ” & Err.Description
End Sub

Private Sub cmdEdit_Click()
  If List1.ListCount > 0 Then
     SetButtons False
     cmdUpdate.Enabled = False
     BukaKunciTeks
     cmdUpdateAll.Enabled = True
     List1.Enabled = False
     StatusEdit = True
     lblTampung.Caption = txtPassword.Text
     ‘If Not m_bEditing Then Editing = True
  Else
     MsgBox “Data masih kosong!”, vbCritical, “Data Kosong”
  End If
End Sub

Private Sub Form_Load()
  Me.ScaleMode = 3
  Text1.Visible = False
  Text1.Appearance = 0
  cmdRefresh_Click
  If List1.ListCount > 0 Then
     List1.Selected(0) = True
  Else
     MsgBox “Data masih kosong!”, vbCritical, “Kosong”
  End If
  StatusEdit = False
  PosisiKetemu = 0
  KriteriaCari = “”
  KunciTeks
End Sub

Private Sub List1_Click()
   Dim fileNo As Integer
   Dim sFileName As String
   Dim tmp As String
   Dim pos As Integer
   Dim i As Integer
   Dim sPassword As String
   Dim sDesc As String
   Dim sLocation As String
   Dim sExpiry As String
  
   ‘On Error GoTo Pesan

     ‘If tmp = “” Then Exit Sub
     tmp = List1.Text
     ‘find the first comma
     pos = InStr(tmp, “,”)
     ‘extract the string up to the comma
     sPassword = Left$(tmp, pos - 1)
     ’shorten the string by removing the item
    ‘ready to find the next comma
     tmp = Mid$(tmp, pos + 1, Len(tmp))
     ‘do it again
     pos = InStr(tmp, “,”)
     sDesc = Left$(tmp, pos - 1)
     tmp = Mid$(tmp, pos + 1, Len(tmp))
     ‘do it again
     pos = InStr(tmp, “,”)
     sLocation = Left$(tmp, pos - 1)
     tmp = Mid$(tmp, pos + 1, Len(tmp))
     ‘the remainder is the expiry
     sExpiry = tmp
     ‘display the retrieved values
     txtPassword.Text = sPassword
     txtDescription.Text = sDesc
     txtLocation.Text = sLocation
     txtExpiry.Text = sExpiry
     RecordAktif = List1.ListIndex
     lblStatus.Caption = “Record ke-” & RecordAktif + 1 & ” dari ” & List1.ListCount & ” record”
     Exit Sub
Pesan:
     MsgBox Err.Number & ” - ” & Err.Description
End Sub

Private Sub List1_DblClick()
  ‘cmdEdit_Click
  If List1.ListCount > 0 Then
     SetButtons False
     cmdUpdate.Enabled = False
     KunciTeks
     cmdUpdateAll.Enabled = True
     StatusEdit = True
     If Not m_bEditing Then Editing = True
  Else
     MsgBox “Data masih kosong!”, vbCritical, “Data Kosong”
  End If
End Sub

Private Sub List1_GotFocus()
  RecordAktif = List1.ListIndex
  lblStatus.Caption = “Record ke-” & RecordAktif + 1 & ” dari ” & List1.ListCount & ” record”
End Sub

Private Sub List1_KeyPress(KeyAscii As Integer)
  If KeyAscii = 27 Then End
End Sub

Private Sub List1_KeyUp(KeyCode As Integer, Shift As Integer)
  If ((KeyCode = vbKeyF2) And (Shift = 0)) Then
     If (Not m_bEditing) Then Editing = True
  End If
End Sub
Private Sub Text1_LostFocus()
‘If the textbox looses focus and we’re editing, restore the text
‘and cancel the edit
  If m_bEditing = True Then
    List1.List(m_lngCurrIndex) = Text1.Tag
    Editing = False
  End If
End Sub
Private Sub Text1_KeyPress(KeyAscii As Integer)
Dim strText As String
  If KeyAscii = 10 Or KeyAscii = 13 Then
     If Len(Trim$(Text1.Text)) = 0 Then
        List1.List(m_lngCurrIndex) = Text1.Tag
     Else
        strText = Text1.Text
        ‘assign the new text to the item
        List1.List(m_lngCurrIndex) = strText
        List1_Click
        cmdUpdateAll.Enabled = True
     End If
     Editing = False ‘return to the old state
     KeyAscii = 0 ‘avoid a beep
  ElseIf KeyAscii = 27 Then ‘pressed Esc to cancel the edit
     List1.List(m_lngCurrIndex) = Text1.Tag ‘restore the original text
     Editing = False
     KeyAscii = 0 ‘avoid a beep
  End If
  lblTampung.Caption = txtPassword.Text
End Sub
Private Sub Text1_GotFocus()
  ’select all the text
  Text1.SelStart = 0
  Text1.SelLength = Len(Text1.Text)
  lblTampung.Caption = txtPassword.Text
End Sub
Private Sub Text1_Change()
Dim lpSize As SIZE
Dim phDC As Long
‘adjust the size of the textbox depending on the calculated
’size of the text it contains (or 50 pixels, whatever is greater)
‘note that the extent calculation fails (for some reason) when the
‘font is over 14 points, but if you have a listbox with a 14 point
‘font then you need some redesign there
  phDC = GetDC(Text1.hwnd)
  If GetTextExtentPoint32(phDC, Text1.Text, Len(Text1.Text), lpSize) = 1 Then
     Text1.Width = Max(50, lpSize.cx)
  End If
  Call ReleaseDC(Text1.hwnd, phDC)
End Sub

Private Property Let Editing(vData As Boolean)
Dim rcItem As RECT ‘RECT of the item being edited
Dim strText As String ‘text of the item beign edited
Dim lpSize As SIZE ‘uset to calculate the size of the textbox
Dim phDC As Long ‘hDC of the listbox
On Error Resume Next
  ‘Get the current index…
  m_lngCurrIndex = List1.ListIndex
  ‘…and split if there’s no index
  If m_lngCurrIndex = -1 Then Beep: Exit Property
  ‘are we starting an edit?
  If vData = True Then
  strText = List1.List(m_lngCurrIndex)
  If Len(strText) = 0 Then Beep: Exit Property
    ‘try to get the RECT of the item within the list
    If SendMessage(List1.hwnd, LB_GETITEMRECT, ByVal m_lngCurrIndex, rcItem) _
      <> LB_ERR Then
      ‘adjust the RECT to makeup. Note that these are client window coordinates
      ‘That is, the RECT is in relation to the list’s parent window.
      ‘We also take into consideration the 3-D border, so remove the call to
      ‘GetSystemMetrics() if the listbox’s appearance is “flat”
      With rcItem
        .Left = .Left + List1.Left + GetSystemMetrics(SM_CXEDGE)
        .Top = List1.Top + .Top
        ‘why not a call to GetSysMetrics and the SM_CYEDGE?
        ‘because we want the textbox to pop up centered over
        ‘the list item, not flush with the top.
    
        ‘Get the DC of the listbox and calculate the height and width of the
        ‘Note that the extent calculation fails (for some reason) when the
        ‘font is over 14 points.
        phDC = GetDC(Text1.hwnd)
        Call GetTextExtentPoint32(phDC, strText, Len(strText), lpSize)
        Call ReleaseDC(Text1.hwnd, phDC)
        ‘position and show the textbox, bring it to the top of the Z order.
        Call SetWindowPos(Text1.hwnd, HWND_TOP, .Left, .Top, Max(50, lpSize.cx), _
           lpSize.cy + 2, SWP_SHOWWINDOW Or SWP_NOREDRAW)
      End With
      ’setting the List property of the listbox causes too
      ‘much flashing, so turn off redrawing
      Call SendMessage(List1.hwnd, WM_SETREDRAW, 0, ByVal 0&amp
      List1.List(m_lngCurrIndex) = “”
      ’save the item’s text and set the focus to the textbox
      With Text1
        .Enabled = True
        .Tag = strText
        .Text = strText
        .SetFocus
      End With
    End If
  Else
    ’set the redraw flag so that the listbox updates itself
    Call SendMessage(List1.hwnd, WM_SETREDRAW, 1, ByVal 0&amp
    ‘Get rid of the textbox and clear it
    With Text1
      .Enabled = False
      .Visible = False
      .Move 800, 800
      .Text = “”
      .Tag = “”
    End With
    m_lngCurrIndex = -1 ‘invalidate this for next time
  End If
  ’save the current state
  m_bEditing = vData
End Property

Sub SetButtons(bVal As Boolean)
    cmdAdd.Enabled = bVal
    cmdEdit.Enabled = bVal
    cmdUpdate.Enabled = Not bVal
    cmdUpdateAll.Enabled = Not bVal
    cmdCancel.Enabled = Not bVal
    cmdDelAll.Enabled = bVal
    cmdDelete.Enabled = bVal
    cmdClose.Enabled = bVal
    cmdRefresh.Enabled = bVal
    cmdNext.Enabled = bVal
    cmdFirst.Enabled = bVal
    cmdLast.Enabled = bVal
    cmdPrevious.Enabled = bVal
    cmdFindFirst.Enabled = bVal
    cmdFindNext.Enabled = bVal
    cmdDelKriteria.Enabled = bVal
End Sub

Private Sub txtDescription_KeyPress(KeyAscii As Integer)
  If KeyAscii = 13 Then txtLocation.SetFocus
End Sub

Private Sub txtExpiry_KeyPress(KeyAscii As Integer)
  If KeyAscii = 13 Then
     If cmdUpdate.Enabled = True Then
        cmdUpdate.SetFocus
     ElseIf cmdUpdateAll.Enabled = True Then
        cmdUpdateAll.SetFocus
     End If
  End If
End Sub

Private Sub txtLocation_KeyPress(KeyAscii As Integer)
  If KeyAscii = 13 Then txtExpiry.SetFocus
End Sub

Private Sub txtPassword_KeyPress(KeyAscii As Integer)
  ‘cmdUpdateAll.Enabled = True
  If KeyAscii = 13 Then txtDescription.SetFocus
End Sub

Sub KunciTeks()
  txtPassword.Enabled = False
  txtDescription.Enabled = False
  txtLocation.Enabled = False
  txtExpiry.Enabled = False
End Sub
Sub BukaKunciTeks()
  txtPassword.Enabled = True
  txtDescription.Enabled = True
  txtLocation.Enabled = True
  txtExpiry.Enabled = True
End Sub