Saturday, November 23, 2013

VB6 DataGrid: Mouse Wheel Scroll Horizontal ScrollBar +SHIFT

Jika kita mencari source code untuk men-scroll DataGrid dari atas ke bawah (vertikal) tentu tidak akan kesulitan, tetapi bagaimana jika scroll-nya menyamping dari kiri ke kanan (horizontal) yang disertai dengan menekan tombol SHIFT? Nah, di bawah ini merupakan salah satu contoh source codenya, dengan mengimplentasikan SubClassing menggunakan komponen SSubTmr6.dll seperti yang telah diposting sebelumnya. 

Form:

Option Explicit 

Dim WithEvents cMouse As cDataGridScroll

'--------------------------------------------------------------------------
' http://khoiriyyah.blogspot.com
' menggunakan component VBAccelerator SSubTmr6.dll Steve McMahon
'--------------------------------------------------------------------------

Private Sub Form_Activate()
If DataGrid1.hWndEditor <> 0 Then cMouse.AttacthHWNDEditor
End Sub

Private Sub Form_Load()
With Adodc1
.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=biblio.mdb;Persist Security Info=False"
.RecordSource = "Select * from [titles]"
.Refresh
.Recordset.MoveFirst
End With
Set DataGrid1.DataSource = Adodc1
DataGrid1.Refresh
Set cMouse = New cDataGridScroll
With cMouse
.DataGrid = DataGrid1
End With
End Sub

Private Sub Form_Resize()
On Error Resume Next
DataGrid1.Move 0, 0, Me.ScaleWidth, Me.ScaleHeight
End Sub

Private Sub Form_Unload(Cancel As Integer)
Set cMouse = Nothing
End Sub

Class (cDataGridScroll.cls):

Option Explicit 

Implements ISubclass

'--------------------------------------------------------------------------
' http://khoiriyyah.blogspot.com
' menggunakan component VBAccelerator SSubTmr6.dll Steve McMahon
'--------------------------------------------------------------------------

Private Const WM_MOUSEWHEEL = &H20A
Private Const WHEEL_DELTA = 120
Private Const MK_SHIFT = &H4

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSrc As Any, ByVal cbSrc As Long)

Public Event MouseScroll(Shift As Integer)
Private WithEvents dtGrid As DataGrid
Dim GSubclass As New GSubclass

Public Sub AttacthHWNDEditor()
GSubclass.AttachMessage Me, dtGrid.hWndEditor, WM_MOUSEWHEEL
End Sub

Public Property Let DataGrid(New_DataGrid As DataGrid)
Set dtGrid = New_DataGrid
GSubclass.AttachMessage Me, dtGrid.hwnd, WM_MOUSEWHEEL
End Property

Private Property Let ISubclass_MsgResponse(ByVal RHS As SSubTimer6.EMsgResponse)
'
End Property

Private Property Get ISubclass_MsgResponse() As SSubTimer6.EMsgResponse
'
End Property

