FreeBasic
Главная
Вход
Регистрация
Вторник, 23.04.2024, 20:24Приветствую Вас Гость | RSS
[ Новые сообщения · Участники · Правила форума · Поиск · RSS ]
  • Страница 1 из 1
  • 1
Форум » Freebasic » Исходники » MessageBox со своей иконкой (MessageBox со своей иконкой)
MessageBox со своей иконкой
haavДата: Среда, 03.10.2012, 07:29 | Сообщение # 1
Генералиссимус
Группа: Администраторы
Сообщений: 1361
Репутация: 49
Статус: Offline
MessageBox со своей иконкой


Иконку можно подставить любую с именем "22.ico" или поменяте имя в файле ресурсов.

MSBINDIRECT.rc

Code
1000 ICON DISCARDABLE "22.ico"


MSBINDIRECT.bas

Code
#Include "windows.bi"
Sub MsgBox(Caption As string, Message As String)
     Dim mb As MSGBOXPARAMS
     mb.hInstance = Getmodulehandle(0)
     mB.cbSize = SizeOf(MSGBOXPARAMS)
     mb.lpszText = StrPtr(Message)
     mb.lpszCaption = StrPtr(Caption)
     mb.dwStyle = MB_OK or MB_USERICON
     mb.lpszIcon = MAKEINTRESOURCE(1000)       
     MessageBoxIndirect(@mb)
End Sub
    
MsgBox("message","new message")


Вы сохраняете власть над людьми покуда оставляете им что-то…Отберите у человека все, и этот человек уже будет неподвластен вам…
 
vizitДата: Среда, 06.02.2019, 12:49 | Сообщение # 2
Рядовой
Группа: Пользователи
Сообщений: 11
Репутация: 0
Статус: Offline

Код
'#include once "windows.bi"
#include once "win/olectl.bi"

Dim Memdll As  Any Ptr
Dim func As Function(As Integer, As String, As String, As Integer) As Integer
Dim Resultat as integer
Dim MesText as string ="Добрый день"
Dim Zagolovok as String ="Приветствие"
Memdll=DylibLoad("C:\Windows\System32\user32.dll")
If Memdll=0 Then End
func=DylibSymbol(Memdll, "MessageBoxA")
If func=0 Then End
Resultat=func(Null, MesText, Zagolovok, MB_YESNO + MB_ICONERROR + MB_DEFBUTTON2)
? Resultat
Sleep
Dylibfree Memdll


Почему вместо текста сообщения и заголовка MessageBox появлются символ и цифра 83?
 
WQДата: Среда, 06.02.2019, 13:15 | Сообщение # 3
Полковник
Группа: Проверенные
Сообщений: 215
Репутация: 7
Статус: Offline
vizit

Неправильно декларирована функция, надо примерно так


Код
Dim func As Function(As Integer, As ZString ptr, As ZString ptr, As Integer) As Integer


Сообщение отредактировал WQ - Среда, 06.02.2019, 13:16
 
vizitДата: Среда, 06.02.2019, 13:52 | Сообщение # 4
Рядовой
Группа: Пользователи
Сообщений: 11
Репутация: 0
Статус: Offline
Спасибо.

Брал из урока Создание статических и динамических библиотек. Там на этот счёт нет пояснений.
 
SomerickДата: Суббота, 09.02.2019, 03:14 | Сообщение # 5
Рядовой
Группа: Пользователи
Сообщений: 14
Репутация: 2
Статус: Offline
Смотрите, а у меня есть вот такой мессаджбокс, хоть с иконкой из ресурсов, хоть с любым хендлом.
А также можно с таймером закрытия, и с закрытием по клику вне формы
и ещё, и ещё...
И к тому же совместимость с аргументами стандартного WINAPI MessageBoxW.
И ещё плюс, можно произвольно менять текст на кнопках. (По дефолту английские OK, Cancel,.. etc)

Плюс другие опции можно сделать самостоятельно, изменив код как пожелаете.

Прототип
Function MsEx(hwin As HWND,s As wString Ptr,Caption As wString Ptr,iType As Long)As Long

