Membuat Custom Message Box dengan Visual Basic oleh Muhammad Iqbal

Membuat Custom Message Box dengan Visual Basic oleh Muhammad Iqbal

  8/07/2009 12:21:00 AM    DIBACA ORG

---

Berikut ini adalah email dari sdr. Muhammad Iqbal (lab.qballz [at] gmail.com) kepada saya tentang cara membuat sebuah Custom Message Box, saya posting kesini "as is" nya, silah dicuba:

Assalamu'alaikum


"Bismillaahirrohmaanirrohiim"

Mau membuat Message Box Sendiri?


Ni code & triknya

1. Buat Project baru ActiveX DLL


Copy aja code ini.

Option Explicit

Public Function MsgBox4Button(strTitle As String, strcmd1 As String, _


Optional strcmd2 As String = " ", Optional strcmd3 As String = " ", _


Optional strcmd4 As String = " ") As String


With frmMsgBox4Button


.Caption = strTitle


.CMD1.Caption = strcmd1


.CMD2.Caption = strcmd2


.CMD3.Caption = strcmd3


.CMD4.Caption = strcmd4


If Trim(.CMD1.Caption) = "CMD1" Then .CMD2.Visible = False


If Trim(.CMD2.Caption) = "CMD2" Then .CMD2.Visible = False


If Trim(.CMD3.Caption) = "CMD3" Then .CMD3.Visible = False


If Trim(.CMD4.Caption) = "CMD4" Then .CMD4.Visible = False

End With


frmMsgBox4Button.Show 1


MsgBox4Button = frmMsgBox4Button.Response


Unload frmMsgBox4Button


End Function

: CMD1, 2, 3, 4 adl Button yang akan tampil nanti berjumlah 4, coba cutom sendiri yang saya coba baru 4 CMD, maklum Ngunduh-nya juga segitu (4 Button).

2. Add/Tambahkan 1 Form


Form ini akan tampil sebagai Message Box kita.


Copy juga code ini

Option Explicit


Public Response As String


Const LWA_BOTH = 3


Const LWA_ALPHA = 2


Const LWA_COLORKEY = 1


Const GWL_EXSTYLE = -20


Const WS_EX_LAYERED = &H80000


Private Declare Function GetWindowLong Lib "user32" Alias _


"GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex 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 SetLayeredWindowAttributes Lib "user32" _


(ByVal hwnd As Long, ByVal color As Long, ByVal X As Byte, _


ByVal alpha As Long) As Boolean


Dim TransparanDonk As Integer

Private Sub Timer1_Timer()


On Error Resume Next


TransparanDonk = TransparanDonk + 5


If TransparanDonk < 255 Then TransparanDonk = 255: Timer1.Enabled = False ': End ( END disini utk menutup applikasi/form ini)


TransparanBro Me.hwnd, TransparanDonk


Me.Show


End Sub


Sub TransparanBro(hWndBro As Long, TransBro As Integer)


On Error Resume Next


Dim OKBro As Long


OKBro = GetWindowLong(hWndBro, GWL_EXSTYLE)


SetWindowLong hWndBro, GWL_EXSTYLE, OKBro Or WS_EX_LAYERED


SetLayeredWindowAttributes hWndBro, RGB(255, 255, 255), TransBro, LWA_ALPHA


Exit Sub


End Sub

Private Sub CMD1_Click()


Response = CMD1.Caption 'CMD1 adl Nama CommandButton


Me.Hide


End Sub


Private Sub CMD2_Click()


Response = CMD2.Caption 'CMD2 adl Nama CommandButton


Me.Hide


End Sub


Private Sub CMD3_Click() 'CMD3 adl Nama CommandButton


Response = CMD3.Caption


Me.Hide


End Sub


Private Sub CMD4_Click() 'CMD4 adl Nama CommandButton


Response = CMD4.Caption


Me.Hide


End Sub

3. Compile Project-nya.


4. Add New StanadrEXE project atawa buat baru aja tp project ActiveX DLL -nya simpen dulu.


5. Nah di project baru itu Copy juga code ini, Ingat! Code ini juga saya Unduh, bukan hasil saya sendiri tapi saya lupa sumbernya siapa, so kalo yang mau prtotes code-nya dipakai Saya Mohon Ma'af.

'Option Explicit


Private Sub Command1_Click()


Dim objMsgBox, MyMsgBox


Set objMsgBox = CreateObject("PROoneDLL.CSOne")


MyMsgBox = objMsgBox.MsgBox4Button(" Pilih pilihan anda ! ", "Tambah Data", "Edit Data", "Preview", "Keluar")


'MsgBox MyMsgBox 'Ini akan menjadikan sebuah MsgBox Baru setelah _


MyMsgBox = objMsgBox.MsgBox4Button tersebut di CLOSE _


untuk saya coba tidak diaktivkan

If MyMsgBox = "Tambah Data" Then


Text1.Text = "Reaksi Tambah Data"


ElseIf MyMsgBox = "Edit Data" Then


Text1.Text = "Reaksi Edit Data" 'Text1 adl error/reaksi saat di-RUN yang pertama saya coba


ElseIf MyMsgBox = "Preview" Then


Text1.Text = "Reaksi Preview"


ElseIf MyMsgBox = "Keluar" Then


Text1.Text = "Reaksi Keluar"


End If


'End If


Set objMsgBox = Nothing


End Sub

Ini bukan note ya :


"Tambah Data", "Edit Data", "Preview", "Keluar" : adl NAMA button yang akan ditampilkan yang biasanya YES NO CANCEL-ntu,


end coba diganti dengan kata yang lain cutom sendiri aja.


Oh iya jangan lupa hasil compile ActiveX DLL tadi di tambahkan/dipanggil di ProjectPreference.


"Insya Alloh" berhasil Amiiiiin


Dan bermanfa'at sekaligus menjadi Amal buat saya

Wassalam.


Muh. Iqbal


Cilegon-People