Private Function ISubclass_WindowProc(ByVal hwnd As Long, ByVal iMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim fwKeys As Integer, zDelta As Integer
Static intHScroll As Integer
Select Case iMsg
Case WM_MOUSEWHEEL
fwKeys = LoWord(wParam)
zDelta = HiWord(wParam) / WHEEL_DELTA
'Debug.Print "fwKeys: " & fwKeys
'Debug.Print "zDelta: " & zDelta
If fwKeys = 4 Then '+SHIFT
intHScroll = intHScroll + 1
If intHScroll > 5 Then 'memperlambat horizontal scroll
If zDelta > 0 Then
dtGrid.Scroll -1, 0
Else
dtGrid.Scroll 1, 0
End If
intHScroll = 0
End If
ElseIf fwKeys = 0 Then
If zDelta > 0 Then
dtGrid.Scroll 0, -1
Else
dtGrid.Scroll 0, 1
End If
ElseIf fwKeys = 8 Then '+CTRL 'ZOOM
If zDelta > 0 Then
dtGrid.Font.Size = dtGrid.Font.Size + 1
Else
If dtGrid.Font.Size > 2 Then
dtGrid.Font.Size = dtGrid.Font.Size - 1
End If
End If
End If
End Select
End Function

Private Sub Class_Terminate()
GSubclass.DetachMessage Me, dtGrid.hwnd, WM_MOUSEWHEEL
Set GSubclass = Nothing
Set dtGrid = Nothing
End Sub

Function LoWord(ByVal dwDoubleWord As Long) As Integer
Call CopyMemory(LoWord, dwDoubleWord, 2)
End Function

Function HiWord(ByVal dwDoubleWord As Long) As Integer
Call CopyMemory(HiWord, ByVal VarPtr(dwDoubleWord) + 2, 2)
End Function
READ MORE - VB6 DataGrid: Mouse Wheel Scroll Horizontal ScrollBar +SHIFT

Friday, November 22, 2013

Cara Menggunakan Komponen SubClassing SSubTmr6.dll

SSubTmr6.dll merupakan komponen yang dibuat oleh Steve McMahon. Tujuan utamanya adalah untuk mengimplementasikan subclassing dengan mudah, stabil, dan aman. Selengkapnya bisa Anda baca disini.

Di bawah ini merupakan langkah mudah cara menggunakan komponen subclassing SSubTmr6.dll. Setelah menambahkan referensi dll SSubTmr6.dll (vbAccelerator VB6 Subclassing And Timer Assistant...) selanjutnya, buatlah kerangkan kodenya seperti di bawah ini:

Option Explicit  

'--------------------------------------------------------------------------
' http://khoiriyyah.blogspot.com
' kerangka kode Subclassing SSubTmr6.dll Steve McMahon
'--------------------------------------------------------------------------
Dim GSubclass As New GSubclass
Implements ISubclass

Private Property Let ISubclass_MsgResponse(ByVal RHS As SSubTimer6.EMsgResponse)
'Kode ini boleh dikosongkan tetapi tidak boleh dihapus
End Property

Private Property Get ISubclass_MsgResponse() As SSubTimer6.EMsgResponse
'Kode ini boleh dikosongkan tetapi tidak boleh dihapus
End Property

Private Function ISubclass_WindowProc(ByVal hwnd As Long, ByVal iMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case iMsg
Case Message1
Case Message2
Case Etc
End Select
End Function

Di bawah ini merupakan contoh paling sederhana subclassing menggunakan komponen SSubTmr6.dll. Kode di bawah, digunakan untuk mengganti menu yang ditampilkan pada saat mengklik kanan komponen TextBox standar:

Option Explicit 

'--------------------------------------------------------------------------
' http://khoiriyyah.blogspot.com
' kerangka kode Subclassing SSubTmr6.dll Steve McMahon
'--------------------------------------------------------------------------
Dim GSubclass As New GSubclass
Implements ISubclass

'message windows yang akan dilampirkan (klik kanan)
Private Const WM_RBUTTONUP = &H205

Private Property Let ISubclass_MsgResponse(ByVal RHS As SSubTimer6.EMsgResponse)
'Kode ini boleh dikosongkan tetapi tidak boleh dihapus
End Property

Private Property Get ISubclass_MsgResponse() As SSubTimer6.EMsgResponse
'Kode ini boleh dikosongkan tetapi tidak boleh dihapus
End Property

Private Sub Form_Load()
'melampirkan message WM_RBUTTONUP-nya Text1 pada komponen
    GSubclass.AttachMessage Me, Text1.hwnd, WM_RBUTTONUP
End Sub

Private Sub Form_Unload(Cancel As Integer)
'menghilangkan message WM_RBUTTONUP-nya Text1 dari komponen
    GSubclass.DetachMessage Me, Text1.hwnd, WM_RBUTTONUP
Set GSubclass = Nothing 'bersihkan memory
End Sub

Private Function ISubclass_WindowProc(ByVal hwnd As Long, ByVal iMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case iMsg
Case WM_RBUTTONUP
'tampilkan menu mnuTest pada saat klik kanan di Text1
        PopupMenu mnuTest
End Select
End Function

Maka sekarang, pada saat kita mengklik kanan TextBox diganti menjadi seperti gambar di bawah ini:

mengganti menu klik kanan pada textbox
Gambar: Menu klik kanan default yang terdapat pada TextBox kita ganti dengan menu buatan kita sendiri

READ MORE - Cara Menggunakan Komponen SubClassing SSubTmr6.dll

Tuesday, November 19, 2013

Install Arabic di Windows 7

Mengenai cara install arabic di Windows 7 - Sebelumnya saya pernah memposting mengenai cara setting arabic pada pada Windows XP, maka pada kesempatan kali ini, kita akan membahas mengenai cara install/setting arabic language pada Windows 7.

Cara menginstall/setting arabic pada Windows 7 jauh lebih mudah dibandingkan dengan setting arabic pada Windows XP, mengapa demikian? karena menginstall arabic pada Windows 7 tidak memerlukan CD installer. Jadi, kemungkinan tidak akan ada judul posting yang seperti ini: Cara Install/Setting Arabic Pada Window 7 Tanpa CD Installer, karena memang tidak membutuhkannya.

Langkah-langkah installasi:

  • Klik Tombol Start >> Control Panel >> Clock, Language and Region >> Change keyboards or other input methods
  • Pada Dialog window Text Services and Input Languages, klik tombol Add
  • Pada window Add Input Language, pilih Arabic (Saudi Arabia) Klik tanda + pada Arabic (Saudi Arabia)  >>  tanda + Keyboard >> pilih Arabic (101)  >> OK.
  • Sampai disini, proses intallasi belum selesai, selanjutnya klik tombol Key Settings >> Change Key Sequence... >> Switch input languages >> CTRL + SHIFT, point yang terakhir ini maksudnya: apabila Anda ingin berpindah dari latin ke arab maka tekan CTRL + SHIFT (kanan) dan apabila Anda ingin berpindah dari Arab ke Latin tekan CTRL + SHIFT (kiri). Tentu saja ini akan sangat memudahkan sekali pada saat kita mengetik tulisan campuran antara Latin dan Arab.
Untuk lebih jelasnya, Anda bisa melihat video cara install arabic pada Windows 7:



Demikian mengenai cara install arabic pada Windows 7, Semoga bermanfaat.
READ MORE - Install Arabic di Windows 7

Friday, November 1, 2013

VB6 Trik - Mengukur Dimensi String Tanpa Fungsi API

Menjelaskan mengenai cara mengukur dimensi string yang menggunakan objek font tertentu tanpa menggunakan fungsi API.

Untuk berbagai keperluan, terkadang kita membutuhkan sebuah prosedure untuk mengukur dimensi sebuah string. Di samping dengan menggunakan fungsi API GetTextExtentPoint32, kitapun dapat mengukurnya dengan sebuah trik yang sederhana, di bawah ini adalah contohnya:

Option Explicit

Private Type hwFONT
Height As Integer
Width As Integer
End Type

Private Function GetWidthHeight(LabelCaption As String) As hwFONT
Dim lbl As Label, hwF As hwFONT
Set lbl = Controls.Add("VB.Label", "lblTestWidthHeight")
With lbl
.Caption = LabelCaption
.AutoSize = True
.Refresh
End With
hwF.Width = lbl.Width
hwF.Height = lbl.Height
GetWidthHeight = hwF
Controls.Remove "lblTestWidthHeight"
End Function

Private Function GetFontWidthHeight(LabelCaption As String, _
Optional FontName As String = "MS Sans Serif", _
Optional FontSize As String = 8) As hwFONT
Dim lbl As Label, hwF As hwFONT
Set lbl = Controls.Add("VB.Label", "lblTestWidthHeight")
With lbl
.FontName = FontName
.FontSize = FontSize
.Caption = LabelCaption
.AutoSize = True
.Refresh
End With
hwF.Width = lbl.Width
hwF.Height = lbl.Height
GetFontWidthHeight = hwF
Controls.Remove "lblTestWidthHeight"
End Function

Private Function GetFontObjectWH(LabelCaption As String, fntAny As StdFont) As hwFONT
Dim lbl As Label, hwF As hwFONT
Set lbl = Controls.Add("VB.Label", "lblTestWidthHeight")
With lbl
.Caption = LabelCaption
.AutoSize = True
Set .Font = fntAny
.Refresh
End With
hwF.Width = lbl.Width
hwF.Height = lbl.Height
GetFontObjectWH = hwF
Controls.Remove "lblTestWidthHeight"
End Function

Private Sub cmdTest1_Click()
Dim hwF As hwFONT
hwF = GetWidthHeight("Test")
List1.AddItem "Test"
Shape1.Width = hwF.Width
Picture1.Cls
Picture1.Print "Height: " & hwF.Height & vbCrLf & "Widht: " & hwF.Width
End Sub

Private Sub cmdTest3_Click()
Dim fntList As StdFont
Dim hwF As hwFONT
Set fntList = List1.Font
Dim strString As String
strString = "Test Font object"
List1.AddItem strString
hwF = GetFontObjectWH(strString, fntList)
Shape1.Width = hwF.Width
Picture1.Cls
Picture1.Print "Height: " & hwF.Height & vbCrLf & "Widht: " & hwF.Width
End Sub

Private Sub cmdTest2_Click()
Dim hwF As hwFONT
hwF = GetFontWidthHeight("Just Test")
List1.AddItem "Just Test"
Shape1.Width = hwF.Width
Picture1.Cls
Picture1.Print "Height: " & hwF.Height & vbCrLf & "Widht: " & hwF.Width
End Sub
Selanjutnya, dari contoh-contoh di atas yang akan kita gunakan untuk berbagai keperluan adalah:
Private Type hwFONT
Height As Integer
Width As Integer
End Type

Private Function GetFontObjectWH(LabelCaption As String, fntAny As StdFont) As hwFONT
Dim lbl As Label, hwF As hwFONT
Set lbl = Controls.Add("VB.Label", "lblTestWidthHeight")
With lbl
.Caption = LabelCaption
.AutoSize = True
Set .Font = fntAny
.Refresh
End With
hwF.Width = lbl.Width
hwF.Height = lbl.Height
GetFontObjectWH = hwF
Controls.Remove "lblTestWidthHeight"
End Function

Download project: String dimension (font height and width)

READ MORE - VB6 Trik - Mengukur Dimensi String Tanpa Fungsi API