Аргументы
hwin - окно-родитель
s - текст (пользуюсь юникодом, всё равно надо выводить разную информацию, например в путях файлов могут оказаться символы, да мало ли где встретятся, так что нелишне предусмотреть. Сами файлы, код в посте следует сохранить наоборот, НЕ в юникоде, т.к. там есть WStr("Text"))
Caption - заглавие
iType - набор флагов как в стандартном боксе, плюс возможно добавить (Or) MsEx* флаги

MsExNOMOUSETOOKBTN Запрет ставить курсор на кнопке по умолчанию
MsExCLOSEONDEACTION Закрытие мессаджбокса при клике вне формы и потере фокуса
MsExCHECK Включить чекбокс
MsExCHECKED Отметка в чекбоксе, если включен MsExCHECK
MsExTIMER(t) Включить закрытие по таймеру(t: 1 - 255, секунд)
Если таймер запущен, его можно остановить кликом на текст мессаджбокса. Кстати текст можно выделять и копировать.
MsExRESICON(i) Включить иконку из ресурсов(i:  1 - 255)
MsExICON Включить иконку из MsExIcoAndBtnNames.Ico (менее приоритетный флаг)

Возвращаемое значение, младшая часть: x=(retVal And &hf)
0 - 7 :совпадает с стандартными значениями, например 1 ОК, 6 Yes
8: таймаут, если был включен MsExTIMER
Дополнительно, возвращает retVal And MsExCHECKED, если был включен MsExCHECK и имеется отметка в чекбоксе

File: MsEx.bas

Код
'MsEx - Custom Messagebox with standard and extended features
'icon from res,icon from hicon,checkbox,button names,close on timer,close on killfocus
'zwide and lib autor Somerick Ankantare

#Include Once "windows.bi"
Extern "Windows"

'# определения, относящиеся к вызову MsEx
#Define MsExNOMOUSETOOKBTN &h8000
#Define MsExCLOSEONDEACTION &h4000
#Define MsExCHECK &h2000
#Define MsExCHECKED &h800
#Define MsExTIMER(t) (t Shl 24)
#Define MsExRESICON(i) (i Shl 16)
#Define MsExICON 112

Type MsExIcoAndBtnNamesType
    As HICON Ico
    As WString Ptr BtnOK,BtnCancel,BtnAbort,BtnRetry,BtnIgnore,BtnYes,BtnNo,Check,TimerClose
End Type

'в MsExIcoAndBtnNames можно свободно задавать свои один или несколько параметров(иконка, названия кнопок) в ходе выполнения программы
Common Shared As MsExIcoAndBtnNamesType MsExIcoAndBtnNames

'# нижеследуют внутренние определения

'Declare Function uLen(s As WString Ptr)As Integer'My functions in zwlib runtime, for example replaced to alternative Rnd and lstrlenW.
'Declare Function zRndMax(As Integer)As Integer
#Define uLen lstrlenW
#Define zRndMax(x) x*Rnd
' в принципе эту небольшую рандомизацию положения окна вообще можно отключить, объявив #Define zRndMax(x) 40
#Define SMW SendMessageW
#Define GetProcent(i100,proc) (i100*proc/100)
#Define iCast(a) Cast(Integer,a)

'Диалог из шаблона, но контролы создаются CreateWindowEx, удобнее рассчёт размеров и проч.
Type MsExTmpDlg Field=1
    As DWORD Style,ExStyle
    As WORD CntControls,x,y,w,h
    As WORD menuEnable
    As WORD classEnable
    As WString*2 Caption
End Type

Type MsExFunctionType
    As HWND hwin
    As Any Ptr s,Caption
    As Integer iType
End Type

Private Function MsExFunctionProc(hWin As HWND,uMsg As UINT,wParam As WPARAM,lParam As LPARAM)As Integer
Static As HICON ico(3),CasheResIco
Static As HWND hChk,hTimer
Static As Integer IcoWdt,xScr,yScr,CloseOnDeActivate,CasheResIcoID,iTimer,RetVal,MsExCHECKEnable
Static As HFONT f
Static As HMODULE hInstance
Dim As wString*255 s1=Any

