MsgBox omilla vaihtoehdoilla?

tommosen kopsasin joskus netistä
KOPIOI moduuliin jutut
muuttele otsikot ,ikonit ja nappien tekstit seuraavissa koodinpätkissä...
toinen vaihtoehto on tehdä oma lomake ja siihen kuvat ja tekstit, se jopa onnistuu tavalliselta käyttäjältäkin aika helposti.

Sub Test_Custom_MsgBoxI()
Sub Test_Custom_MsgBoxII()
Sub Test_Custom_MsgBoxIII()
Sub Test_Custom_MsgBoxIV()


Option Explicit
Dim y As Double
'//
'// Version 2.0
'// Taken from Original Q
'// http://216.92.17.166/board2/viewtopic.php?t=49224&highlight=xl97
'//
'// Amended for Use with Xl2000+
'// By Ivan F Moala
'// http://www.xcelfiles.com
'//
'// All code below you need in a Seperate Module
'// Note: This is a good example for making it into
'// a Class Module....so why haven't I ? because Class modules
'// do not support the Addressof Operator!
'//

Private Declare Function GetCurrentThreadId _
Lib "kernel32" () _
As Long

Private Declare Function GetDesktopWindow _
Lib "user32" () _
As Long

Private Declare Function GetWindowLong _
Lib "user32" _
Alias "GetWindowLongA" ( _
ByVal hwnd As Long, _
ByVal nIndex As Long) _
As Long

Private Declare Function MessageBox _
Lib "user32" _
Alias "MessageBoxA" ( _
ByVal hwnd As Long, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal wType As Long) _
As Long

Private Declare Function SetDlgItemText _
Lib "user32" _
Alias "SetDlgItemTextA" ( _
ByVal hDlg As Long, _
ByVal nIDDlgItem As Long, _
ByVal lpString As String) _
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 SetWindowText _
Lib "user32" _
Alias "SetWindowTextA" ( _
ByVal hwnd As Long, _
ByVal lpString As String) _
As Long

Private Declare Function UnhookWindowsHookEx _
Lib "user32" ( _
ByVal hHook As Long) _
As Long

'//
Private Const MB_YESNOCANCEL = &H3&
Private Const MB_YESNO = &H4&
Private Const MB_RETRYCANCEL = &H5&
Private Const MB_OKCANCEL = &H1&
Private Const MB_OK = &H0&
Private Const MB_ABORTRETRYIGNORE = &H2&

'// Default MsgBox button
Private Const MB_DEFBUTTON1 = &H0&
Private Const MB_DEFBUTTON2 = &H100&
Private Const MB_DEFBUTTON3 = &H200&

'// Enumerated icons in the message box
Public Enum eIcon
MB_ICONHAND = &H10&
MB_ICONASTERISK = &H40&
MB_ICONERROR = MB_ICONHAND
MB_ICONEXCLAMATION = &H30&
MB_ICONINFORMATION = MB_ICONASTERISK
MB_ICONMASK = &HF0&
MB_ICONSTOP = MB_ICONHAND
MB_ICONWARNING = MB_ICONEXCLAMATION
End Enum

Private Const IDERROR = 0
Private Const IDOK = 1
Private Const IDCANCEL = 2
Private Const IDABORT = 3
Private Const IDRETRY = 4
Private Const IDIGNORE = 5
Private Const IDYES = 6
Private Const IDNO = 7
Private Const IDPROMPT = &HFFFF& '65535

Private Const WH_CBT = 5
Private Const GWL_HINSTANCE = (-6)
Private Const HCBT_ACTIVATE = 5

Private Type MSGBOX_HOOK_PARAMS
hwndOwner As Long
hHook As Long
End Type

Private MSGHOOK As MSGBOX_HOOK_PARAMS

'// Global for Custom MsgBox string
'Public gstrMsg As String

'// Module level
Dim mstrPrompt As String
Dim mstrTitle As String
Dim mVbFlags As VbMsgBoxStyle 'Long
Dim mVbFlags2 As VbMsgBoxStyle 'long
Dim mstrButton1 As String
Dim mstrButton2 As String
Dim mstrButton3 As String
Dim mhwnd As Long
''
Dim mBufferTxt As String
Dim mBufferCap As String

Private Function MessageBoxH( _
hwndThreadOwner As Long, _
hwndOwner As Long, _
mbFlags As Long) As Long

'// This function calls the hook
Dim hInstance As Long
Dim hThreadId As Long

hInstance = GetWindowLong(hwndThreadOwner, GWL_HINSTANCE)
hThreadId = GetCurrentThreadId()

