Jumat, 19 Oktober 2012

Menampilkan MsgBox Pada Posisi Tertentu di Layar


Bosan dengan posisi MsgBox asli bawaan VB6 yang selalu berada di tengah layar monitor Anda? Apakah Anda ingin menampilkannya pada posisi yang Anda inginkan? Gunakan trik berikut ini.
Code::


'Deskripsi : Membuat posisi MsgBox asli VB6 berada pada posisi tertentu di layar monitor.
'Sumber    : http://www.vbcode.com
'Pembuat   : Masino Sinaga (admin@masinosinaga.com)
'Tanggal   : 3 April 2008 
'Persiapan : 1. Buat satu project dengan satu form, satu module, dan satu commandbutton
'            2. Copy-kan coding berikut masing-masing ke module dan form.
'------------------------------------------
 
'--- awal coding di Form ---
Private Sub Command1_Click()
    MsgBoxEx "This is only a test MsgBox at position 100, 200", _
             100, 200, Custom, vbQuestion + vbAbortRetryIgnore, "Title"
End Sub
'--- akhir coding di Form ---
 
'--- awal coding di Module ---
Option Explicit
 
Public Enum StartupPos
    CenterScreen
    CenterOwner
    Custom
End Enum
 
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 Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
        (Destination As Any, Source As Any, ByVal Length 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 CallNextHookEx Lib "user32" (ByVal hHook As Long, _
        ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" _
        (ByVal hHook As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
        (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" 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 GetClassName Lib "user32" Alias "GetClassNameA" _
        (ByVal hwnd As Long, ByVal lpClassName As String, _
        ByVal nMaxCount 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 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 Const SWP_FRAMECHANGED = &H20
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOZORDER = &H4
Private Const GWL_WNDPROC = (-4)
Private Const WH_CALLWNDPROC = 4
Private Const WM_CREATE = &H1
Private Const WM_INITDIALOG = &H110
 
Private MSGBOXEX_X As Integer
Private MSGBOXEX_Y As Integer
Private MSGBOXEX_STARTUP As StartupPos
Private lPrevWnd As Long
Private lHook As Long
 
Private Function SubMsgBox(ByVal hwnd As Long, ByVal Msg As Long, _
                           ByVal wParam As Long, ByVal lParam As Long) As Long
  Dim tRECT As RECT
  Dim tOWNER As RECT
  If Msg = WM_INITDIALOG Then
    'Posisikan MsgBox jika memungkinakan...
    If MSGBOXEX_STARTUP = CenterOwner Then
      Call GetWindowRect(GetParent(hwnd), tOWNER)
    Else
      Call GetWindowRect(0, tOWNER)
    End If
  Call GetWindowRect(hwnd, tRECT)
  Select Case MSGBOXEX_STARTUP
    Case Custom
        If MSGBOXEX_X = -1 Then
            'Center Horizontal
            tRECT.Left = ((Screen.Width / Screen.TwipsPerPixelX) - _
                         (tRECT.Right - tRECT.Left)) / 2
        Else
            'Position Horizontal
            tRECT.Left = MSGBOXEX_X
        End If
        If MSGBOXEX_Y = -1 Then
            'Center Vertical
            tRECT.Top = ((Screen.Height / Screen.TwipsPerPixelY) - _
                        (tRECT.Bottom - tRECT.Top)) / 2
        Else
            'Position Vertical
            tRECT.Top = MSGBOXEX_Y
        End If
        Call SetWindowPos(hwnd, 0, tRECT.Left, tRECT.Top, 0, 0, SWP_NOSIZE Or _
                          SWP_NOZORDER Or SWP_FRAMECHANGED)
 
    Case CenterOwner
        tRECT.Left = tOWNER.Left + (((tOWNER.Right - tOWNER.Left) - _
                     (tRECT.Right - tRECT.Left)) / 2)
        tRECT.Top = tOWNER.Top + (((tOWNER.Bottom - tOWNER.Top) - _
                    (tRECT.Bottom - tRECT.Top)) / 2)
        Call SetWindowPos(hwnd, 0, tRECT.Left, tRECT.Top, 0, 0, _
                          SWP_NOSIZE Or SWP_NOZORDER Or SWP_FRAMECHANGED)
 
    End Select
    'Remove the Messagebox Subclassing
    Call SetWindowLong(hwnd, GWL_WNDPROC, lPrevWnd)
  End If
  SubMsgBox = CallWindowProc(lPrevWnd, hwnd, Msg, wParam, ByVal lParam)
End Function
 
Private Function HookWindow(ByVal nCode As Long, ByVal wParam As Long, _
                            ByVal lParam As Long) As Long
    Dim tCWP As CWPSTRUCT
    Dim sClass As String
    'This is where you need to Hook the Messagebox
    CopyMemory tCWP, ByVal lParam, Len(tCWP)
    Select Case tCWP.message
        Case WM_CREATE
            sClass = Space(255)
            sClass = Left(sClass, GetClassName(tCWP.hwnd, ByVal sClass, 255))
            If sClass = "#32770" Then
               'Subclass the Messagebox as it's created
               lPrevWnd = SetWindowLong(tCWP.hwnd, GWL_WNDPROC, AddressOf SubMsgBox)
            End If
    End Select
    HookWindow = CallNextHookEx(lHook, nCode, wParam, ByVal lParam)
End Function
 
Public Function MsgBoxEx(Prompt, Optional X = -1, Optional Y = -1, _
                         Optional StartupPosition As StartupPos = CenterScreen, _
                         Optional Buttons As VbMsgBoxStyle = vbOKOnly, _
                         Optional Title, Optional HelpFile, Optional Context) _
                         As VbMsgBoxResult
    MSGBOXEX_X = X
    MSGBOXEX_Y = Y
    MSGBOXEX_STARTUP = StartupPosition
    'set a Thread Message Hook..
    lHook = SetWindowsHookEx(WH_CALLWNDPROC, AddressOf HookWindow, _
                             App.hInstance, App.ThreadID)
    MsgBoxEx = MsgBox(Prompt, Buttons, Title, HelpFile, Context)
    'Remove the Hook
    Call UnhookWindowsHookEx(lHook)
End Function
'--- akhir coding di Module ---

0 komentar:

Posting Komentar

 

© 2011 e - Tutorial | by Moeh Fitrah