Select Case uMsg
Case WM_INITDIALOG
If f=0 Then
    f=GetStockObject(DEFAULT_GUI_FONT)
    xScr=GetSystemMetrics(0):yScr=GetSystemMetrics(1)
    IcoWdt=GetSystemMetrics(SM_CXICON)
    'Установка текста кнопок по умолчанию, если до первого вызова =0 (если не установлены в программе)
    If MsExIcoAndBtnNames.BtnOK=0 Then MsExIcoAndBtnNames.BtnOK=@WStr("OK")
    If MsExIcoAndBtnNames.BtnCancel=0 Then MsExIcoAndBtnNames.BtnCancel=@WStr("Cancel")
    If MsExIcoAndBtnNames.BtnAbort=0 Then MsExIcoAndBtnNames.BtnAbort=@WStr("Abort")
    If MsExIcoAndBtnNames.BtnRetry=0 Then MsExIcoAndBtnNames.BtnRetry=@WStr("Retry")
    If MsExIcoAndBtnNames.BtnIgnore=0 Then MsExIcoAndBtnNames.BtnIgnore=@WStr("Ignore")
    If MsExIcoAndBtnNames.BtnYes=0 Then MsExIcoAndBtnNames.BtnYes=@WStr("Yes")
    If MsExIcoAndBtnNames.BtnNo=0 Then MsExIcoAndBtnNames.BtnNo=@WStr("No")
    If MsExIcoAndBtnNames.Check=0 Then MsExIcoAndBtnNames.Check=@WStr("Do not show next time")
    If MsExIcoAndBtnNames.TimerClose=0 Then MsExIcoAndBtnNames.TimerClose=@WStr("Close:")
EndIf

Dim As WString Ptr s=Cast(MsExFunctionType Ptr,lparam)->s,Caption=Cast(MsExFunctionType Ptr,lparam)->Caption
Dim As Integer iType=Cast(MsExFunctionType Ptr,lparam)->iType
Dim As HWND hw=hwin,hwinp=Cast(MsExFunctionType Ptr,lparam)->hwin
If Caption=0 Then Caption=@WStr("")
If s=0 Then s=@WStr("")
SMW hWin,WM_SETTEXT,0,iCast(Caption)

CloseOnDeActivate=iType And MsExCLOSEONDEACTION
RetVal=0
MsExCHECKEnable=iType And MsExCHECK
iTimer=iType And &hff000000

Dim As HICON i=Any
Dim As Integer IcoWdtAdd=0,a=Any,x=Any,y=Any,_
BtnId(2)=Any,BtnCnt=Any,BtnCnt1=Any,BtnSel=0,BtnLeft=Any,BtnTop=Any,BtnTopCheck=Any,BtnWdt=Any,BtnHdt=Any,BtnAllWdt=Any,_
CheckWdt=Any,CheckHdt=Any,TimerWdt=Any,_
WndWdt=Any,WndHdt=Any,OldX=0,xLn=Any,TmpX=Any,TmpY=Any
Dim As wString Ptr BtnCap(2)=Any,wp=Any
Dim As zString Ptr p=Any,p1=Any
Dim As HWND BtnHWND(2)=Any
Dim As MSG msg=Any
Dim As RECT r=Any,r0=Any,rCaption=Any,rS=Any,WndRect=Any,ClientRect=Any

GetWindowRect hw,@WndRect:WndRect.right-=WndRect.left:WndRect.bottom-=WndRect.top
GetClientRect hw,@ClientRect
Var AddHdt=WndRect.bottom-ClientRect.bottom,AddWdt=WndRect.right-ClientRect.right

'определение иконки и её загрузка при необходимости
If iType And &hff0000 Then
    Var ResIcon=(iType And &hff0000)Shr 16
    If(CasheResIcoID<>ResIcon)Or(CasheResIco=0)Then
        If CasheResIco Then DestroyIcon CasheResIco
        If hInstance=0 Then hInstance=GetModuleHandle(0)
        CasheResIcoID=ResIcon:CasheResIco=LoadIcon(hInstance,Cast(LPCSTR,CasheResIcoID))
     EndIf
    i=CasheResIco
    IcoWdtAdd=IcoWdt+10
