ARBi Blog's Lama: Mengedit Data di ListBox

PERSIAPAN			PROPERTIES
NO	CONTROL	ITEM	NAME	VALUE	KETERANGAN
1.	CommandButton	1	Caption	Hapus
2.	ListBox	1
3.	Textbox	1

Masukkan souce ini ke dalam Form :

Option Explicit
DefLng A-Z
Private m_bEditing As Boolean
Private m_lngCurrIndex As Long

Private Sub Command1_Click()
  If Not m_bEditing Then Editing = True
End Sub

Private Sub Form_Load()
  Me.ScaleMode = 3
  Text1.Visible = False
  Text1.Appearance = 0
  Command1.Caption = "Tekan F2 utk mengedit"
  Dim a%
  For a% = 1 To 10
     List1.AddItem "Item yang ke-" & a%
  Next a%
  Set Text1.Font = List1.Font
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()
  'Jika textbox kehilangan fokus ketika kita mengedit data, kembalikan
  'data/teks semula dan batalkan proses pengeditan yg telah berlangsung.
  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
       'Assginment-kan teks baru ke item data di Listbox ybt
       List1.List(m_lngCurrIndex) = strText
    End If
    Editing = False 'Kembalikan ke posisi semula
    KeyAscii = 0 'Menghindari bunyi beep
  ElseIf KeyAscii = 27 Then 'Jika ditekan Esc untuk membatalkan pengeditan
    List1.List(m_lngCurrIndex) = Text1.Tag 'Kembalikan data semula
    Editing = False
    KeyAscii = 0 'Menghindari bunyi beep
  End If
End Sub

Private Sub Text1_GotFocus()
  'Jika Text1 mendapat fokus, sorot semua isinya.
  Text1.SelStart = 0
  Text1.SelLength = Len(Text1.Text)
End Sub

Private Sub Text1_Change()
Dim lpSize As SIZE
Dim phDC As Long
  'Atur ukuran textbox tergantung dari hasil perhitungan
  'ukuran dari textbox dalam pixels
  'Catatan bahwa tingkat perhitungan gagal (untuk beberapa alasan) ketika
  'huruf melebihi dari 14 points, tapi jika Anda mempunyai sebuah listbox
  'dengan huruf 14 point, Anda harus men-design-nya dari sana.
  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
  'Ambil index dari item data
  m_lngCurrIndex = List1.ListIndex
  '... perlakuan khusus jika tidak ada index
  If m_lngCurrIndex = -1 Then Beep: Exit Property
 
  'Mulai mengedit data...
  If vData = True Then
    strText = List1.List(m_lngCurrIndex)
    If Len(strText) = 0 Then Beep: Exit Property
    'Coba mengambil type RECT dari item dalam list
    If SendMessage(List1.hwnd, LB_GETITEMRECT, ByVal m_lngCurrIndex, rcItem) _
      <> LB_ERR Then
     'Atur RECT. Catatan bahwa ini adalah koordinat di layar
     'Itulah mengapa RECT berhubungan dengan luas dari jendela Listbox
     'Kita juga mempertimbangkan dengan batas 3-D listbox, jadi jangan memanggil
     'fungsi GetSystemMetrics() jika property Appearence listbox = "Flat"
     With rcItem
      .Left = .Left + List1.Left + GetSystemMetrics(SM_CXEDGE)
      .Top = List1.Top + .Top
      'Mengapa tidak memanggil fungsi GetSysMetrics dan SM_CYEDGE?
      '...karena kita ingin data berada di tengah textbox

      'Ambil DC dari listbox lalu hitung tinggi dan lebarnya
      'Catatan bahwa hasil perhitungan gagal (untuk beberapa alasan) ketika
      'ukuran huruf melebihi dari 14 points.
      phDC = GetDC(Text1.hwnd)
      Call GetTextExtentPoint32(phDC, strText, Len(strText), lpSize)
      Call ReleaseDC(Text1.hwnd, phDC)
      'Posisikan dan tampilkan textbox, bawa ke tampilan/urutan teratas.
      Call SetWindowPos(Text1.hwnd, HWND_TOP, .Left, .Top, Max(50, lpSize.cx), _
           lpSize.cy + 2, SWP_SHOWWINDOW Or SWP_NOREDRAW)
     End With
     'Setting property Listbox menyebabkan banyak efek pemunculan, jadi
     'matikan property "redrawing"
     Call SendMessage(List1.hwnd, WM_SETREDRAW, 0, ByVal 0&)
     List1.List(m_lngCurrIndex) = ""
     'Simpan item data dan set fokus ke textbox
     With Text1
       .Enabled = True
       .Tag = strText
       .Text = strText
       .SetFocus
     End With
    End If
  Else
    'Set tanda redraw sehingga listbox menyesuaikan sendiri
    Call SendMessage(List1.hwnd, WM_SETREDRAW, 1, ByVal 0&)
    'Bersihkan isi textbox
    With Text1
      .Enabled = False
      .Visible = False
      .Move 800, 800
      .Text = ""
      .Tag = ""
    End With
    m_lngCurrIndex = -1 'invalidate this for next time
  End If
  'Simpan posisi terbaru..........
  m_bEditing = vData
End Property

Masukkan souce ini ke dalam Module :

Option Explicit
DefLng A-Z

Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type

Type SIZE
  cx As Long
  cy As Long
End Type

Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
  (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
  lParam As Any) As Long
Declare Function GetTextExtentPoint32 Lib "gdi32" Alias _
  "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal _
  cbString As Long, lpSize As SIZE) As Long
Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal _
  hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As _
  Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, _
  ByVal hdc As Long) As Long

Public Const WM_SETREDRAW = &HB&
Public Const WM_SETFONT = &H30
Public Const WM_GETFONT = &H31
Public Const LB_GETITEMRECT = &H198
Public Const LB_ERR = (-1)
Public Const SWP_NOSIZE = &H1
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOZORDER = &H4
Public Const SWP_NOREDRAW = &H8
Public Const SWP_NOACTIVATE = &H10
Public Const SWP_FRAMECHANGED = &H20
Public Const SWP_SHOWWINDOW = &H40
Public Const SWP_HIDEWINDOW = &H80
Public Const SWP_NOCOPYBITS = &H100
Public Const SWP_NOOWNERZORDER = &H200
Public Const SWP_DRAWFRAME = SWP_FRAMECHANGED
Public Const SWP_NOREPOSITION = SWP_NOOWNERZORDER
Public Const HWND_TOP = 0
Public Const HWND_BOTTOM = 1
Public Const HWND_TOPMOST = -1
Public Const HWND_NOTOPMOST = -2
Public Const SM_CXEDGE = 45
Public Const SM_CYEDGE = 46

Public Function Max(ByVal param1 As Long, ByVal param2 As Long) As Long
  If param1 > param2 Then Max = param1 Else Max = param2
End Function

Kategori

Archive

Blogroll

Member

Jumat, 02 Oktober 2009

Mengedit Data di ListBox

0 komentar:

Logo

About Me