Menambahkan tombol baru di Title Bar

Yaph sesuai judulnya kita akan menambahkan tombol baru di Title Bar, lihat gambar :

oke langsung saja tambahkan sebuah modul kemudian copy paste kode berikut :

Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Private 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
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long

Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetVersionEx Lib "kernel32.dll" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long

Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion      As Long
    dwMinorVersion      As Long
    dwBuildNumber       As Long
    dwPlatformId        As Long
    szCSDVersion        As String * 128
End Type

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

Private Type CWPSTRUCT
    lParam              As Long
    wParam              As Long
    Message             As Long
    hwnd                As Long
End Type

Private Const WM_MOVE                       As Long = &H3
Private Const WM_SETCURSOR                  As Long = &H20
Private Const WM_NCPAINT                    As Long = &H85
Private Const WM_COMMAND                    As Long = &H111
Private Const BM_SETSTATE                   As Long = &HF3
Private Const SWP_FRAMECHANGED              As Long = &H20
Private Const WS_CHILD                      As Long = &H40000000
Private Const WS_VISIBLE                    As Long = &H10000000
Private Const WS_EX_TOOLWINDOW              As Long = &H80
Private Const VER_PLATFORM_WIN32_WINDOWS    As Long = 1
Private Const VER_PLATFORM_WIN32_NT         As Long = 2

Private MyForm                              As Form
Private frm                                 As Form
Private GiàIntercettato                     As Boolean
Private sysVar00_lOSVersion                 As Long
Private WHook                               As Long
Private ButtonHwnd                          As Long
Private lButtXPos                           As Long

Public Sub InitButton(frmObj As Form, Optional XPosition As Long = 75)
    Dim os As OSVERSIONINFO
    Dim retval As Long  ' return value

    os.dwOSVersionInfoSize = Len(os)  ' set the size of the structure
    retval = GetVersionEx(os)  ' read Windows's version information
    sysVar00_lOSVersion = os.dwPlatformId
    Set MyForm = frmObj
    GiàIntercettato = False

    Call UnHookButton

    Set frm = frmObj
    lButtXPos = XPosition

    ButtonHwnd = CreateWindowEx(WS_EX_TOOLWINDOW, "Button", "?", WS_CHILD + WS_VISIBLE, 50, 50, 14, 14, frmObj.hwnd, 0, App.hInstance, 0)

    WHook = SetWindowsHookEx(4, AddressOf HookProc, 0, App.ThreadID)

    Call SetParent(ButtonHwnd, GetParent(frmObj.hwnd))
End Sub

Public Sub UnHookButton()
    If lButtXPos > 0 Then

        lButtXPos = 0
        Call UnhookWindowsHookEx(WHook)
        Call DestroyWindow(ButtonHwnd)
    End If
End Sub

Private Function HookProc(ByVal ncode As Long, ByVal wParam As Long, Inf As CWPSTRUCT) As Long
    Dim FormRect As RECT
    Static LastParam As Long

    If Inf.hwnd = GetParent(ButtonHwnd) And sysVar00_lOSVersion = VER_PLATFORM_WIN32_WINDOWS Then
        If Inf.Message = WM_COMMAND Then
            Select Case LastParam

                Case ButtonHwnd
                    Call frm.btnNew_Click
            End Select
        ElseIf Inf.Message = WM_SETCURSOR Then
            LastParam = Inf.wParam
        End If

    ElseIf Inf.hwnd = frm.hwnd Then
        If Inf.Message = WM_NCPAINT Or Inf.Message = WM_MOVE Then

            Call GetWindowRect(frm.hwnd, FormRect)

            Call SetWindowPos(ButtonHwnd, 0, FormRect.Right - lButtXPos, FormRect.Top + 6, 17, 14, SWP_FRAMECHANGED)

        End If

    ElseIf Inf.hwnd = ButtonHwnd And sysVar00_lOSVersion = VER_PLATFORM_WIN32_NT Then
        If Inf.Message = BM_SETSTATE And Inf.wParam = 0 Then
            If GiàIntercettato = False Then
               GiàIntercettato = True
               Call MyForm.btnNew_Click
             Else
               GiàIntercettato = False
            End If
        End If
    End If

    HookProc = CallNextHookEx(WHook, ncode, wParam, Inf.lParam)
End Function

contoh penggunaan di form :

Private Sub Form_Load()
    Call InitButton(Me)
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Call UnHookButton
End Sub

Public Sub btnNew_Click()
    'TODO : tampilkan pesan atau form disini
End Sub

Selamat mencoba and happy coding !!!

referensi :

1. http://www.justvb.net/
2. http://www.Planet-Source-Code.com/vb/scripts/ShowCode.asp?txtCodeId=58651&lngWId=1