Else'Std Icon
Dim As LPCSTR xi=Any
Select Case iType And 112
    Case 16
        xi=IDI_HAND:y=0
        iSet:i=ico(y):If i=0 Then i=LoadIcon(0,xi):ico(y)=i
        IcoWdtAdd=IcoWdt+10
    Case 32:xi=IDI_QUESTION:y=1:GoTo iSet
    Case 48:xi=IDI_EXCLAMATION:y=2:GoTo iSet
    Case 112:i=MsExIcoAndBtnNames.Ico
        If i=0 Then GoTo iSetStd
        IcoWdtAdd=IcoWdt+10
    Case Is<>0
        iSetStd:xi=IDI_ASTERISK:y=3:GoTo iSet
End Select
EndIf

'установка рабочего набора кнопок
Select Case iType And 7
    Case 0,Is>5:BtnCnt=1:BtnCap(0)=MsExIcoAndBtnNames.BtnOK:BtnId(0)=1
    Case 1:BtnCnt=2:BtnCap(0)=MsExIcoAndBtnNames.BtnOK:BtnId(0)=1
    BtnCap(1)=MsExIcoAndBtnNames.BtnCancel:BtnId(1)=2

    Case 2:BtnCnt=3:BtnCap(0)=MsExIcoAndBtnNames.BtnAbort:BtnId(0)=3
    BtnCap(1)=MsExIcoAndBtnNames.BtnRetry:BtnId(1)=4
    BtnCap(2)=MsExIcoAndBtnNames.BtnIgnore:BtnId(2)=5

    Case 3:BtnCnt=3:BtnCap(0)=MsExIcoAndBtnNames.BtnYes:BtnId(0)=6
    BtnCap(1)=MsExIcoAndBtnNames.BtnNo:BtnId(1)=7
    BtnCap(2)=MsExIcoAndBtnNames.BtnCancel:BtnId(2)=2

    Case 4:BtnCnt=2:BtnCap(0)=MsExIcoAndBtnNames.BtnYes:BtnId(0)=6
    BtnCap(1)=MsExIcoAndBtnNames.BtnNo:BtnId(1)=7
    
    Case 5:BtnCnt=2:BtnCap(0)=MsExIcoAndBtnNames.BtnRetry:BtnId(0)=4
    BtnCap(1)=MsExIcoAndBtnNames.BtnCancel:BtnId(1)=2
End Select
Select Case iType And 768
    Case 256:BtnSel=1
    Case 516:BtnSel=2
End Select
BtnCnt1=BtnCnt-1
If BtnSel>BtnCnt1 Then BtnSel=BtnCnt1

'Рассчёт размера текста
Var hdc=GetDC(hw)
Var Oldf=SelectObject(hdc,f)
BtnHdt=22:BtnWdt=54
For x=0 To BtnCnt1
    wp=BtnCap(x)
    If wp Then
        GetTextExtentPoint32W hdc,wp,uLen(wp),Cast(LPSIZE,@r.right)
        TmpY=GetProcent(r.bottom,190):TmpX=r.right+r.bottom
        If TmpY>BtnHdt Then BtnHdt=TmpY
        If TmpX>BtnWdt Then BtnWdt=TmpX
    EndIf
Next

BtnAllWdt=BtnCnt*BtnWdt
If iTimer Then
    GetTextExtentPoint32W hdc,MsExIcoAndBtnNames.TimerClose,uLen(MsExIcoAndBtnNames.TimerClose),Cast(LPSIZE,@r0.right)
    GetTextExtentPoint32W hdc,@WStr(" 10s"),4,Cast(LPSIZE,@r.right)
    TimerWdt=(r.right+r0.right+18)
    BtnAllWdt+=TimerWdt
EndIf