With MSGHOOK
.hwndOwner = hwndOwner
.hHook = SetWindowsHookEx(WH_CBT, AddressOf MsgBoxHookProc, hInstance, hThreadId)
End With
hwndOwner = 0
'ChangeMsgBoxFont hwndOwner, False
'// Make sure we create enough space for the gstrMsg eg Vbcrlf
'// The maximum length of prompt is approximately 1024 characters,
'// depending on the width of the characters used
MessageBoxH = MessageBox(hwndOwner, Space$(1024), Space$(1024), mbFlags)
'// For a smaller Msgbox height decrease the Space
'MessageBoxH = MessageBox(hwndOwner, mBufferTxt, mBufferCap, mVbFlags)
'// BUT you may NOT fit the Text
'ChangeMsgBoxFont hwndOwner, True

End Function

Private Function MsgBoxHookProc(ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long

'// This function catches the messagebox before it opens
'// and changes the text of the buttons - then removes the hook

If uMsg = HCBT_ACTIVATE Then

SetWindowText wParam, mstrTitle
SetDlgItemText wParam, IDPROMPT, mstrPrompt

Select Case mVbFlags
Case vbAbortRetryIgnore
SetDlgItemText wParam, IDABORT, mstrButton1
SetDlgItemText wParam, IDRETRY, mstrButton2
SetDlgItemText wParam, IDIGNORE, mstrButton3
Case vbYesNoCancel
SetDlgItemText wParam, IDYES, mstrButton1
SetDlgItemText wParam, IDNO, mstrButton2
SetDlgItemText wParam, IDCANCEL, mstrButton3
Case vbOKOnly
SetDlgItemText wParam, IDOK, mstrButton1
Case vbRetryCancel
SetDlgItemText wParam, IDRETRY, mstrButton1
SetDlgItemText wParam, IDCANCEL, mstrButton2
Case vbYesNo
SetDlgItemText wParam, IDYES, mstrButton1
SetDlgItemText wParam, IDNO, mstrButton2
Case vbOKCancel
SetDlgItemText wParam, IDOK, mstrButton1
SetDlgItemText wParam, IDCANCEL, mstrButton2
End Select
'// MUST UnHook here!
UnhookWindowsHookEx MSGHOOK.hHook
End If

MsgBoxHookProc = False

End Function

''' MsgBox(prompt[, buttons] [, title] [, helpfile, context])
'// MsgboxC C for Custom > so intuitively typing in MsgBox THEN add C for Custom
'// gives you this Function.
Public Function MsgBoxC( _
Prompt As String, _
iMsgbox As VbMsgBoxStyle, _
Title As String, _
Optional MsgIcon As eIcon = eIcon.MB_ICONHAND, _
Optional Btn1Txt As String = "Button1", _
Optional Btn2Txt As String = "Button2", _
Optional Btn3Txt As String = "Button3") _
As String

'// This function sets your custom parameters and returns
'// which button was pressed
Dim lReturn As Long

mVbFlags = iMsgbox
mVbFlags2 = MsgIcon
mstrTitle = Title
mstrPrompt = Prompt
mstrButton1 = Btn1Txt
mstrButton2 = Btn2Txt
mstrButton3 = Btn3Txt

mBufferTxt = Space$(Len(Prompt))
mBufferCap = Space$(Len(Title))

lReturn = MessageBoxH(mhwnd, GetDesktopWindow(), mVbFlags Or mVbFlags2)

'// Note: The Button numbers! They are in Normal Button order
Select Case lReturn
Case IDABORT
MsgBoxC = mstrButton1
Case IDRETRY
MsgBoxC = mstrButton2
Case IDIGNORE
MsgBoxC = mstrButton3
Case IDYES
MsgBoxC = mstrButton1
Case IDNO
MsgBoxC = mstrButton2
Case IDCANCEL
MsgBoxC = mstrButton3
Case IDOK
MsgBoxC = mstrButton1
Case IDERROR
MsgBoxC = "NOT ENOUGH MEMORY!"
End Select

End Function

Public Sub MsgBoxError()
'// handle Error
MsgBox "There is not enough memory to create the message box.", _
vbCritical, _
"MessageBox Call"
End
End Sub
'///////////////////////////////////////
'/ Custom routines start here /
'/ Make sure Intellisence is turned ON /
'///////////////////////////////////////

Sub Test_Custom_MsgBoxI()
Dim strReturn As String
Dim strMsg As String

'// Define your Msg Prompt FIRST HERE!
strMsg = "How long was your lunch break?"
strMsg = strMsg & vbLf & "No Break = No lunch break taken"
strMsg = strMsg & vbLf & "1/2 hr = Only 1/2 hour was taken"
strMsg = strMsg & vbLf & "Don't Know = Too long a break!"

'// Call the Custom MsgBox [MsgBoxC]
strReturn = MsgBoxC(strMsg, vbYesNoCancel + vbDefaultButton1, "Testing 1 2 3", eIcon.MB_ICONWARNING, "No Break", "1/2 hr", "Don't Know")
If strReturn = "NOT ENOUGH MEMORY!" Then MsgBoxError

'// Which Button was pressed
Select Case strReturn
Case Is = "No Break"
'// Do your thing for Button1
y = 0
Case Is = "1/2 hr"
'// Do your thing for Button2
y = 0.5
Case Is = "Don't Know"
'// Do your thing for Button3
y = 1
End Select

'// Show the Result
MsgBox "Button:= " & strReturn & vbCr & "Lunch break:= " & y & " hr TOO LONG!"

End Sub

Sub Test_Custom_MsgBoxII()
Dim strReturn As String
Dim strMsg As String

'// Define your Msg Prompt FIRST HERE!
'' Or just type it in
'// Call the Custom MsgBox [MsgBoxC]
strReturn = MsgBoxC("Which test did you Pass?", vbYesNo, "Testing Papers", MB_ICONSTOP, "Test1", "Test2")
If strReturn = "NOT ENOUGH MEMORY!" Then MsgBoxError

'// Which Button was pressed
Select Case strReturn
Case Is = "Test1"
'// Do your thing for Button1
y = 0
Case Is = "Test2"
'// Do your thing for Button2
y = 0.5
End Select

'// Show the Result
MsgBox "Button:= " & strReturn & vbCrLf & vbCrLf & "So you passed " & strReturn

End Sub

Sub Test_Custom_MsgBoxIII()
Dim strReturn As String
Dim strMsg As String

'// Define your Msg Prompt FIRST HERE!
strMsg = "What gender are you?"
strMsg = strMsg & Chr(13) & "Male"
strMsg = strMsg & Chr(13) & "Female"
strMsg = strMsg & Chr(13) & "Other"

'// Call the Custom MsgBox [MsgBoxC]
strReturn = MsgBoxC(strMsg, vbYesNoCancel, "Testing 1 2 3", MB_ICONWARNING, "Male", "Female", "Other")
If strReturn = "NOT ENOUGH MEMORY!" Then MsgBoxError

'// Which Button was pressed
Select Case strReturn
Case Is = "Male"
'// Do your thing for Button1
y = 0
Case Is = "Female"
'// Do your thing for Button2
y = 1
Case Is = "Other"
'// Do your thing for Button3
y = 2
End Select

'// Show the Result
MsgBox "Button:= " & strReturn & vbCr & "You are a " & strReturn

End Sub

Sub Test_Custom_MsgBoxIV()
Dim strReturn As String
Dim strMsg As String

'// Define your Msg Prompt FIRST HERE!
strMsg = "Please choose your pay %tage increase"
strMsg = strMsg & Chr(13) & "0% = No INCREASE"
strMsg = strMsg & Chr(13) & "10%"
strMsg = strMsg & Chr(13) & "20%"

'// Call the Custom MsgBox [MsgBoxC]
strReturn = MsgBoxC(strMsg, vbAbortRetryIgnore, "Testing 1 2 3", MB_ICONSTOP, "0%", "10%", "20%")
If strReturn = "NOT ENOUGH MEMORY!" Then MsgBoxError

'// Which Button was pressed
Select Case strReturn
Case Is = "Test1"
'// Do your thing for Button1
y = 0
Case Is = "Test2"
'// Do your thing for Button2
y = 0.5
Case Is = "Test3"
'// Do your thing for Button3
y = 1
End Select

'// Show the Result
MsgBox "Button:= " & strReturn & vbCr & " Sorry NO CAN DO!!"

End Sub

itse teen nuo aina input boxeilla eli kutakuinkin näin:

Sub valinta()

Dim intValitse As Integer

intValitse = InputBox("valitse oikea vaihtoehto" & vbCrLf & vbCrLf & "1. oletko koira?" & vbCrLf & "2. Oletko kissa?" & vbCrLf & "3. vai kenties norsu?", "Eläimen valitsin", "syötä haluamasi eläimen numero tähän")

' ja sitten vaan ehdot perään

If intValitse = 1 Then ' tee jotain
End If
If intValitse = 2 Then ' tee jotain muuta
End If
If intValitse = 3 Then ' tee mitä tykkäät'
End If

End Sub


mutta tietenkin jos haluat sen msgboxisi niin kannattaa tuota kunden ekaa käyttää