Harus diinport referencess Microsoft Excel 12.0 Object Library
Kelebihan program ini adalah :
- Daftar datanya bisa discroll menggunakan mouse (ada tambahan kode program untuk aktifkan scroll msflexgrid).
- MsFlexgrid bisa di edit langsung, menggunakan textbox dan combobox.
Berikut sourcecode yang saya buat. semoga bermanfaat.
'Form 1 source code.........................................................................................................................
Private Sub DataFG_Click()
TxtEdit.Visible = False
FrameTambah.Visible = False
End Sub
Private Sub DataFG_DblClick()
DataFG_KeyPress 13
End Sub
Private Sub DataFG_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
If FrameTambah.Visible = True Then Exit Sub
If DataFG.Enabled = False Then Exit Sub
If DataFG.Rows <= 0 Then Exit Sub
EditorFG
End If
End Sub
Sub EditorFG()
TxtEdit.Left = DataFG.CellLeft + DataFG.Left
TxtEdit.Top = DataFG.CellTop + DataFG.Top
TxtEdit.Width = DataFG.CellWidth
TxtEdit.Height = DataFG.CellHeight
TxtEdit.Visible = True
TxtEdit.Text = DataFG.Text
TxtEdit.SetFocus
DoEvents
End Sub
Private Sub DataFG_KeyUp(KeyCode As Integer, Shift As Integer)
Dim Ndt As String
Dim Nno As String
Dim N As Integer
If KeyCode = 46 Then 'delete
If DataFG.Rows <= 1 Then Exit Sub
N = DataFG.Row
Ndt = DataFG.TextMatrix(N, 1)
Nno = DataFG.TextMatrix(DataFG.Row, 4)
If MsgBox("Hapus data " & Ndt, vbYesNo + vbQuestion, "Delete") = vbNo Then Exit Sub
DATA1.RecordSource = "select * from alamat where id=" & Nno
DATA1.Refresh
If DATA1.Recordset.RecordCount > 0 Then DATA1.Recordset.Delete
txtCari_KeyUp 0, 0
DataFG.SetFocus
End If
End Sub
Private Sub DataFG_Scroll()
TxtEdit.Visible = False
FrameTambah.Visible = False
End Sub
Private Sub Form_Activate()
tmrLoad.Enabled = True
End Sub
Private Sub Form_Load()
FrameTambah.Top = DataFG.Top + DataFG.Height + 50
FrameTambah.Left = DataFG.Left
FrameTambah.Visible = False
LblJml.Caption = "0"
txtCari.Text = ""
End Sub
Private Sub Form_Unload(Cancel As Integer)
If DataFG.Enabled = False Then
Cancel = 1
Else
Call WheelUnHook(Me.hwnd)
Cancel = 0
End If
End Sub
Private Sub ImageExport_Click()
If DataFG.Enabled = False Then Exit Sub
Frameexport.Visible = True
DataFG.Enabled = False
txtCari.Enabled = False
EXPORT_DATA
Frameexport.Visible = False
txtCari.Enabled = True
DataFG.Enabled = True
End Sub
Private Sub ImageTambah_Click()
If DataFG.Enabled = False Then Exit Sub
TXTtambah(0).Text = ""
TXTtambah(1).Text = ""
TXTtambah(2).Text = ""
DataFG.Enabled = False
FrameTambah.Visible = True
TXTtambah(0).SetFocus
End Sub
Private Sub tmrLoad_Timer()
tmrLoad.Enabled = False
If tmrLoad.Tag = "1" Then Exit Sub
tmrLoad.Tag = "1" 'just load
ConnectDBS
Call DataFG_Fill("SELECT * FROM ALAMAT ORDER BY NAMA")
Call WheelHook(Me.hwnd)
End Sub
Private Sub txtCari_KeyUp(KeyCode As Integer, Shift As Integer)
Dim Zdt As String
If KeyCode = 27 Then Exit Sub
If DataFG.Enabled = False Then Exit Sub
txtCari.Locked = True
Zdt = "select * from alamat where " & _
" nama like '%" & txtCari.Text & "%' or " & _
" telepon like '%" & txtCari.Text & "%' or " & _
" alamat like '%" & txtCari.Text & "%' "
DataFG_Fill Zdt
txtCari.Locked = False
End Sub
Private Sub TxtEdit_GotFocus()
TxtEdit.SetFocus
TxtEdit.SelStart = 0
TxtEdit.SelLength = Len(TxtEdit.Text)
End Sub
Private Sub TxtEdit_KeyPress(KeyAscii As Integer)
Dim Ndt As Double
If KeyAscii = 27 Then
TxtEdit.Visible = False
DataFG.SetFocus
Exit Sub
End If
If KeyAscii = 13 Then
TxtEdit.Text = UCase(TxtEdit.Text)
TxtEdit.Text = Replace(TxtEdit.Text, "%", "")
TxtEdit.Text = Replace(TxtEdit.Text, "\", "")
TxtEdit.Text = Replace(TxtEdit.Text, "'", "")
TxtEdit.Text = Replace(TxtEdit.Text, """", "")
TxtEdit.Text = Replace(TxtEdit.Text, "*", "")
Ndt = CDbl(DataFG.TextMatrix(DataFG.Row, 4))
If DataFG.Col = 1 Then 'nama
DATA1.RecordSource = "select * from alamat where id=" & Ndt
DATA1.Refresh
If DATA1.Recordset.RecordCount > 0 Then
DATA1.Recordset.Fields("Nama") = TxtEdit.Text
DATA1.Recordset.Update
DataFG.Text = TxtEdit.Text
End If
End If
If DataFG.Col = 2 Then 'nama
DATA1.RecordSource = "select * from alamat where id=" & Ndt
DATA1.Refresh
If DATA1.Recordset.RecordCount > 0 Then
DATA1.Recordset.Fields("telepon") = TxtEdit.Text
DATA1.Recordset.Update
DataFG.Text = TxtEdit.Text
End If
End If
If DataFG.Col = 3 Then 'alamat
DATA1.RecordSource = "select * from alamat where id=" & Ndt
DATA1.Refresh
If DATA1.Recordset.RecordCount > 0 Then
DATA1.Recordset.Fields("alamat") = TxtEdit.Text
DATA1.Recordset.Update
DataFG.Text = TxtEdit.Text
End If
End If
DataFG.TextMatrix(DataFG.Row, 4) = DATA1.Recordset.Fields("id")
'DATA1.Recordset.Close
TxtEdit.Visible = False
DataFG.SetFocus
End If
End Sub
Private Sub TXTtambah_GotFocus(Index As Integer)
TXTtambah(Index).BackColor = &HFFFFFF
End Sub
Private Sub TXTtambah_KeyPress(Index As Integer, KeyAscii As Integer)
If KeyAscii = 27 Then
FrameTambah.Visible = False
DataFG.Enabled = True
End If
If KeyAscii = 13 Then
If Index = 0 Then TXTtambah(1).SetFocus
If Index = 1 Then TXTtambah(2).SetFocus
If Index = 2 Then SimpanData
End If
End Sub
Sub SimpanData()
Dim A As Integer
With DATA1.Recordset
.AddNew
.Fields("nama") = TXTtambah(0).Text
.Fields("alamat") = TXTtambah(1).Text
.Fields("telepon") = TXTtambah(2).Text
.Update
End With
A = DataFG.Rows
DataFG.Rows = A + 1
DataFG.TextMatrix(A, 0) = A
DataFG.TextMatrix(A, 1) = TXTtambah(0).Text
DataFG.TextMatrix(A, 2) = TXTtambah(1).Text
DataFG.TextMatrix(A, 3) = TXTtambah(2).Text
DataFG.TextMatrix(A, 4) = DATA1.Recordset.Fields("id")
TXTtambah(0).Text = ""
TXTtambah(1).Text = ""
TXTtambah(2).Text = ""
TXTtambah(0).SetFocus
End Sub
Private Sub TXTtambah_LostFocus(Index As Integer)
TXTtambah(Index).BackColor = &HE0E0E0
TXTtambah(Index).Text = UCase(TXTtambah(Index).Text)
TXTtambah(Index).Text = Replace(TXTtambah(Index).Text, "%", "")
TXTtambah(Index).Text = Replace(TXTtambah(Index).Text, "\", "")
TXTtambah(Index).Text = Replace(TXTtambah(Index).Text, "'", "")
TXTtambah(Index).Text = Replace(TXTtambah(Index).Text, """", "")
TXTtambah(Index).Text = Replace(TXTtambah(Index).Text, "*", "")
End Sub
' Here you can add scrolling support to controls that don't normally respond.
' This Sub could always be moved to a module to make scrollwheel behaviour
' generic across forms.
' ===========================================================================
Public Sub MouseWheel(ByVal MouseKeys As Long, ByVal Rotation As Long, ByVal Xpos As Long, ByVal Ypos As Long)
Dim ctl As Control, cContainerCtl As Control
Dim bHandled As Boolean
Dim bOver As Boolean
For Each ctl In Controls
' Is the mouse over the control
On Error Resume Next
bOver = (ctl.Visible And IsOver(ctl.hwnd, Xpos, Ypos))
On Error GoTo 0
If bOver Then
' If so, respond accordingly
bHandled = True
Select Case True
Case TypeOf ctl Is MSFlexGrid
FlexGridScroll ctl, MouseKeys, Rotation, Xpos, Ypos
Case TypeOf ctl Is PictureBox, TypeOf ctl Is Frame
Set cContainerCtl = ctl: bHandled = False
Case TypeOf ctl Is ListBox, TypeOf ctl Is TextBox, TypeOf ctl Is ComboBox
' These controls already handle the mousewheel themselves, so allow them to:
If ctl.Enabled Then ctl.SetFocus
Case Else
bHandled = False
End Select
If bHandled Then Exit Sub
End If
bOver = False
'Debug.Print ctl.Name
Next ctl
End Sub
'Module Session................................................................................
Option Explicit
' Store WndProcs
Private Declare Function GetProp Lib "user32.dll" Alias "GetPropA" ( _
ByVal hwnd As Long, _
ByVal lpString As String) As Long
Private Declare Function SetProp Lib "user32.dll" Alias "SetPropA" ( _
ByVal hwnd As Long, _
ByVal lpString As String, _
ByVal hData As Long) As Long
Private Declare Function RemoveProp Lib "user32.dll" Alias "RemovePropA" ( _
ByVal hwnd As Long, _
ByVal lpString As String) As Long
' Hooking
Private Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" ( _
ByVal lpPrevWndFunc As Long, _
ByVal hwnd As Long, _
ByVal Msg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" ( _
ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" ( _
ByVal hwnd As Long, _
ByVal Msg As Long, _
wParam As Any, _
lParam As Any) As Long
' Position Checking
Private Declare Function GetWindowRect Lib "user32" ( _
ByVal hwnd As Long, _
lpRect As RECT) As Long
Private Declare Function GetAncestor Lib "user32.dll" ( _
ByVal hwnd As Long, _
ByVal gaFlags As Long) As Long
Private Const GWL_WNDPROC = -4
Private Const WM_MOUSEWHEEL = &H20A
Private Const CB_GETDROPPEDSTATE = &H157
Private Const GA_ROOT = 2
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
' Check Messages
' ================================================
Private Function WindowProc(ByVal Lwnd As Long, ByVal Lmsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim MouseKeys As Long
Dim Rotation As Long
Dim Xpos As Long
Dim Ypos As Long
Dim fFrm As Form
Select Case Lmsg
Case WM_MOUSEWHEEL
MouseKeys = wParam And 65535
Rotation = wParam / 65536
Xpos = lParam And 65535
Ypos = lParam / 65536
Set fFrm = GetForm(Lwnd)
If fFrm Is Nothing Then
' it's not a form
If Not IsOver(Lwnd, Xpos, Ypos) And IsOver(GetAncestor(Lwnd, GA_ROOT), Xpos, Ypos) Then
' it's not over the control and is over the form,
' so fire mousewheel on form (if it's not a dropped down combo)
If SendMessage(Lwnd, CB_GETDROPPEDSTATE, 0&, 0&) <> 1 Then
GetForm(GetAncestor(Lwnd, GA_ROOT)).MouseWheel MouseKeys, Rotation, Xpos, Ypos
Exit Function ' Discard scroll message to control
End If
End If
Else
' it's a form so fire mousewheel
If IsOver(fFrm.hwnd, Xpos, Ypos) Then fFrm.MouseWheel MouseKeys, Rotation, Xpos, Ypos
End If
End Select
WindowProc = CallWindowProc(GetProp(Lwnd, "PrevWndProc"), Lwnd, Lmsg, wParam, lParam)
End Function
' Hook / UnHook
' ================================================
Public Sub WheelHook(ByVal hwnd As Long)
On Error Resume Next
SetProp hwnd, "PrevWndProc", SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub
Public Sub WheelUnHook(ByVal hwnd As Long)
On Error Resume Next
SetWindowLong hwnd, GWL_WNDPROC, GetProp(hwnd, "PrevWndProc")
RemoveProp hwnd, "PrevWndProc"
End Sub
' Window Checks
' ================================================
Public Function IsOver(ByVal hwnd As Long, ByVal lX As Long, ByVal lY As Long) As Boolean
Dim rectCtl As RECT
GetWindowRect hwnd, rectCtl
With rectCtl
IsOver = (lX >= .Left And lX <= .Right And lY >= .Top And lY <= .Bottom)
End With
End Function
Private Function GetForm(ByVal hwnd As Long) As Form
For Each GetForm In Forms
If GetForm.hwnd = hwnd Then Exit Function
Next GetForm
Set GetForm = Nothing
End Function
' Control Specific Behaviour
' ================================================
Public Sub FlexGridScroll(ByRef FG As MSFlexGrid, ByVal MouseKeys As Long, ByVal Rotation As Long, ByVal Xpos As Long, ByVal Ypos As Long)
Dim NewValue As Long
Dim Lstep As Single
On Error Resume Next
With FG
' Lstep = .Height / .RowHeight(0)
' Lstep = Int(Lstep)
' If .Rows < Lstep Then Exit Sub
' Do While Not (.RowIsVisible(.TopRow + Lstep))
' Lstep = Lstep - 1
' Loop
'
Lstep = 1
If Rotation > 0 Then
NewValue = .TopRow - Lstep
If NewValue < 1 Then
NewValue = 1
End If
Else
NewValue = .TopRow + Lstep
If NewValue > .Rows - 1 Then
NewValue = .Rows - 1
End If
End If
.TopRow = NewValue
End With
End Sub
Public Sub PictureBoxZoom(ByRef picBox As PictureBox, ByVal MouseKeys As Long, ByVal Rotation As Long, ByVal Xpos As Long, ByVal Ypos As Long)
picBox.Cls
picBox.Print "MouseWheel " & IIf(Rotation < 0, "Down", "Up")
End Sub
Sub ConnectDBS()
With Futama
.DATA1.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\DATA.mdb;Mode=ReadWrite;Persist Security Info=False"
End With
End Sub
Sub DataFG_clear()
With Futama.DataFG
.Clear
.Cols = 5
.Rows = 1
.Col = 0
.Font.Bold = True
.TextMatrix(0, 0) = "NO"
.ColWidth(0) = 500
.ColAlignment(0) = flexAlignLeftCenter
.Col = 1
.Font.Bold = True
.TextMatrix(0, 1) = "NAMA"
.ColWidth(1) = 3000
.ColAlignment(1) = flexAlignLeftCenter
.Col = 2
.Font.Bold = True
.TextMatrix(0, 2) = "NO TLP / HP"
.ColWidth(2) = 3000
.ColAlignment(2) = flexAlignLeftCenter
.Col = 3
.Font.Bold = True
.TextMatrix(0, 3) = "ALAMAT"
.ColWidth(3) = 3000
.ColAlignment(3) = flexAlignLeftCenter
.Col = 4
.TextMatrix(0, 4) = "id"
.ColWidth(4) = 0
.Font.Bold = True
.ColAlignment(4) = flexAlignLeftCenter
End With
End Sub
Sub DataFG_Fill(Nsql As String)
Dim A, X As Integer
DataFG_clear
With Futama
'.Data1.Connect = "Excel 8.0;"
'.Data1.DatabaseName = App.Path & "\data.xls"
.DATA1.RecordSource = Nsql
.DATA1.Refresh
.LblJml.Caption = Format(.DATA1.Recordset.RecordCount, "#,##0")
A = 1
If .DATA1.Recordset.RecordCount > 0 Then .DATA1.Recordset.MoveFirst
While Not .DATA1.Recordset.EOF
A = .DataFG.Rows
.DataFG.Rows = A + 1
' MsgBox .Data1.Recordset.Fields(0).Name
.DataFG.TextMatrix(A, 0) = A 'no
'If .DATA1.Recordset.Fields(1) <> "" Then .DataFG.TextMatrix(A, 1) = .DATA1.Recordset.Fields(1) 'no
If .DATA1.Recordset.Fields(2) <> "" Then .DataFG.TextMatrix(A, 1) = .DATA1.Recordset.Fields(2)
If .DATA1.Recordset.Fields(3) <> "" Then .DataFG.TextMatrix(A, 2) = .DATA1.Recordset.Fields(3)
If .DATA1.Recordset.Fields(4) <> "" Then .DataFG.TextMatrix(A, 3) = .DATA1.Recordset.Fields(4)
If .DATA1.Recordset.Fields(0) <> "" Then .DataFG.TextMatrix(A, 4) = .DATA1.Recordset.Fields(0)
.DATA1.Recordset.MoveNext
Wend
End With
End Sub
Sub EXPORT_DATA()
Dim Tmp As String
Dim A, B As Integer
Dim App2a As Excel.Application
Dim Wb As Workbook
Dim Wk As Worksheet
Dim Baris As Long, Kolom As Integer
Dim X As Integer
'LblTOP(1).Caption = "Buka Excel Worksheet..."
DoEvents
Set App2a = Excel.Application
Set Wb = App2a.Workbooks.Add
Set Wk = Wb.Worksheets(1)
'
Range("A1").Font.Size = 14
Range("A1").Font.Bold = True
Wk.Cells(1, 1).Value = "DATA ALAMAT"
Wk.Columns(1).HorizontalAlignment = xlHAlignLeft
Range("A3").Font.Size = 11
Range("A3").Font.Bold = True
Wk.Cells(3, 1).HorizontalAlignment = xlHAlignLeft
Wk.Cells(3, 1).Value = "NO"
Wk.Cells(3, 1).ColumnWidth = 5
Range("B3").Font.Size = 11
Range("B3").Font.Bold = True
Wk.Cells(3, 2).HorizontalAlignment = xlHAlignLeft
Wk.Cells(3, 2).Value = "NAMA"
Wk.Cells(3, 2).ColumnWidth = 20
Range("C3").Font.Size = 11
Range("C3").Font.Bold = True
Wk.Cells(3, 3).HorizontalAlignment = xlHAlignLeft
Wk.Cells(3, 3).Value = "NO TLP / HP"
Wk.Cells(6, 3).ColumnWidth = 20
Range("D3").Font.Size = 11
Range("D3").Font.Bold = True
Wk.Cells(3, 4).HorizontalAlignment = xlHAlignLeft
Wk.Cells(3, 4).Value = "ALAMAT"
Wk.Cells(3, 4).ColumnWidth = 50
Range("A3:D3").Interior.Color = RGB(127, 187, 199)
Baris = 4
Kolom = 1
If Futama.DataFG.Rows <= 1 Then
Futama.pb.Max = 10
Else
Futama.pb.Max = Futama.DataFG.Rows
End If
Futama.pb.Min = 0
Futama.pb.Value = 0
Futama.pb.Visible = True
For X = 1 To Futama.DataFG.Rows - 1
Futama.pb.Value = X
DoEvents
Wk.Cells(Baris, Kolom).Font.Name = "Arial Narrow"
Wk.Cells(Baris, Kolom).Font.Size = 10
Wk.Cells(Baris, Kolom).HorizontalAlignment = xlHAlignLeft
Kolom = 1
Wk.Cells(Baris, Kolom).Value = X
Wk.Cells(Baris, Kolom).NumberFormat = "#,##0"
Wk.Cells(Baris, Kolom).HorizontalAlignment = xlHAlignLeft
Kolom = Kolom + 1
Wk.Cells(Baris, Kolom).Value = Futama.DataFG.TextMatrix(X, 1)
Wk.Cells(Baris, Kolom).HorizontalAlignment = xlHAlignLeft
Kolom = Kolom + 1
Wk.Cells(Baris, Kolom).Value = Futama.DataFG.TextMatrix(X, 2)
Wk.Cells(Baris, Kolom).HorizontalAlignment = xlHAlignLeft
Kolom = Kolom + 1
Wk.Cells(Baris, Kolom).Value = Futama.DataFG.TextMatrix(X, 3)
Wk.Cells(Baris, Kolom).HorizontalAlignment = xlHAlignLeft
Kolom = Kolom + 1
Baris = Baris + 1
Next
App2a.Visible = True
Set Wk = Nothing
Set Wb = Nothing
Set App2a = Nothing
End Sub
'EOF..........................................................................................................................................
Anda boleh COPAS (copy & paste) kode diatas tanpa merubah judul dan pembuat program (d2n92.blogspot.com).
Silahkan download sourcecode data alamat