CheckHdt=0:CheckWdt=0
If MsExCHECKEnable Then
    CheckHdt=22
    If MsExIcoAndBtnNames.Check Then
        GetTextExtentPoint32W hdc,MsExIcoAndBtnNames.Check,uLen(MsExIcoAndBtnNames.Check),Cast(LPSIZE,@r0.right)
        CheckWdt=r0.right+r0.bottom+40
        CheckHdt=GetProcent(r0.bottom,160)
    EndIf
EndIf

GetTextExtentPoint32W hdc,Caption,uLen(Caption),Cast(LPSIZE,@rCaption.right)
rCaption.right+=65

p=Cast(ZString Ptr,s)
GetTextExtentPoint32W hdc,@WStr("0"),1,Cast(LPSIZE,@r0.right)

rS.right=0:rS.bottom=0
x=0:OldX=0
Do
    y=peek(word,p+x+x)
    Select Case y
        Case 0,10
        SetYy:
        xLn=x-OldX
        GetTextExtentPoint32W hdc,Cast(WString Ptr,p+OldX+OldX),xLn,Cast(LPSIZE,@r.right)
        If r.right>rS.right Then rS.right=r.right
        rS.bottom+=(IIf(r.bottom<r0.bottom,r0.bottom,r.bottom)+4)
        If y=0 Then Exit Do
        OldX=x+1
        Case 13:y=Peek(word,p+x+x+2):If y=10 Then x+=1
        GoTo SetYy
    End Select
    If x>5000 Then y=0:GoTo SetYy
    x+=1
Loop
rS.right+=24:rS.bottom+=8

SelectObject hdc,Oldf
ReleaseDC hw,hdc

'рассчёт размеров окна
WndHdt=max(IcoWdtAdd,rS.bottom)+BtnHdt+CheckHdt+AddHdt

WndWdt=max(IcoWdtAdd+rS.right,BtnAllWdt+20)
If WndWdt<rCaption.right Then WndWdt=rCaption.right
If WndWdt<CheckWdt Then WndWdt=CheckWdt

WndWdt+=AddWdt

MoveWindow hw,(xScr Shr 1)-(WndWdt Shr 1)-40+zRndMax(80),(yScr Shr 1)-(WndHdt Shr 1)-40+zRndMax(80),WndWdt,WndHdt+6,1
GetClientRect hw,@ClientRect
'проверка клиентского размера, вдруг окно меньше заданного(например если слишком много текста)

'финальный рассчёт размеров контролов и создание их
BtnTop=ClientRect.bottom-BtnHdt-6
BtnTopCheck=BtnTop
If MsExCHECKEnable Then BtnTopCheck-=CheckHdt

If IcoWdtAdd Then
    y=(BtnTopCheck Shr 1)-(IcoWdt Shr 1):If y<0 Then y=0
    SMW CreateWindowExW(0,"Static",0,&h50000843,8,y,IcoWdt,IcoWdt,hw,0,0,0),STM_SETICON,iCast(i),0
EndIf

Var sWnd=CreateWindowExW(0,"Edit",s,&h50000804,IcoWdtAdd+12,4,ClientRect.right-IcoWdtAdd-20,BtnTopCheck-4,hw,0,0,0)
SMW sWnd,WM_SETFONT,iCast(f),0

If iTimer Then
    y=BtnCnt*BtnWdt
    BtnLeft=(ClientRect.right Shr 1)-(y Shr 1)
    x=ClientRect.right-TimerWdt
    If x<BtnLeft+y Then BtnLeft=x-y
    iTimer=(iType Shr 24):SetTimer hWin,1,1000,0
    wsprintfW @s1,"%s %ds",MsExIcoAndBtnNames.TimerClose,iTimer
    hTimer=CreateWindowExW(0,"Static",@s1,&h50000002,x,BtnTop,TimerWdt-5,BtnHdt,hw,0,0,0)
    SMW hTimer,WM_SETFONT,iCast(f),0
Else
    BtnLeft=(ClientRect.right Shr 1)-(BtnAllWdt Shr 1)
EndIf

Var BtnIdAdd=IIf(iType And MsExNOMOUSETOOKBTN,10,0)
For a=0 To BtnCnt1
    Var hBtn=CreateWindowExW(0,"Button",Cast(WString Ptr,BtnCap(a)),IIf(BtnSel=a,&h50010001,&h50010000),BtnLeft+(a*BtnWdt),BtnTop,BtnWdt,BtnHdt,hw,Cast(HMENU,BtnId(a)+BtnIdAdd),0,0)
    SMW hBtn,WM_SETFONT,iCast(f),0
Next

If MsExCHECKEnable Then
    hChk=CreateWindowExW(0,"Button",MsExIcoAndBtnNames.Check,&h50012003,8,BtnTopCheck,ClientRect.right-8,CheckHdt,hw,Cast(HMENU,300),0,0)
    SMW hChk,WM_SETFONT,iCast(f),0
    If iType And MsExCHECKED Then SMW hChk,241,1,0
EndIf

'наконец всё готово, показываем собственно мессаджбокс
ShowWindow hw,5

Case WM_COMMAND
Select Case wParam
    Case 1 To 7:RetVal=wParam:GoTo e0
    Case 10 To 17:RetVal=wParam-10:GoTo e0
    Case EN_SETFOCUS Shl 16
        If iTimer Then KillTimer hWin,1:iTimer=0:ShowWindow hTimer,0
End Select

Case WM_TIMER
    Select Case wParam
    Case 1:iTimer-=1
        If iTimer<=0 Then KillTimer hWin,1:RetVal=8:GoTo e0
        wsprintfW @s1,"%s %ds",MsExIcoAndBtnNames.TimerClose,iTimer
        SMW hTimer,WM_SETTEXT,0,iCast(@s1)
    End Select

Case WM_CLOSE
    e0:
    If MsExCHECKEnable Then
        If SMW(hChk,240,0,0)Then RetVal Or=MsExCHECKED
    EndIf
    EndDialog hWin,RetVal

Case 134
    If CloseOnDeActivate Then
        If wParam=0 Then CloseOnDeActivate=0:GoTo e0
    EndIf
End Select
Return 0
End Function

Function MsEx(hwin As HWND,s As wString Ptr,Caption As wString Ptr,iType As Long)As Long
Static As MsExTmpDlg TmpDlg1=(13107346,9,_
0,_
0,0,176,45,_
0,0,_
WStr(""))
Dim As MsExFunctionType ibt=(hwin,s,Caption,iType)
Return DialogBoxIndirectParamW(0,Cast(LPCDLGTEMPLATE,@TmpDlg1),hwin,@MsExFunctionProc,iCast(@ibt))
End Function
End Extern


Добавлено (09.02.2019, 03:26)
---------------------------------------------
Программа - демонстрация и тест MsEx

File: MsEx_Test.bas

Код
'App Test MsEx custom MessageBox

'#Include "windows.bi" 'включен в модуле MsEx.bas(модуль из моей библиотеки,при использовании библиотек надо включать windows.bi итд)
#Include "MsEx.bas"

Dim Shared As HMODULE hInstance
Dim Shared As HICON hi'Icon 1
Dim Shared As HWND hw'Main Wnd

'main dlg proc
Function DlgProc(hWin As HWND,uMsg As UINT,wParam As WPARAM,lParam As LPARAM)As Integer
Static As HWND tCap,tStr,tName,cbBtn,cbBtnDef,cbBtnName

#Define SM SendMessageA
#Define CbAdd(h,s) SM(h,CB_ADDSTRING,0,Cast(LPARAM,s))
#Define CbGetSel(h) SM(h,CB_GETCURSEL,0,0)
#Define CbSetSel(h,i) SM h,CB_SETCURSEL,i,0
#Define GetDlgCheck IsDlgButtonChecked
Static As zString Ptr cbBtns(0 To ...)={@"OK",@"OK Cancel",@"Abort Retry Ignore",@"Yes No Cancel",@"Yes No",@"Retry Cancel"}
Static As Byte cbBtnl(0 To ...)={0,1,2,3,4,5}
Static As zString Ptr cbBtnDefs(0 To ...)={@"Default 1",@"Default 2",@"Default 3"}
Static As Short cbBtnDefl(0 To ...)={0,256,512}
Static As zString Ptr cbBtnNames(0 To ...)={@"BtnOK",@"BtnCancel",@"BtnAbort",@"BtnRetry",@"BtnIgnore",@"BtnYes",@"BtnNo",@"Check",@"Timer"}

Dim As Integer x=Any,c=Any
Dim As WString*500 s=Any,s1=Any
Dim As wString Ptr p=Any

Select Case uMsg
Case WM_INITDIALOG
hi=LoadIcon(hinstance,Cast(LPCSTR,1))
hW=hWin:SM hW,WM_SETICON,Cast(WPARAM,1),Cast(LPARAM,hi)
tCap=GetDlgItem(hW,1005):tStr=GetDlgItem(hW,1002):tName=GetDlgItem(hW,1019)
cbBtn=GetDlgItem(hW,1013):cbBtnDef=GetDlgItem(hW,1016):cbBtnName=GetDlgItem(hW,1018)

For x=0 To 5:CbAdd(cbBtn,cbBtns(x)):Next:CbSetSel(cbBtn,0)
For x=0 To 3:CbAdd(cbBtnDef,cbBtnDefs(x)):Next:CbSetSel(cbBtnDef,0)
For x=0 To 8:CbAdd(cbBtnName,cbBtnNames(x)):Next:CbSetSel(cbBtnName,0)

CheckDlgButton hw,1009,1

MsEx(hw,!"Welcome!","MsEx",16448)

Case WM_COMMAND
Dim As Integer id=LoWord(wParam),Event=HiWord(wParam)
Select Case Event
Case BN_CLICKED
    Select Case id
        Case 1001
            SetDlgItemTextW hw,1015,0
            x=0
            If GetDlgCheck(hw,1006)Then
                x=16
            ElseIf GetDlgCheck(hw,1007)Then
                x=32
            ElseIf GetDlgCheck(hw,1008)Then
                x=48
            ElseIf GetDlgCheck(hw,1009)Then
                x=64
            ElseIf GetDlgCheck(hw,1010)Then
                x=MsExRESICON(GetDlgItemInt(hw,1012,0,0))
            ElseIf GetDlgCheck(hw,1011)Then
                x=MsExICON:MsExIcoAndBtnNames.Ico=hi
            EndIf
            x=x Or cbBtnl(CbGetSel(cbBtn))Or cbBtnDefl(CbGetSel(cbBtnDef))
            If GetDlgCheck(hw,1021)Then x Or=MsExNOMOUSETOOKBTN
            If GetDlgCheck(hw,1022)Then x Or=MsExCLOSEONDEACTION
            If GetDlgCheck(hw,1023)Then x Or=MsExTIMER(GetDlgItemInt(hw,1024,0,0))
            If GetDlgCheck(hw,1025)Then x Or=MsExCHECK
            If GetDlgCheck(hw,1026)Then x Or=MsExCHECKED
            
            GetWindowTextW(tStr,@s,500):GetWindowTextW(tCap,@s1,500)
            
            
            x=MsEx(hw,@s,@s1,x)
            
            
            'Format result
            Select Case x And &hf
                Case 1 To 7
                    p=*(Cast(WString Ptr Ptr,@MsExIcoAndBtnNames.BtnOK)+((x And &hf)-1))
                Case 8
                    p=@WStr("Timeout")
                Case Else
                    p=@WStr("-")
            End Select
            wsprintfW @s,"MsEx Return: %d (%s)",x,p
            If x And MsExCHECKED Then lstrcatW @s," Check: CHECKED"
            
            SetDlgItemTextW hw,1015,@s'Show result
    End Select

Case EN_CHANGE
    Select Case id
        Case 1019
            Type sN As WString*50
            Static As sN sH(8)
            x=CbGetSel(cbBtnName)
            p=@sH(x)
            *(Cast(WString Ptr Ptr,@MsExIcoAndBtnNames.BtnOK)+x)=p
            GetWindowTextW tName,p,50
            'Это для примера изменения надписей.
            'Конечно можно проще, без Static WString, просто присвоить текст указателям так:
            'MsExIcoAndBtnNames.BtnOK=@WStr("Your Text OK")
            'MsExIcoAndBtnNames.BtnYes=@WStr("Your Text Yes")
            '... итд
    End Select

Case CBN_SELENDOK
    Select Case id
        Case 1018
            p=*(Cast(WString Ptr Ptr,(@MsExIcoAndBtnNames.BtnOK))+CbGetSel(cbBtnName))
            SetWindowTextW tName,IIf(p,p,@WStr("(defaulf)"))
    End Select
End Select

Case WM_CLOSE:EndDialog hWin,0:PostQuitMessage 0
Case Else:Exit Function
End Select
e:Return 1
End Function

'Sub main cdecl Alias "main"'Entry Point

    hInstance=GetModuleHandle(0)

    DialogBoxParamW(hInstance,Cast(LPCTSTR,1000),0,@DlgProc,0)

    If hw=0 Then MsEx(hw,"Error create dialog main!","Error",16)
    
    ExitProcess 0
'End Sub


File: MsEx_Test.rc


Код
#define Dlg_Main 1000

Dlg_Main DIALOGEX 0,0,412,224
CAPTION "MsEx"
FONT 8,"MS Sans Serif",400,0,0
STYLE 0x10CE0800
BEGIN
  CONTROL "Show MsEx",1001,"Button",0x50010000,268,164,136,52
  CONTROL "Hello!",1002,"Edit",0x503110C4,8,44,400,36,0x00000200
  CONTROL "Text",1003,"Static",0x50000000,4,32,52,12
  CONTROL "Caption",1004,"Static",0x50000000,4,0,60,12
  CONTROL "Test",1005,"Edit",0x500100C0,8,12,400,16,0x00000200
  CONTROL "Ico x",1006,"Button",0x50010009,60,96,40,16
  CONTROL "Ico ?",1007,"Button",0x50010009,100,96,40,16
  CONTROL "Ico !",1008,"Button",0x50010009,140,96,40,16
  CONTROL "Ico i",1009,"Button",0x50010009,180,96,40,16
  CONTROL "Ico Resource(1-255)",1010,"Button",0x50010009,220,96,84,16
  CONTROL "Ico HICON",1011,"Button",0x50010009,328,96,76,16
  CONTROL "1",1012,"Edit",0x500120C0,304,96,16,12,0x00000200
  CONTROL "",1013,"ComboBox",0x50210043,48,120,128,76
  CONTROL "Button workset:",1014,"Static",0x50000000,4,116,40,20
  CONTROL "Return",1015,"Static",0x50800000,4,180,252,28
  CONTROL "",1016,"ComboBox",0x50210043,180,120,100,56
  CONTROL "Custom Names:",1017,"Static",0x50000000,4,140,56,16
  CONTROL "",1018,"ComboBox",0x50210043,68,140,108,72
  CONTROL "OK",1019,"Edit",0x500100C4,180,140,100,12,0x00000200
  CONTROL "No Icon",1020,"Button",0x50010009,8,96,48,16
  CONTROL "No set mouse to default btn",1021,"Button",0x50010003,292,120,116,12
  CONTROL "Close on kill focus",1022,"Button",0x50010003,4,160,84,12
  CONTROL "Close on Timer (1-255)",1023,"Button",0x50010003,92,160,92,12
  CONTROL "5",1024,"Edit",0x500120C0,184,160,16,12,0x00000200
  CONTROL "CheckBox",1025,"Button",0x50010003,292,136,116,12
  CONTROL "Checked (if CheckBox on)",1026,"Button",0x50010003,292,148,116,12
END

1 ICON DISCARDABLE "1.ico"


А также к этим файлам нужно добавить как минимум одну любую иконку, под именем "1.ico" одна уже записана в MsEx_Test.rc с id 1. Это главная иконка приложения.


Сообщение отредактировал Somerick - Суббота, 09.02.2019, 04:14
 
Форум » Freebasic » Исходники » MessageBox со своей иконкой (MessageBox со своей иконкой)
  • Страница 1 из 1
  • 1
Поиск: