ab.com コミュニティ https://www.activebasic.com/forum/ |
|
LOOK LIKE HSP ? https://www.activebasic.com/forum/viewtopic.php?t=265 |
ページ 1 / 1 |
作成者: | Uhsp [ 2005年8月10日(水) 22:56 ] |
記事の件名: | LOOK LIKE HSP ? |
HSPに似た構文でコーディング出来ないものかとActiveBasicの学習を兼ねて APIの羅列でここまで出来ましたが 初心者なので問題点や間違った使用法などが察知できませんよろしければ 助言などいただければ嬉しいです。 (Classにしなさいは能力的に見通しが悪いのでゆるしてください) あと、前にも質問しましたが関数の省略値(0)を判断する良い方法があれば あわせてご教授いただきたいと思います。 長いのでURLを貼らせていただきますが問題ならば管理人さんに削除を お願いいたします。 http://fortunehill.ld.infoseek.co.jp/sample/uhsp3.lzh |
作成者: | ゲスト [ 2005年8月10日(水) 23:37 ] |
記事の件名: | |
そんなにHSPが好きならABを使わずとも初めからHSP使えばいいじゃん。 って言っちゃいけない暗黙の了解? |
作成者: | Uhsp [ 2005年8月11日(木) 04:53 ] |
記事の件名: | |
> そんなにHSPが好きならABを使わずとも初めからHSP使えばいいじゃん。 > って言っちゃいけない暗黙の了解? おっしゃる通りですが、好き嫌いの問題では無く ABは従来のBASIC感覚ではとっつき難い構文なのでもう少しBASIC感覚で利用 したいと思い HSPのフォーム・バッファ・オブジェクト管理方法を真似しました しかしHSPとABは全く異なった言語なので 関数名を似せた物マクロだと思って頂いたほうがいいと思います。 (HSPも従来のBASICとは程遠いですが) これがある程度安定してHSPからABへの足がかりになればと思いますが ABを普通に利用している方には意味のない物だと言うのも事実でしょう。 (特に現状はGDI・CONTROL関係の扱いのみですから) |
作成者: | Uhsp [ 2005年10月23日(日) 18:19 ] |
記事の件名: | |
Uhsp 3.01 最新版です。 コード: '|============================================================================| '|=================================================[ UHSPFUNCTIONS 3.00 ]=====| #include <api_mmsys.sbp> '|=====================[ ]=====| #include <api_commctrl.sbp> '|=====================[ ]=====| #include <api_richedit.sbp> '|=====================[ ]=====| #include <api_winsock2.sbp> '|=====================[ ]=====| '|============================================================================| '|=================================================[ ]=====| Const UHSP_REV = "3.01" Const UHSP_BUF = 31 Const UHSP_BN = 100 Const UHSP_BS = (WS_OVERLAPPED or _ WS_CAPTION or _ WS_SYSMENU or _ WS_MINIMIZEBOX or _ WS_THICKFRAME) Const UHSP_BX = (&H00000000) '|=================================================[ ]=====| Const UHSP_OBJ = 63 Const UHSP_ON = 1000 Const UHSP_OS = (WS_CHILD or _ WS_VISIBLE) Const UHSP_OX = (&H00000000) '|=================================================[ ]=====| Const UHSP_ALPHA = &H99999 Const UHSP_TRANS = &H99998 '|=================================================[ ]=====| Const AC_SRC_OVER = &H0 Const AC_SRC_ALPHA = &H1 Const WM_MOUSEWHELL = &H20A Const SB_LINLEFT = &H0 Const SB_LINRIGHT = &H1 Const SB_THUMTRACK = &H5 Const SB_BOTTMOM = &H7 Const DDL_READWRITE = &H0 Const DDL_READONLY = &H1 Const DDL_HIDDEN = &H2 Const DDL_SYSTEM = &H4 Const DDL_DIRECTORY = &H10 Const DDL_ARCHIVE = &H20 Const DDL_POSTMSGS = &H2000 Const DDL_DRIVES = &H4000 Const DDL_EXCLUSIVE = &H8000 '|=================================================[ ]=====| Const EVT_KEY = UHSP_BN Const EVT_MOUSE = UHSP_BN+10 Const EVT_MOUSELBUTTON = UHSP_BN+11 Const EVT_MOUSERBUTTON = UHSP_BN+12 Const EVT_MOUSEMBUTTON = UHSP_BN+13 Const EVT_MOUSEWHELL = UHSP_BN+14 Const EVT_COMMAND = UHSP_BN+20 Const EVT_TIMER = UHSP_BN+30 Const EVT_FORM = UHSP_BN+40 Const EVT_FORMMOVE = UHSP_BN+41 Const EVT_FORMSIZE = UHSP_BN+42 Const EVT_FORMSCROLL = UHSP_BN+43 Const EVT_NOTIFY = UHSP_BN+50 Const EVT_MENU = UHSP_BN+60 '|=================================================[ ]=====| Declare Function AlphaBlend Lib "msimg32" ( _ hdcDest as HDC,nXDest as Long,nYDest as Long,nDestWidth as Long, nDestHeight as Long,hdcSrc as HDC,XSrc as Long,YSrc as Long, nSrcWidth as Long,nSrcHeight as Long, ByRef blendfunc as BLENDFUNCTION) as Long Declare Function TransparentBlt Lib "msimg32" ( _ hdcDest as HDC,nXDest as Long,nYDest as Long,nDestWidth as Long, nDestHeight as Long,hdcSrc as HDC,XSrc As Long,YSrc as Long, nSrcWidth as Long,nSrcHeight as Long,dwRop as DWord) as Long Declare Function AdjustWindowRectEx Lib "user32" ( _ ByRef lpRect as RECT,dwStyle as DWord,bMenu as Long, dwExStyle as DWord) as Long Declare Function SHGetSpecialFolderPath Lib "shell32.dll" _ Alias "SHGetSpecialFolderPathA" ( _ hwndOwner As Long,lpszPath As String,nFolder As Long, fCreate As Long) As Long '|=================================================[ ]=====| Type BLENDFUNCTION BlendOp as BYTE BlendFlags as BYTE SourceConstantAlpha as BYTE AlphaFormat as BYTE End Type '|=================================================[ ]=====| Type BUF_INFO hwHnd as HWND hwDC as HDC hwBmp as HBITMAP hwBsh as HBRUSH hwPen as HPEN hwFnt as HFONT hwRgn as HRGN hmDC as HDC hmBmp as HBITMAP hmBsh as HBRUSH hmPen as HPEN hmFnt as HFONT wUid as BYTE wShw as LONG wFcs as LONG wDst as LONG wEst as LONG wCtx as STRING wCsz as POINTAPI wCps as POINTAPI wBsz as POINTAPI wDsz as POINTAPI wFsz as POINTAPI wVps as POINTAPI aSba as POINTAPI aSps as POINTAPI aMnu as LONG aMba as LONG aTba as LONG cPos as POINTAPI cFco as LONG cBco as LONG cBmo as LONG cBst as LONG cPst as LONG cPwd as LONG cFna as STRING cFsz as LONG cFwd as LONG cFit as LONG cFul as LONG cFhl as LONG cFch as LONG cFpt as LONG cGmo as LONG cGsz as POINTAPI cGbd as LONG oCsz as POINTAPI oCps as POINTAPI End Type '|=================================================[ ]=====| Type OBJ_INFO hoHnd as HWND oUid as BYTE oShw as LONG oDst as LONG oEst as LONG oCsz as POINTAPI oCps as POINTAPI oCtx as STRING oCna as STRING oFna as STRING hoFnt as HFONT oFsz as LONG oFwd as LONG oFit as LONG oFul as LONG oFhl as LONG oFch as LONG oFpt as LONG End Type '|=================================================[ ]=====| Dim Uhsp_Wc as WNDCLASSEX Dim Uhsp_Ti as TEXTMETRIC Dim Uhsp_Si as SCROLLINFO Dim Uhsp_Rc as RECT Dim Uhsp_Pt as POINTAPI Dim Uhsp_Fd as WIN32_FIND_DATA Dim Uhsp_Bm as BITMAP Dim Binfo[UHSP_BUF+1] as BUF_INFO Dim Oinfo[UHSP_BUF+1,UHSP_OBJ+1] as OBJ_INFO Dim Cbuf as BYTE Dim Fbuf as BYTE Dim Cobj as LONG Dim hInstance as DWORD Dim hwHnd as HWND Dim hwDC as HDC Dim hmDC as HDC Dim hmBmp as HBITMAP Dim hoMnu as HWND '|=================================================[ ]=====| FillMemory(VarPtr(Uhsp_Wc),Len(Uhsp_Wc),0) With Uhsp_Wc .cbSize = Len(Uhsp_Wc) .hInstance = GetModuleHandle(NULL) .style = CS_HREDRAW or CS_VREDRAW or CS_DBLCLKS .hCursor = LoadCursor(NULL,IDC_ARROW) .hIcon = LoadIcon(NULL,IDI_APPLICATION) .hIconSm = LoadIcon(NULL,IDI_WINLOGO) .lpszClassName = "UHSP_CL" .lpfnWndProc = AddressOf(UhspWndProc) ' .hbrBackground = hMainBrush End With RegisterClassEx(Uhsp_Wc) hInstance = GetModuleHandle(NULL) '|============================================================================| '|=================================================[ BUFFER ]=====| '|============================================================================| Function Buffer(ID as BYTE)(BX as LONG,BY as LONG) as LONG Buffer = Screen(ID,0,0,0,0,,,,BX,BY,2) End Function '|=================================================[ SCREEN ]=====| Function Screen (ID as BYTE) _ (SX as LONG,SY as LONG,PX as LONG,PY as LONG, WS as LONG,EX as LONG,TI as STRING, BX as LONG,BY as LONG,SW as BYTE) as LONG Screen = -1 If (ID < 0) or (ID > UHSP_BUF) Then Exit Function Dim Ck as LONG With Binfo[ID] If (SW = 0) Then SW = 1 If (.wUid = 0) and (SW = 1) Then Ck = 1 If (.wUid = 0) and (SW = 2) Then Ck = 2 If (.wUid = 1) and (SW = 1) Then Ck = -1 If (.wUid = 1) and (SW = 2) Then Ck = -1 If (.wUid = 2) and (SW = 1) Then Ck = 21 If (.wUid = 2) and (SW = 2) Then Ck = 22 Screen = Ck If (Ck = -1) Then Exit Function If (SX = 0) or (SX = -1) Then SX = 640 If (SY = 0) or (SY = -1) Then SY = 480 If (SX < GetSystemMetrics(SM_CXMINTRACK)) Then _ SX = GetSystemMetrics(SM_CXMINTRACK) If (SY < GetSystemMetrics(SM_CYMINTRACK)) Then _ SY = GetSystemMetrics(SM_CYMINTRACK) If (BX = 0) or (BX = -1) Then BX = SX If (BY = 0) or (BY = -1) Then BY = SY If (WS = 0) or (WS = -1) Then WS = UHSP_BS If (SX < BX) or (SY < BY) Then WS = (WS or WS_MAXIMIZEBOX) If (EX = 0) or (EX = -1) Then EX = UHSP_BX If (StrPtr(TI) = 0) Then TI = "- Uhsp "+UHSP_REV+" -" Select Case Ck Case 21,22 Ck = Ck - 20 DeleteDC(.hwDC) :DeleteDC(.hmDC) DeleteObject(.hwRgn) : DeleteObject(.hwBmp) :DeleteObject(.hmBmp) DeleteObject(.hwBsh) :DeleteObject(.hmBsh) DeleteObject(.hwPen) :DeleteObject(.hmPen) DeleteObject(.hwFnt) :DeleteObject(.hmFnt) End Select If (WS and WS_HSCROLL) Then _ .aSba.x = GetSystemMetrics(SM_CYHSCROLL) Else .aSba.x = 0 If (WS and WS_VSCROLL) Then _ .aSba.y = GetSystemMetrics(SM_CYVSCROLL) Else .aSba.y = 0 .wUid = SW .wShw = SW_HIDE .wFcs = 0 .wDst = WS .wEst = EX .wCtx = TI .wCsz.x = SX .wCsz.y = SY .wCps.x = PX .wCps.y = PY .wBsz.x = BX .wBsz.y = BY .wDsz.x = (BX-SX)+.aSba.x .wDsz.y = (BY-SY)+.aSba.y .wVps.x = 0 .wVps.y = 0 .aSps.x = 0 .aSps.y = 0 .aMnu = 0 .aMba = 0 .aTba = 0 .cPos.x = 0 .cPos.y = 0 .cFco = &Hffffff .cBco = &H000000 .cBmo = TRANSPARENT .cBst = PS_SOLID .cPst = PS_SOLID .cPwd = 0 .cFna = "MS 明朝" .cFsz = 16 .cFwd = FW_NORMAL .cFit = 0 .cFul = 0 .cFhl = 0 .cFch = SHIFTJIS_CHARSET .cFpt = DEFAULT_PITCH .cGmo = SRCCOPY .cGsz.x = SX .cGsz.y = SY .cGbd = 0 .oCsz.x = 80 .oCsz.y = 20 .oCps.x = 0 .oCps.y = 0 Select Case Ck Case 1 Uhsp_Rc.left = 0 Uhsp_Rc.right = SX+.aSba.x Uhsp_Rc.top = 0 Uhsp_Rc.bottom = SY+.aSba.y AdjustWindowRectEx(Uhsp_Rc,WS,.aMnu,EX) .wFsz.x = Uhsp_Rc.right-Uhsp_Rc.left .wFsz.y = Uhsp_Rc.bottom-Uhsp_Rc.top .hwHnd = CreateWindowEx(EX,"UHSP_CL","",WS, .wCps.x,.wCps.y, .wFsz.x,.wFsz.y,0,0, GetModuleHandle(NULL),0) SetWindowText(.hwHnd,.wCtx) .hwDC = GetDC(.hwHnd) Case 2 .wFsz.x = 0 .wFsz.y = 0 .hwHnd = 0 .hwDC = GetDC(0) End Select .hwRgn = CreateRectRgn(0,0,.wBsz.x,.wBsz.y) .hwBmp = CreateCompatibleBitmap(.hwDC,.wBsz.x,.wBsz.y) .hmDC = CreateCompatibleDC(.hwDC) .hmBmp = CreateCompatibleBitmap(.hwDC,.wBsz.x,.wBsz.y) .hmBsh = CreateSolidBrush(.cFco) .hmPen = CreatePen(.cPst,.cPwd,.cFco) .hmFnt = CreateFont(-.cFsz,0,0,0,.cFwd,.cFit,.cFul,.cFhl,.cFch, OUT_DEFAULT_PRECIS,CLIP_DEFAULT_PRECIS,DEFAULT_QUALITY, .cFpt,.cFna) .hwBmp = SelectObject(.hmDC,.hmBmp) .hwBsh = SelectObject(.hmDC,.hmBsh) .hwPen = SelectObject(.hmDC,.hmPen) .hwFnt = SelectObject(.hmDC,.hmFnt) SelectObject(.hwDC,.hwRgn) SetTextColor(.hmDC,.cFco) SetBkColor(.hmDC,.cBco) SetBkMode(.hmDC,.cBmo) Cbuf = ID hwHnd = .hwHnd hwDC = .hwDC hmDC = .hmDC hmBmp = .hmBmp End With End Function '|=================================================[ WIDTH ]=====| Function Width(PX as LONG,PY as LONG) _ (SX as LONG,SY as LONG,BX as LONG,BY as LONG) as LONG Width = -1 With Binfo[Cbuf] If (PX = -1) Then PX = .wCps.x If (PY = -1) Then PY = .wCps.y If (SX = 0) or (SX = -1) Then SX = .wCsz.x If (SY = 0) or (SY = -1) Then SY = .wCsz.y If (SX < GetSystemMetrics(SM_CXMINTRACK)) Then _ SX = GetSystemMetrics(SM_CXMINTRACK) If (SY < GetSystemMetrics(SM_CYMINTRACK)) Then _ SY = GetSystemMetrics(SM_CYMINTRACK) If (BX = 0) or (BX = -1) Then BX = .wBsz.x If (BY = 0) or (BY = -1) Then BY = .wBsz.y If (SX > BX) Then SX = BX If (SY > BY) Then SY = BY Width = 1 If (SX <> .wCsz.x) or (SY <> .wCsz.y) Then Width = 2 Dim htDC as HDC,htBmp as HBITMAP htDC = CreateCompatibleDC(.hmDC) htBmp = CreateCompatibleBitmap(.hmDC,.wCsz.x,.wCsz.y) SelectObject(htDC,htBmp) BitBlt(htDC,0,0,.wCsz.x,.wCsz.y,.hmDC,0,0,SRCCOPY) DeleteObject(.hwRgn) DeleteObject(.hwBmp) DeleteObject(.hmBmp) .hwBmp = CreateCompatibleBitmap(.hmDC,BX,BY) .hmBmp = CreateCompatibleBitmap(.hmDC,BX,BY) SelectObject(.hmDC,.hmBmp) BitBlt(.hmDC,0,0,BX,BY,htDC,0,0,SRCCOPY) DeleteDC(htDC) DeleteObject(htBmp) .wCsz.x = SX .wCsz.y = SY .wBsz.x = BX .wBsz.y = BY .hwRgn = CreateRectRgn(0,0,.wBsz.x,.wBsz.y) SelectObject(.hwDC,.hwRgn) End If If (.wUid = 1) Then Uhsp_Rc.left = 0 Uhsp_Rc.right = SX+.aSba.x Uhsp_Rc.top = 0 Uhsp_Rc.bottom = SY+.aSba.y AdjustWindowRectEx(Uhsp_Rc,.wDst,.aMnu,.wEst) .wCps.x = PX .wCps.y = PY .wFsz.x = Uhsp_Rc.right- Uhsp_Rc.left .wFsz.y = Uhsp_Rc.bottom-Uhsp_Rc.top .wDsz.x = BX-SX+.aSba.x .wDsz.y = BY-SY+.aSba.y MoveWindow(.hwHnd,PX,PY,.wFsz.x,.wFsz.y,TRUE) End If End With End Function '|=================================================[ TITLE ]=====| Function Title()(TI as STRING) as LONG Title = -1 With Binfo[Cbuf] If (.wUid <> 1) Then Exit Function If (StrPtr(TI) = 0) Then TI = "" .wCtx = TI Title = SetWindowText(.hwHnd,.wCtx) End With End Function '|=================================================[ FSEL ]=====| Function Fsel(ID as BYTE) as LONG Fsel = -1 If (ID < 0) or (ID > UHSP_BUF) Then Exit Function Dim ii as BYTE For ii = 0 to UHSP_BUF :Binfo[ii].wFcs = 0 :Next ii Binfo[ID].wFcs = 1 Fsel = SetFocus(Binfo[ID].hwHnd) Fbuf = ID End Function '|=================================================[ GSEL ]=====| Function Gsel(ID as BYTE)(SW as LONG) as LONG Gsel = -1 If (ID < 0) or (ID > UHSP_BUF) Then Exit Function With Binfo[ID] If (.wUid <> 1) Then Exit Function Select Case SW Case -1 :.wShw = SW_HIDE Case -2 :.wShw = SW_MINIMIZE Case 1 :.wShw = SW_SHOW Case 2 :.wShw = SW_RESTORE Case 3 :.wShw = SW_SHOWMAXIMIZED Case Else : End Select Cbuf = ID hwHnd = .hwHnd hwDC = .hwDC hmDC = .hmDC hmBmp = .hmBmp ShowWindow(.hwHnd,.wShw) Gsel = ID End With End Function '|=================================================[ POS ]=====| Function Pos()(PX as LONG,PY as LONG) as LONG Pos = -1 With Binfo[Cbuf] If (PX <> -1) Then .cPos.x = PX If (PY <> -1) Then .cPos.y = PY End With Pos = 1 End Function '|=================================================[ MES ]=====| Function Mes()(SS as STRING) as LONG Dim ii as LONG Dim jj as LONG Dim Tx as STRING Mes = 1 With Binfo[Cbuf] If (StrPtr(SS) = 0) Then .cPos.y = .cPos.y+.cFsz :Exit Function If (SS = "") Then .cPos.y = .cPos.y+.cFsz :Exit Function SS = SS+"\n" ii = 1 jj = 1 While 1 jj = InStr(ii,SS,"\n") If (jj = 0) Then Exit While Tx = (Mid$(SS,ii,jj-ii)) ii = jj+2 TextOut(.hmDC,.cPos.x,.cPos.y,Tx,Len(Tx)) .cPos.y = .cPos.y+.cFsz Wend End With End Function '|=================================================[ FCOLOR ]=====| Function Fcolor(RR as LONG)(GG as LONG,BB as LONG) as LONG Fcolor = -1 With Binfo[Cbuf] If (RR > 255) Then .cFco = RR Else .cFco = RGB(RR,GG,BB) Fcolor = SetTextColor(.hmDC,.cFco) Pen(.cPst,.cPwd) Brush(.cBst) End With End Function '|=================================================[ BCOLOR ]=====| Function Bcolor(RR as LONG)(GG as LONG,BB as LONG) as LONG Bcolor = -1 With Binfo[Cbuf] If (RR > 255) Then .cBco = RR Else .cBco = RGB(RR,GG,BB) Bcolor = SetBkColor(.hmDC,.cBco) End With End Function '|=================================================[ QCOLOR ]=====| Function Qcolor()(SW as LONG) as LONG Select Case SW Case 1 :Qcolor = RGB( 0, 0,132) '青 Case 2 :Qcolor = RGB( 0,132, 0) '緑 Case 3 :Qcolor = RGB( 0,132,132) 'シアン Case 4 :Qcolor = RGB(132, 0, 0) '赤 Case 5 :Qcolor = RGB(132, 0,132) 'マゼンタ Case 6 :Qcolor = RGB(132,132, 0) '黄 Case 7 :Qcolor = RGB(192,192,192) '白 Case 8 :Qcolor = RGB(128,128,128) '灰色 Case 9 :Qcolor = RGB( 0, 0,255) '明るい青 Case 10 :Qcolor = RGB( 0,255, 0) '明るい緑 Case 11 :Qcolor = RGB( 0,255,255) '明るいシアン Case 12 :Qcolor = RGB(255, 0, 0) '明るい赤 Case 13 :Qcolor = RGB(255, 0,255) '明るいマゼンタ Case 14 :Qcolor = RGB(255,255, 0) '明るい黄 Case 15 :Qcolor = RGB(255,255,255) '明るい白 Case 16 :Qcolor = GetSysColor(COLOR_3DDKSHADOW) Case 17 :Qcolor = GetSysColor(COLOR_3DFACE) Case 18 :Qcolor = GetSysColor(COLOR_3DHILIGHT) Case 19 :Qcolor = GetSysColor(COLOR_3DHIGHLIGHT) Case 20 :Qcolor = GetSysColor(COLOR_BTNHILIGHT) Case 21 :Qcolor = GetSysColor(COLOR_BTNHIGHLIGHT) Case 22 :Qcolor = GetSysColor(COLOR_3DLIGHT) Case 23 :Qcolor = GetSysColor(COLOR_3DSHADOW) Case 24 :Qcolor = GetSysColor(COLOR_ACTIVEBORDER) Case 25 :Qcolor = GetSysColor(COLOR_ACTIVECAPTION) Case 26 :Qcolor = GetSysColor(COLOR_APPWORKSPACE) Case 27 :Qcolor = GetSysColor(COLOR_BACKGROUND) Case 28 :Qcolor = GetSysColor(COLOR_BTNTEXT) Case 29 :Qcolor = GetSysColor(COLOR_CAPTIONTEXT) Case 30 :Qcolor = GetSysColor(COLOR_GRAYTEXT) Case 31 :Qcolor = GetSysColor(COLOR_HIGHLIGHT) Case 32 :Qcolor = GetSysColor(COLOR_HIGHLIGHTTEXT) Case 33 :Qcolor = GetSysColor(COLOR_INACTIVEBORDER) Case 34 :Qcolor = GetSysColor(COLOR_INACTIVECAPTION) Case 35 :Qcolor = GetSysColor(COLOR_INFOBK) Case 36 :Qcolor = GetSysColor(COLOR_INFOTEXT) Case 37 :Qcolor = GetSysColor(COLOR_MENU) Case 38 :Qcolor = GetSysColor(COLOR_MENUTEXT) Case 39 :Qcolor = GetSysColor(COLOR_SCROLLBAR) Case 40 :Qcolor = GetSysColor(COLOR_WINDOW) Case 41 :Qcolor = GetSysColor(COLOR_WINDOWFRAME) Case 42 :Qcolor = GetSysColor(COLOR_WINDOWTEXT) Case 62 :Qcolor = Binfo[Cbuf].cFco 'Binfo Fcolor Case 63 :Qcolor = Binfo[Cbuf].cBco 'Binfo Bcolor Case Else :Qcolor = RGB( 0, 0, 0) '黒 Qbcolor(0-16) End Select End Function '|=================================================[ BKMODE ]=====| Function Bkmode()(ID as BYTE) as LONG Bkmode = -1 With Binfo[Cbuf] Select Case ID Case 1 :.cBmo = OPAQUE Case Else :.cBmo = TRANSPARENT '0 End Select Bkmode = SetBkMode(.hmDC,.cBmo) End With End Function '|=================================================[ BRUSH ]=====| Function Brush()(BT as BYTE) as LONG Brush = -1 With Binfo[Cbuf] Select Case BT Case 6 :.cBst = HS_HORIZONTAL +1 Case 1 :.cBst = HS_VERTICAL +1 Case 2 :.cBst = HS_FDIAGONAL +1 Case 3 :.cBst = HS_BDIAGONAL +1 Case 4 :.cBst = HS_CROSS +1 Case 5 :.cBst = HS_DIAGCROSS +1 Case Else :.cBst = PS_SOLID End Select DeleteObject(.hmBsh) Select Case .cBst Case 0 :.hmBsh = CreateSolidBrush(.cFco) Case Else :.hmBsh = CreateHatchBrush(.cBst-1,.cFco) End Select Brush = SelectObject(.hmDC,.hmBsh) End With End Function '|=================================================[ PEN ]=====| Function Pen()(PT as BYTE,PW as LONG) as LONG Pen = -1 With Binfo[Cbuf] If (PW <> -1) Then .cPwd = PW Select Case PT Case 1 :.cPst = PS_DASH Case 2 :.cPst = PS_DOT Case 3 :.cPst = PS_DASHDOT Case 4 :.cPst = PS_DASHDOTDOT Case 5 :.cPst = PS_NULL Case Else :.cPst = PS_SOLID '0 End Select DeleteObject(.hmPen) .hmPen = CreatePen(.cPst,.cPwd,.cFco) Pen = SelectObject(.hmDC,.hmPen) End With End Function '|=================================================[ FONT ]=====| Function Font(FS as LONG) _ (FN as STRING,FW as LONG,FI as LONG,FU as LONG,FH as LONG, FC as LONG,FP as LONG) as LONG Font = -1 With Binfo[Cbuf] If (FS = 0) or (FS = -1) Then FS = .cFsz Else .cFsz = FS If (StrPtr(FN) = 0) Then FN = .cFna Else .cFna = FN If (FW = 0) or (FW = -1) Then FW = .cFwd Else .cFwd = FW If (FI = 0) or (FI = -1) Then FI = .cFit Else .cFit = FI If (FU = 0) or (FU = -1) Then FU = .cFul Else .cFul = FU If (FH = 0) or (FH = -1) Then FH = .cFhl Else .cFhl = FH If (FC = 0) or (FC = -1) Then FC = .cFch Else .cFch = FC If (FP = 0) or (FP = -1) Then FP = .cFpt Else .cFpt = FP DeleteObject(.hmFnt) .hmFnt = CreateFont(-FS,0,0,0,FW,FI,FU,FH,FC,OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS,DEFAULT_QUALITY,FP,FN) Font = SelectObject(.hmDC,.hmFnt) End With End Function '|=================================================[ GLINE ]=====| Function Gline(X1 as LONG,Y1 as LONG)(X2 as LONG,Y2 as LONG) as LONG Gline = -1 With Binfo[Cbuf] If (X2 = -1) Then X2 = X1 :X1 = .cPos.x If (Y2 = -1) Then Y2 = Y1 :Y1 = .cPos.y MoveToEx(.hmDC,X2,Y2,ByVal 0) Gline = LineTo(.hmDC,X1,Y1) .cPos.x = X2 .cPos.y = Y2 End With End Function '|=================================================[ BOXF ]=====| Function Boxf()(X1 as LONG,Y1 as LONG,X2 as LONG,Y2 as LONG) as LONG Boxf = -1 With Binfo[Cbuf] If (X1+Y1+X2+Y2 = 0) Then X2 = .wBsz.x :Y2 = .wBsz.y Uhsp_Rc.left = X1 Uhsp_Rc.top = Y1 Uhsp_Rc.right = X2 Uhsp_Rc.bottom = Y2 Boxf = FillRect(.hmDC,Uhsp_Rc,.hmBsh) End With End Function '|=================================================[ GPAINT ]=====| Function Gpaint()(PX as LONG,PY as LONG) as LONG Gpaint = -1 Gpaint = ExtFloodFill(Binfo[Cbuf].hmDC,PX,PY,Gpget(PX,PY),1) End Function '|=================================================[ GPSET ]=====| Function Gpset(PX as LONG,PY as LONG) as LONG Gpset = -1 Gpset = SetPixel(Binfo[Cbuf].hmDC,PX,PY,Binfo[Cbuf].cFco) End Function '|=================================================[ GPGET ]=====| Function Gpget(PX as LONG,PY as LONG) as LONG Gpget = -1 Gpget = GetPixel(Binfo[Cbuf].hmDC,PX,PY) End Function '|=================================================[ GCLS ]=====| Function Gcls()(SW as BYTE) as LONG Dim htBsh as HBRUSH With Binfo[Cbuf] Gcls = -1 Uhsp_Rc.left = 0 Uhsp_Rc.top = 0 Uhsp_Rc.right = .wBsz.x Uhsp_Rc.bottom = .wBsz.y htBsh = CreateSolidBrush(Qcolor(SW)) Gcls = FillRect(.hmDC,Uhsp_Rc,htBsh) DeleteObject(htBsh) .cPos.x = 0 .cPos.y = 0 End With End Function '|=================================================[ GMODE ]=====| Function Gmode()(SW as BYTE,SX as LONG,SY as LONG,BD as LONG) as LONG Gmode = -1 With Binfo[Cbuf] If (SX <> 0) Then .cGsz.x = SX If (SY <> 0) Then .cGsz.y = SY If (BD <> 0) Then .cGbd = BD Select Case SW Case 1 : .cGmo = SRCAND Case 2 : .cGmo = SRCERASE Case 3 : .cGmo = SRCINVERT Case 4 : .cGmo = SRCPAINT Case 5 : .cGmo = DSTINVERT Case 6 : .cGmo = MERGECOPY Case 7 : .cGmo = MERGEPAINT Case 8 : .cGmo = NOTSRCCOPY Case 9 : .cGmo = NOTSRCERASE Case 10 : .cGmo = PATCOPY Case 11 : .cGmo = PATINVERT Case 12 : .cGmo = PATPAINT Case 13 : .cGmo = BLACKNESS Case 14 : .cGmo = WHITENESS Case 15 : .cGmo = UHSP_TRANS Case 16 : .cGmo = UHSP_ALPHA Case Else : .cGmo = SRCCOPY '0 End Select Gmode = 1 End With End Function '|=================================================[ GCOPY ]=====| Function Gcopy(ID as BYTE) _ (PX as LONG,PY as LONG,SX as LONG,SY as LONG) as LONG Gcopy = -1 With Binfo[Cbuf] If (ID < 0) or (ID > UHSP_BUF) Then Exit Function If (SX = 0) Then Uhsp_Pt.x = .cGsz.x Else Uhsp_Pt.x = SX If (SY = 0) Then Uhsp_Pt.y = .cGsz.y Else Uhsp_Pt.y = SY Select Case .cGmo Case UHSP_TRANS TransparentBlt(.hmDC,.cPos.x,.cPos.y,Uhsp_Pt.x,Uhsp_Pt.y, Binfo[ID].hmDC,PX,PY,Uhsp_Pt.x,Uhsp_Pt.y, .cFco) Case UHSP_ALPHA Dim Bf as BLENDFUNCTION Bf.BlendOp = AC_SRC_OVER Bf.BlendFlags = 0 Bf.AlphaFormat = 0 Bf.SourceConstantAlpha = .cGbd Dim Mm as LONG memcpy(VarPtr(Mm),VarPtr(Bf),Len(Mm)) AlphaBlend(.hmDC,.cPos.x,.cPos.y,Uhsp_Pt.x,Uhsp_Pt.y, Binfo[ID].hmDC,PX,PY,Uhsp_Pt.x,Uhsp_Pt.y, ByVal Mm) Case Else BitBlt(.hmDC,.cPos.x,.cPos.y,Uhsp_Pt.x,Uhsp_Pt.y, Binfo[ID].hmDC,PX,PY,.cGmo) End Select .cPos.x = .cPos.x+Uhsp_Pt.x .cPos.y = .cPos.y+Uhsp_Pt.y Gcopy = 1 End With End Function '|=================================================[ GZOOM ]=====| Function Gzoom(ID as BYTE,ZX as LONG,ZY as LONG,PX as LONG,PY as LONG, SX as LONG,SY as LONG) as LONG Gzoom = -1 With Binfo[Cbuf] StretchBlt(.hmDC,.cPos.x,.cPos.y,ZX,ZY, Binfo[ID].hmDC,PX,PY,SX,SY,.cGmo) .cPos.x = .cPos.x+ZX .cPos.y = .cPos.y+ZY Gzoom = 1 End With End Function '|=================================================[ GROLL ]=====| Function Groll()(PX as LONG,PY as LONG) as LONG Groll = -1 With Binfo[Cbuf] If (PX = -1) or (PX < 0) Then PX = .wVps.x If (PY = -1) or (PY < 0) Then PY = .wVps.y If (PX > .wDsz.x) Then .wVps.x = .wDsz.x Else .wVps.x = PX If (PY > .wDsz.y) Then .wVps.y = .wDsz.y Else .wVps.y = PY Groll = 1 End With End Function '|=================================================[ REDRAW ]=====| Function Redraw()(X1 as LONG,Y1 as LONG,X2 as LONG,Y2 as LONG) as LONG Redraw = -1 With Binfo[Cbuf] If (.wUid = 1) and (.wShw = SW_SHOW) Then Select Case (X1+Y1+X2+Y2) Case 0 BitBlt(.hwDC,0,0,.wBsz.x,.wBsz.y, .hmDC,.wVps.x,.wVps.y,SRCCOPY) Case Else Uhsp_Rc.left = X1 Uhsp_Rc.top = Y1 Uhsp_Rc.right = X2 Uhsp_Rc.bottom = Y2 BitBlt(.hwDC,Uhsp_Rc.left,Uhsp_Rc.top, Uhsp_Rc.right,Uhsp_Rc.bottom, .hmDC,Uhsp_Rc.left,Uhsp_Rc.top,SRCCOPY) End Select End If Redraw = 1 End With End Function '|=================================================[ PICLOAD ]=====| Function Picload(FN as STRING)(SW as BYTE) as LONG Dim htDC as HDC Dim htBmp as HBITMAP Picload = -1 With Binfo[Cbuf] htDC = CreateCompatibleDC(.hwDC) htBmp = LoadImage(0,FN,IMAGE_BITMAP,0,0,LR_LOADFROMFILE) SelectObject(htDC,htBmp) GetObject(htBmp,Len(Uhsp_Bm),Uhsp_Bm) Select Case SW Case 1 Width(-1,-1,Uhsp_Bm.bmWidth,Uhsp_Bm.bmHeight) Case Else End Select BitBlt(.hmDC,.cPos.x,.cPos.y,Uhsp_Bm.bmWidth,Uhsp_Bm.bmHeight, htDC,0,0,SRCCOPY) DeleteDC(htDC) DeleteObject(htBmp) Picload = (Uhsp_Bm.bmWidth << 16)+Uhsp_Bm.bmHeight If (Picload = 0) Then Picload = -1 End With End Function '|=================================================[ BMPSAVE ]=====| Function Bmpsave(FN as STRING)(CB as BYTE) as LONG Dim hFile as LONG,htDC as HDC 'Dim Bmp as BITMAP Dim Bmf as BITMAPFILEHEADER Dim Bmi as BITMAPINFO Dim Dsz as DWORD,Dps as BytePtr,Wtp as LONG,Dck as INTEGER Bmpsave = -1 Select Case CB Case 1 :CB = 1 Case 2 :CB = 4 Case 3 :CB = 8 Case 4 :CB = 16 Case 5 :CB = 24 Case 6 :CB = 32 Case Else :CB = 24 '0 End Select Bmi.bmiHeader.biSize = 40 Bmi.bmiHeader.biWidth = Binfo[Cbuf].wBsz.x Bmi.bmiHeader.biHeight = Binfo[Cbuf].wBsz.y Bmi.bmiHeader.biPlanes = 1 Bmi.bmiHeader.biBitCount = CB Bmi.bmiHeader.biCompression = BI_RGB Bmi.bmiHeader.biSizeImage = 0 Bmi.bmiHeader.biXPelsPerMeter = 0 Bmi.bmiHeader.biYPelsPerMeter = 0 Bmi.bmiHeader.biClrUsed = 0 Bmi.bmiHeader.biClrImportant = 0 Dsz = ((CB*Bmi.bmiHeader.biWidth+31)\32)*4*Abs(Bmi.bmiHeader.biHeight) Bmf.bfType = &H4D42 Bmf.bfReserved1 = 0 Bmf.bfReserved2 = 0 If (CB <= 8) Then Bmf.bfOffBits = 54+(4*(1<<CB)) Else Bmf.bfOffBits = 54 Bmf.bfSize = Dsz+Bmf.bfOffBits Dps = GlobalAlloc(GPTR, Dsz) htDC = CreateCompatibleDC(Binfo[Cbuf].hmDC) SelectObject(htDC, Binfo[Cbuf].hmBmp) Dck = GetDIBits(htDC,Binfo[Cbuf].hmBmp, 0,Binfo[Cbuf].wBsz.y,Dps,Bmi,DIB_RGB_COLORS) DeleteDC(htDC) hFile = CreateFile(FN,GENERIC_WRITE,0,ByVal NULL, CREATE_ALWAYS,FILE_ATTRIBUTE_NORMAL,NULL) WriteFile(hFile,VarPtr(Bmf),14,VarPtr(Wtp),ByVal NULL) WriteFile(hFile,VarPtr(Bmi),Bmf.bfOffBits-14,VarPtr(Wtp),ByVal NULL) WriteFile(hFile,Dps,Dsz,VarPtr(Wtp),ByVal NULL) CloseHandle(hFile) GlobalFree(Dps) Bmpsave = 1 End Function '|=================================================[ DIALOG ]=====| Function Dialog(SS as STRING)(TI as STRING,BS as LONG,HD as LONG) as LONG Dim Rx as DWORD Dialog = -1 If (StrPtr(TI) = 0) Then TI = "" If (HD = 0) Then HD = Binfo[Cbuf].hwHnd Else HD = 0 If (BS = 0) Then BS = MB_OK MsgBox HD,SS,TI,BS,Rx Dialog = Rx InvalidateRect(HD,ByVal NULL,TRUE) End Function '|=================================================[ GETKEY ]=====| Function Getkey(SW as LONG) as LONG Dim htHnd as HANDLE Getkey = -1 htHnd = GetForegroundWindow() If (htHnd = Binfo[Cbuf].hwHnd) and (GetAsyncKeyState(SW) and &H8000) Then Getkey = 1 End If End Function '|=================================================[ STRF ]=====| Function Strf(FM as STRING) _ (P0 as DWORD,P1 as DWORD,P2 as DWORD,P3 as DWORD, P4 as DWORD,P5 as DWORD,P6 as DWORD,P7 as DWORD, P8 as DWORD,P9 as DWORD ) as STRING Dim Tx[ELM(1024)] as Byte Strf = "" wvsprintf(Tx,FM,VarPtr(FM)+SizeOf(*Byte)) Strf = Tx End Function '|=================================================[ EXIST ]=====| Function Exist(FN as STRING)(NN as LONG) as STRING Dim Sh as LONG Sh = FindFirstFile(FN,Uhsp_Fd) While (NN <> 0) FindNextFile(Sh,Uhsp_Fd) NN = NN-1 Wend FindClose(Sh) Exist = Uhsp_Fd.cFileName End Function '|=================================================[ DIRINFO ]=====| Function Dirinfo(SW as BYTE)(OP as LONG) as STRING Dim Tx as STRING Tx = String$(255,Chr$(0)) If (OP <> 0) Then SW = 255 Select Case SW Case 1 :GetWindowsDirectory(Tx,255) Case 2 :GetSystemDirectory(Tx,255) Case 3 :GetTempPath(255,Tx) Case 4 :SHGetSpecialFolderPath(GetDesktopWindow(),Tx,&H0,FALSE) Case 255 :SHGetSpecialFolderPath(GetDesktopWindow(),Tx,OP ,FALSE) Case Else :GetCurrentDirectory(255,Tx) End Select Dirinfo = Left$(Tx,InStr(1,Tx,Chr$(0))-1) End Function '|=================================================[ GINFO ]=====| Function Ginfo(SW as BYTE) as LONG With Binfo[Cbuf] Select Case SW Case 0 :GetCursorPos(Uhsp_Pt) :Ginfo = Uhsp_Pt.x Case 1 :GetCursorPos(Uhsp_Pt) :Ginfo = Uhsp_Pt.y Case 2 :Ginfo = Fbuf Case 3 :Ginfo = Cbuf Case 4 :Ginfo = .wCps.x Case 5 :Ginfo = .wCps.y Case 6 :Ginfo = .wCps.x+.wFsz.x Case 7 :Ginfo = .wCps.y+.wFsz.y Case 8 :Ginfo = .wVps.x Case 9 :Ginfo = .wVps.y Case 10 :Ginfo = .wFsz.x Case 11 :Ginfo = .wFsz.y Case 12 :Ginfo = .wCsz.x Case 13 :Ginfo = .wCsz.y Case 14 :Ginfo = -1 'mes size X Case 15 :Ginfo = -1 'mes size Y Case 16 :Ginfo = .cFco and &HFF Case 17 :Ginfo = .cFco >> 8 and &HFF Case 18 :Ginfo = .cFco >> 16 and &HFF Case 19 :Ginfo = 0 'color mode Case 20 :Ginfo = GetSystemMetrics(SM_CXFULLSCREEN) Case 21 :Ginfo = GetSystemMetrics(SM_CYFULLSCREEN) Case 22 :Ginfo = .cPos.x Case 23 :Ginfo = .cPos.y Case 24 :Ginfo = 0 Case Else :Ginfo = -1 'int wnd ID End Select End With End Function '|============================================================================| '|=================================================[ GBUFID ]=====| '|============================================================================| Function Gbufid(HN as HANDLE) as LONG Dim ii as BYTE Gbufid = -1 For ii = 0 to UHSP_BUF If (HN = Binfo[ii].hwHnd) Then Gbufid = ii :Exit For Next ii End Function '|=================================================[ GOBJID ]=====| Function Gobjid(HN as HANDLE) as LONG Dim ii as BYTE Gobjid = -1 For ii = 0 to UHSP_BUF If (Oinfo[Fbuf,ii].oUid = 1) and (HN = Oinfo[Fbuf,ii].hoHnd) Then _ Gobjid = ii :Exit For Next ii End Function '|============================================================================| '|=================================================[ OBJECT ]=====| '|============================================================================| Function Object(ON as STRING) _ (ID as BYTE ,PX as LONG,PY as LONG,SX as LONG,SY as LONG, TI as STRING,WS as LONG,EX as LONG,CN as STRING) as LONG Object = -1 If (ID < 0) or (ID > UHSP_OBJ) Then Exit Function If (Oinfo[Cbuf,ID].oUid <> 0) Then Exit Function If (PX = -1) Then PX = Binfo[Cbuf].oCps.x If (PY = -1) Then PY = Binfo[Cbuf].oCps.y If (SX = 0) Then SX = Binfo[Cbuf].oCsz.x Else Binfo[Cbuf].oCsz.x = SX If (SY = 0) Then SY = Binfo[Cbuf].oCsz.y Else Binfo[Cbuf].oCsz.y = SY If (StrPtr(ON) = 0) Then ON = "Button" If (StrPtr(CN) = 0) Then CN = "BUTTON" If (StrPtr(TI) = 0) Then TI = "" Select Case MakeStr(CharLower(ON)) Case "button" WS = UHSP_OS or BS_PUSHBUTTON or WS EX = UHSP_OX or EX CN = "BUTTON" Uhsp_Pt.x = 0 Uhsp_Pt.y = 0 Case "check" WS = UHSP_OS or BS_AUTOCHECKBOX or WS EX = UHSP_OX or EX CN = "BUTTON" Uhsp_Pt.x = 0 Uhsp_Pt.y = 0 Case "group" WS = UHSP_OS or BS_GROUPBOX or WS EX = UHSP_OX or EX CN = "BUTTON" Uhsp_Pt.x = 0 Uhsp_Pt.y = 0 Case "radio" WS = UHSP_OS or BS_AUTORADIOBUTTON or WS EX = UHSP_OX or EX CN = "BUTTON" Uhsp_Pt.x = 0 Uhsp_Pt.y = 0 Case "label" WS = UHSP_OS or SS_NOTIFY or WS EX = UHSP_OX or EX CN = "STATIC" Uhsp_Pt.x = 0 Uhsp_Pt.y = 0 Case "combo" WS = UHSP_OS or CBS_DROPDOWN or WS EX = UHSP_OX or EX CN = "COMBOBOX" Uhsp_Pt.x = 0 Uhsp_Pt.y = 2 Case "list" WS = UHSP_OS or LBS_STANDARD or LBS_NOINTEGRALHEIGHT or WS '(WS_BORDER | WS_VSCROLL | LBS_SORT | LBS_NOTIFY) EX = UHSP_OX or WS_EX_CLIENTEDGE or EX CN = "LISTBOX" Uhsp_Pt.x = 0 Uhsp_Pt.y = 0 Case "edit" WS = UHSP_OS or ES_MULTILINE or _ ES_AUTOHSCROLL or ES_AUTOVSCROLL or WS EX = UHSP_OX or EX CN = "EDIT" Uhsp_Pt.x = 0 Uhsp_Pt.y = 0 Case "input" WS = UHSP_OS or WS EX = UHSP_OX or EX CN = "EDIT" Uhsp_Pt.x = 0 Uhsp_Pt.y = 0 Case "treeview" WS = UHSP_OS or WS EX = UHSP_OX or EX CN = "SysTreeView32" Uhsp_Pt.x = 0 Uhsp_Pt.y = 0 Case "listview" WS = UHSP_OS or WS EX = UHSP_OX or EX CN = "SysListView32" Uhsp_Pt.x = 0 Uhsp_Pt.y = 0 Case "progressbar" WS = UHSP_OS or WS EX = UHSP_OX or EX CN = "msctls_progress32" Uhsp_Pt.x = 0 Uhsp_Pt.y = 0 Case "hscrollbar" WS = UHSP_OS or WS EX = UHSP_OX or EX CN = "SCROLLBAR" Uhsp_Pt.x = 0 Uhsp_Pt.y = 0 Case "vscrollbar" WS = UHSP_OS or SBS_VERT or WS EX = UHSP_OX or EX CN = "SCROLLBAR" Uhsp_Pt.x = 0 Uhsp_Pt.y = 0 Case "statusbar" If (Binfo[Cbuf].aTba <> 0) Then Exit Function WS = UHSP_OS or CCS_BOTTOM or SBARS_SIZEGRIP or WS EX = UHSP_OX or EX CN = "UHSP_STATUS" Uhsp_Pt.x = 0 Uhsp_Pt.y = 0 Case "menu" If (Binfo[Cbuf].aMnu <> 0) Then Exit Function WS = 0 EX = UHSP_OX or EX CN = "UHSP_MENU" Uhsp_Pt.x = 0 Uhsp_Pt.y = 0 Case Else End Select With Oinfo[Cbuf,ID] .oUid = 1 .oShw = SW_SHOW .oDst = WS .oEst = EX .oCna = CN .oCtx = TI .oCps.x = PX .oCps.y = PY .oFna = "MS 明朝" .oFsz = 16 .oFwd = FW_NORMAL .oFit = 0 .oFul = 0 .oFhl = 0 .oFch = SHIFTJIS_CHARSET .oFpt = DEFAULT_PITCH Select Case CN Case "UHSP_MENU" .hoHnd = CreateMenu() hoMnu = .hoHnd Case "UHSP_STATUS" .hoHnd = CreateStatusWindow(WS,NULL, Binfo[Cbuf].hwHnd,UHSP_ON+ID) Case Else .hoHnd = CreateWindowEx(EX,CN,TI,WS,PX,PY,SX,SY, Binfo[Cbuf].hwHnd,UHSP_ON+ID, GetModuleHandle(NULL),0) End Select Object = .hoHnd .hoFnt = CreateFont(-.oFsz,0,0,0,.oFwd,.oFit,.oFul,.oFhl,.oFch, OUT_DEFAULT_PRECIS,CLIP_DEFAULT_PRECIS,DEFAULT_QUALITY, .oFpt,.oFna) SendMessage(GetDlgItem(Binfo[Cbuf].hwHnd,UHSP_ON+ID), WM_SETFONT,.hoFnt,0) GetWindowRect(.hoHnd,Uhsp_Rc) .oCsz.x = Uhsp_Rc.right-Uhsp_Rc.left-Uhsp_Pt.x .oCsz.y = Uhsp_Rc.bottom-Uhsp_Rc.top-Uhsp_Pt.y Select Case CN Case "UHSP_MENU" Case "UHSP_STATUS" Binfo[Cbuf].aTba = UHSP_ON+ID .oCps.x = 0 .oCps.y = Binfo[Cbuf].wCsz.y-.oCsz.y AddRgn(.oCps.x,.oCps.y,.oCps.x+.oCsz.x,.oCps.y+.oCsz.y) Case Else Binfo[Cbuf].oCps.x = Binfo[Cbuf].oCps.x+.oCsz.x Binfo[Cbuf].oCps.y = Binfo[Cbuf].oCps.y+.oCsz.y AddRgn(.oCps.x,.oCps.y,.oCps.x+.oCsz.x,.oCps.y+.oCsz.y) End Select End With End Function '|=================================================[ OBJMOVE ]=====| Function Objmove(ID as BYTE) _ (PX as LONG,PY as LONG,SX as LONG,SY as LONG) as LONG Objmove = -1 With Oinfo[Cbuf,ID] If (ID < 0) or (ID > UHSP_OBJ) Then Exit Function If (.oUid = 0) Then Exit Function If (PX = -1) Then PX = .oCps.x If (PY = -1) Then PY = .oCps.y If (SX = -1) or (SX = 0) Then SX = .oCsz.x If (SY = -1) or (SY = 0) Then SY = .oCsz.y DelRgn(.oCps.x,.oCps.y,.oCps.x+.oCsz.x,.oCps.y+.oCsz.y) .oCps.x = PX .oCps.y = PY MoveWindow(.hoHnd,PX,PY,SX,SY,TRUE) If (SX <> .oCsz.x) or (SY <> .oCsz.y) Then Select Case .oCna Case "COMBOBOX" Uhsp_Pt.x = 0 :Uhsp_Pt.y = 2 CAse Else :Uhsp_Pt.x = 0 :Uhsp_Pt.y = 0 End Select GetWindowRect(.hoHnd,Uhsp_Rc) .oCsz.x = Uhsp_Rc.right-Uhsp_Rc.left-Uhsp_Pt.x .oCsz.y = Uhsp_Rc.bottom-Uhsp_Rc.top-Uhsp_Pt.y End If AddRgn(PX,PY,PX+.oCsz.x,PY+.oCsz.y) Objmove = 1 End With End Function '|=================================================[ OBJFONT ]=====| Function Objfont(ID as BYTE,FS as LONG) _ (FN as STRING,FW as LONG,FI as LONG,FU as LONG,FH as LONG, FC as LONG,FP as LONG) as LONG Objfont = -1 With Oinfo[Cbuf,ID] If (ID < 0) or (ID > UHSP_OBJ) Then Exit Function If (.oUid = 0) Then Exit Function If (FS = 0) or (FS = -1) Then FS = .oFsz Else .oFsz = FS If (StrPtr(FN) = 0) Then FN = .oFna Else .oFna = FN If (FW = 0) or (FW = -1) Then FW = .oFwd Else .oFwd = FW If (FI = 0) or (FI = -1) Then FI = .oFit Else .oFit = FI If (FU = 0) or (FU = -1) Then FU = .oFul Else .oFul = FU If (FH = 0) or (FH = -1) Then FH = .oFhl Else .oFhl = FH If (FC = 0) or (FC = -1) Then FC = .oFch Else .oFch = FC If (FP = 0) or (FP = -1) Then FP = .oFpt Else .oFpt = FP DeleteObject(.hoFnt) .hoFnt = CreateFont(-FS,0,0,0,FW,FI,FU,FH,FC,OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS,DEFAULT_QUALITY,FP,FN) SendMessage(GetDlgItem(Binfo[Cbuf].hwHnd,UHSP_ON+ID), WM_SETFONT,.hoFnt,0) Objfont = 1 End With End Function '|=================================================[ DELOBJ ]=====| Function Delobj(ID as BYTE) as LONG Delobj = -1 With Oinfo[Cbuf,ID] If (ID < 0) or (ID > UHSP_OBJ) Then Exit Function If (Oinfo[Cbuf,ID].oUid = 0) Then Exit Function DeleteObject(.hoFnt) DestroyWindow(.hoHnd) DelRgn(.oCps.x,.oCps.y,.oCps.x+.oCsz.x,.oCps.y+.oCsz.y) .oUid = 0 .oShw = 0 .oDst = 0 .oEst = 0 .oCna = "" .oCtx = "" .oCps.x = 0 .oCps.y = 0 .oFna = "" .oFsz = 0 .oFwd = 0 .oFit = 0 .oFul = 0 .oFhl = 0 .oFch = 0 .oFpt = 0 Delobj = 1 End With End Function '|=================================================[ SETOBJ ]=====| Function Setobj(ID as BYTE,SS as STRING)(SW as LONG,NN as LONG) as LONG Setobj = -1 With Oinfo[Cbuf,ID] If (ID < 0) or (ID > UHSP_OBJ) Then Exit Function If (.oUid = 0) Then Exit Function If (StrPtr(SS) = 0) Then SS = "" Select Case .oCna Case "STATIC" Select Case SW Case Else :SW = WM_SETTEXT End Select Case "BUTTON" Select Case SW Case 1 :SW = BM_SETCHECK Case Else :SW = WM_SETTEXT End Select Case "LISTBOX" Select Case SW Case 1 :SW = LB_INSERTSTRING Case 2 :SW = LB_DELETESTRING Case 3 :SW = LB_RESETCONTENT Case 4 :SW = LB_SETCURSEL Case Else :SW = LB_ADDSTRING End Select Case "COMBOBOX" Select Case SW Case 1 :SW = CB_INSERTSTRING Case 2 :SW = CB_DELETESTRING Case 3 :SW = CB_RESETCONTENT Case 4 :SW = CB_SETCURSEL Case 5 :SW = CB_SHOWDROPDOWN Case Else :SW = CB_ADDSTRING End Select Case "EDIT" Select Case SW Case Else :SW = WM_SETTEXT End Select Case "UHSP_STATUS" Select Case SW Case Else :SW = SB_SETTEXT End Select Case Else End Select Select Case SW Case BM_SETCHECK SendMessage(.hoHnd,SW,NN,0) Case LB_RESETCONTENT SendMessage(.hoHnd,SW,NN,0) Case CB_RESETCONTENT,CB_SHOWDROPDOWN SendMessage(.hoHnd,SW,NN,0) Case SB_SETTEXT SendMessage(.hoHnd,SW,NN,StrPtr(SS)) Case Else :SendMessage(.hoHnd,SW,NN,StrPtr(SS)) End Select Setobj = 1 End With End Function '|=================================================[ GETOBJ ]=====| Function Getobj(ID as BYTE)(SW as LONG,NN as LONG) as STRING Getobj = "-1" With Oinfo[Cbuf,ID] If (ID < 0) or (ID > UHSP_OBJ) Then Exit Function If (.oUid = 0) Then Exit Function Select Case .oCna Case "STATIC" Select Case SW Case Else :SW = WM_GETTEXT End Select Case "BUTTON" Select Case SW Case 1 :SW = BM_GETCHECK Case Else :SW = WM_GETTEXT End Select Case "LISTBOX" Select Case SW Case 1 :SW = LB_GETCURSEL Case 2 :SW = LB_GETCOUNT Case Else :SW = LB_GETTEXT If (NN = 0) Then _ NN = SendMessage(.hoHnd,LB_GETCURSEL,0,0) End Select Case "COMBOBOX" Select Case SW Case 1 :SW = CB_GETCURSEL Case 2 :SW = CB_GETCOUNT Case Else :SW = CB_GETLBTEXT If (NN = 0) Then _ NN = SendMessage(.hoHnd,CB_GETCURSEL,0,0) End Select Case "EDIT" Select Case SW Case Else :SW = WM_GETTEXT End Select Case Else End Select Dim Tx as STRING Tx = ZeroString(255) Select Case SW Case BM_GETCHECK Tx = Str$(SendMessage(.hoHnd,SW,0,0)) Case LB_GETCURSEL,LB_GETCOUNT Tx = Str$(SendMessage(.hoHnd,SW,0,0)) Case CB_GETCURSEL,CB_GETCOUNT Tx = Str$(SendMessage(.hoHnd,SW,0,0)) Case WM_GETTEXT SendMessage(.hoHnd,SW,255,StrPtr(Tx)) Case Else :SendMessage(.hoHnd,SW,NN ,StrPtr(Tx)) End Select Getobj = Tx End With End Function '|============================================================================| '|=================================================[ ]=====| '|============================================================================| Function AddRgn(X1 as LONG,Y1 as LONG,X2 as LONG,Y2 as LONG) as LONG Dim hRgn as HRGN hRgn = CreateRectRgn(X1,Y1,X2,Y2) ExtSelectClipRgn(Binfo[Cbuf]0.hwDC,hRgn,RGN_DIFF) End Function '|=================================================[ ]=====| Function DelRgn(X1 as LONG,Y1 as LONG,X2 as LONG,Y2 as LONG) as LONG Dim hRgn as HRGN hRgn = CreateRectRgn(X1,Y1,X2,Y2) ExtSelectClipRgn(Binfo[Cbuf]0.hwDC,hRgn,RGN_OR) End Function '|============================================================================| '|=================================================[ ]=====| '|============================================================================| Randomize Uhsp_Init() '|============================================================================| '|=================================================[ ]=====| '|============================================================================| 'Function UhspWndProc(hWnd as DWord,dwMsg as DWord, ' wParam as DWord,lParam as DWord) as DWord ' UhspWndProc=UhspWndEvnt(hWnd,dwMsg,wParam,lParam) 'End Function '|=================================================[ ]=====| Function UhspWndEvnt(hWnd as DWord,message as DWord, wParam as DWord,lParam as DWord) as DWord Dim Bn as LONG Dim Pm as *MINMAXINFO Bn = Gbufid(hWnd) Select Case message Case WM_CREATE ' 1 Uhsp_Si.cbSize = Len(Uhsp_Si) Uhsp_Si.fMask = SIF_ALL Uhsp_Evnt(EVT_FORM ,Bn,message,wParam,lParam,0,0) Case WM_DESTROY ' 2 UhspWnd_Destroy() Case WM_MOVE ' 3 Uhsp_Evnt(EVT_FORMMOVE ,Bn,message-3,wParam,lParam, LOWORD(lParam),HIWORD(lParam)) Case WM_SIZE ' 5 UhspWnd_Scroll(Bn) Uhsp_Evnt(EVT_FORMSIZE ,Bn,message-5,wParam,lParam, LOWORD(lParam),HIWORD(lParam)) Case WM_ACTIVATE ' 6 Binfo[Gbufid(hWnd)].wShw = SW_SHOW Uhsp_Evnt(EVT_FORM ,Bn,message,wParam,lParam,0,0) Case WM_SETFOCUS ' 7 Fsel(Gbufid(hWnd)) Gsel(Fbuf) Uhsp_Evnt(EVT_FORM ,Bn,message,wParam,lParam,0,0) Case WM_KILLFOCUS ' 8 Uhsp_Evnt(EVT_FORM ,Bn,message,wParam,lParam,0,0) Case WM_ENABLE ' 10 Case WM_PAINT ' 15 UhspWnd_Paint() Case WM_CLOSE ' 16 UhspWnd_Close() Case WM_ACTIVATEAPP ' 28 Case WM_GETMINMAXINFO ' 36 If (Bn <> -1) Then Pm = lParam ' Pm->ptMaxSize.x = ' Pm->ptMaxSize.y = Pm->ptMaxPosition.x = 0 Pm->ptMaxPosition.y = 0 Pm->ptMinTrackSize.x = Binfo[Bn].wFsz.x Pm->ptMinTrackSize.y = Binfo[Bn].wFsz.y Pm->ptMaxTrackSize.x = Binfo[Bn].wBsz.x+Binfo[Bn].aSba.y Pm->ptMaxTrackSize.y = Binfo[Bn].wBsz.y+Binfo[Bn].aSba.x End If Case WM_NOTIFY ' 78 Cobj = wParam-UHSP_ON Uhsp_Evnt(EVT_NOTIFY ,Bn,message- 78,wParam,lParam) Case WM_HELP ' 83 Case WM_KEYDOWN,WM_KEYUP,WM_CHAR '256 Uhsp_Evnt(EVT_KEY ,Bn,message-256,wParam,lParam) Case WM_COMMAND '273 ' Uhsp_Evnt(EVT_COMMAND ,Bn,message-273,wParam,lParam,0,0) Cobj = Gobjid(lParam) Uhsp_Evnt(EVT_COMMAND ,Bn,message-273,Cobj+UHSP_ON, lParam,wParam,0) Case WM_TIMER '275 Uhsp_Evnt(EVT_TIMER ,Bn,message-275,wParam,lParam,0,0) Case WM_HSCR |
作成者: | Uhsp [ 2005年10月23日(日) 18:25 ] |
記事の件名: | |
長すぎて途中で切れてしまいました。 コード: '|============================================================================| '|=================================================[ ]=====| '|============================================================================| 'Function UhspWndProc(hWnd as DWord,dwMsg as DWord, ' wParam as DWord,lParam as DWord) as DWord ' UhspWndProc=UhspWndEvnt(hWnd,dwMsg,wParam,lParam) 'End Function '|=================================================[ ]=====| Function UhspWndEvnt(hWnd as DWord,message as DWord, wParam as DWord,lParam as DWord) as DWord Dim Bn as LONG Dim Pm as *MINMAXINFO Bn = Gbufid(hWnd) Select Case message Case WM_CREATE ' 1 Uhsp_Si.cbSize = Len(Uhsp_Si) Uhsp_Si.fMask = SIF_ALL Uhsp_Evnt(EVT_FORM ,Bn,message,wParam,lParam,0,0) Case WM_DESTROY ' 2 UhspWnd_Destroy() Case WM_MOVE ' 3 Uhsp_Evnt(EVT_FORMMOVE ,Bn,message-3,wParam,lParam, LOWORD(lParam),HIWORD(lParam)) Case WM_SIZE ' 5 UhspWnd_Scroll(Bn) Uhsp_Evnt(EVT_FORMSIZE ,Bn,message-5,wParam,lParam, LOWORD(lParam),HIWORD(lParam)) Case WM_ACTIVATE ' 6 Binfo[Gbufid(hWnd)].wShw = SW_SHOW Uhsp_Evnt(EVT_FORM ,Bn,message,wParam,lParam,0,0) Case WM_SETFOCUS ' 7 Fsel(Gbufid(hWnd)) Gsel(Fbuf) Uhsp_Evnt(EVT_FORM ,Bn,message,wParam,lParam,0,0) Case WM_KILLFOCUS ' 8 Uhsp_Evnt(EVT_FORM ,Bn,message,wParam,lParam,0,0) Case WM_ENABLE ' 10 Case WM_PAINT ' 15 UhspWnd_Paint() Case WM_CLOSE ' 16 UhspWnd_Close() Case WM_ACTIVATEAPP ' 28 Case WM_GETMINMAXINFO ' 36 If (Bn <> -1) Then Pm = lParam ' Pm->ptMaxSize.x = ' Pm->ptMaxSize.y = Pm->ptMaxPosition.x = 0 Pm->ptMaxPosition.y = 0 Pm->ptMinTrackSize.x = Binfo[Bn].wFsz.x Pm->ptMinTrackSize.y = Binfo[Bn].wFsz.y Pm->ptMaxTrackSize.x = Binfo[Bn].wBsz.x+Binfo[Bn].aSba.y Pm->ptMaxTrackSize.y = Binfo[Bn].wBsz.y+Binfo[Bn].aSba.x End If Case WM_NOTIFY ' 78 Cobj = wParam-UHSP_ON Uhsp_Evnt(EVT_NOTIFY ,Bn,message- 78,wParam,lParam) Case WM_HELP ' 83 Case WM_KEYDOWN,WM_KEYUP,WM_CHAR '256 Uhsp_Evnt(EVT_KEY ,Bn,message-256,wParam,lParam) Case WM_COMMAND '273 ' Uhsp_Evnt(EVT_COMMAND ,Bn,message-273,wParam,lParam,0,0) Cobj = Gobjid(lParam) Uhsp_Evnt(EVT_COMMAND ,Bn,message-273,Cobj+UHSP_ON, lParam,wParam,0) Case WM_TIMER '275 Uhsp_Evnt(EVT_TIMER ,Bn,message-275,wParam,lParam,0,0) Case WM_HSCROLL '276 If (lParam = 0) Then GetScrollInfo(Binfo[Bn].hwHnd,SB_HORZ,Uhsp_Si) Select Case LOWORD(wParam) Case SB_LINLEFT Uhsp_Si.nPos = Uhsp_Si.nPos-1 Case SB_LINRIGHT Uhsp_Si.nPos = Uhsp_Si.nPos+1 Case SB_PAGELEFT Uhsp_Si.nPos = Uhsp_Si.nPos-10 Case SB_PAGERIGHT Uhsp_Si.nPos = Uhsp_Si.nPos+10 Case SB_THUMBPOSITION Uhsp_Si.nPos = Uhsp_Si.nTrackPos Case SB_THUMTRACK Uhsp_Si.nPos = HIWORD(wParam) Case SB_LEFT Uhsp_Si.nPos = 0 Case SB_RIGHT Uhsp_Si.nPos = 100 Case SB_ENDSCROLL End Select Binfo[Bn].aSps.x = Uhsp_Si.nPos Binfo[Bn].wVps.x = Binfo[Bn].aSps.x*(Binfo[Bn].wDsz.x/100) SetScrollInfo(Binfo[Bn].hwHnd,SB_HORZ,Uhsp_Si,TRUE) InvalidateRect(hWnd,ByVal NULL,TRUE) Uhsp_Evnt(EVT_FORMSCROLL ,Bn,message-276,wParam,lParam, Binfo[Bn].aSps.x,Binfo[Bn].wVps.x) Else Cobj = Gobjid(lParam) Uhsp_Evnt(EVT_COMMAND ,Bn,message-276,Cobj+UHSP_ON, lParam,wParam,lParam) End If Case WM_VSCROLL '277 If (lParam = 0) Then GetScrollInfo(Binfo[Bn].hwHnd,SB_VERT,Uhsp_Si) Select Case LOWORD(wParam) Case SB_LINEUP Uhsp_Si.nPos = Uhsp_Si.nPos-1 Case SB_LINEDOWN Uhsp_Si.nPos = Uhsp_Si.nPos+1 Case SB_PAGEUP Uhsp_Si.nPos = Uhsp_Si.nPos-10 Case SB_PAGEDOWN Uhsp_Si.nPos = Uhsp_Si.nPos+10 Case SB_THUMBPOSITION Uhsp_Si.nPos = Uhsp_Si.nTrackPos Case SB_THUMTRACK Uhsp_Si.nPos = HIWORD(wParam) Case SB_TOP Uhsp_Si.nPos = 0 Case SB_BOTTMOM Uhsp_Si.nPos = 100 Case SB_ENDSCROLL End Select Binfo[Bn].aSps.y = Uhsp_Si.nPos Binfo[Bn].wVps.y = Binfo[Bn].aSps.y*(Binfo[Bn].wDsz.y/100) SetScrollInfo(Binfo[Bn].hwHnd,SB_VERT,Uhsp_Si,TRUE) InvalidateRect(hWnd,ByVal NULL,TRUE) Uhsp_Evnt(EVT_FORMSCROLL ,Bn,message-276,wParam,lParam, Binfo[Bn].aSps.y,Binfo[Bn].wVps.y) Else Cobj = Gobjid(lParam) Uhsp_Evnt(EVT_COMMAND ,Bn,message-276,Cobj+UHSP_ON, lParam,wParam,lParam) End If Case WM_MENUSELECT '287 Uhsp_Evnt(EVT_MENU ,Bn,message-287,wParam,lParam, LOWORD(wParam),HIWORD(wParam)) Case WM_MOUSEMOVE '512 Uhsp_Evnt(EVT_MOUSE ,Bn,message-512,wParam,lParam, LOWORD(lParam),HIWORD(lParam)) Case WM_LBUTTONDOWN,WM_LBUTTONUP,WM_LBUTTONDBLCLK '513 If (GetFocus() <> hWnd) Then Fsel(Gbufid(hWnd)) :Cobj = -1 Uhsp_Evnt(EVT_MOUSELBUTTON ,Bn,message-513,wParam,lParam, LOWORD(lParam),HIWORD(lParam)) Case WM_RBUTTONDOWN,WM_RBUTTONUP,WM_RBUTTONDBLCLK '516 Uhsp_Evnt(EVT_MOUSERBUTTON ,Bn,message-516,wParam,lParam, LOWORD(lParam),HIWORD(lParam)) Case WM_MBUTTONDOWN,WM_MBUTTONUP,WM_MBUTTONDBLCLK '519 Uhsp_Evnt(EVT_MOUSEMBUTTON ,Bn,message-519,wParam,lParam, LOWORD(lParam),HIWORD(lParam)) Case WM_MOUSEWHELL '522 Uhsp_Evnt(EVT_MOUSEWHELL ,Bn,message-522,wParam,lParam, LOWORD(lParam),HIWORD(lParam)) Case WM_SIZING '532 UhspWnd_Scroll(Bn) Uhsp_Evnt(EVT_FORMSIZE ,Bn,message-531,wParam,lParam, Binfo[Bn].wCsz.x,Binfo[Bn].wCsz.y) Case WM_MOVING '534 GetWindowRect(Binfo[Bn].hwHnd,Uhsp_Rc) Binfo[Bn].wCps.x = Uhsp_Rc.left Binfo[Bn].wCps.y = Uhsp_Rc.top Uhsp_Evnt(EVT_FORMMOVE ,Bn,message-533,wParam,lParam, Binfo[Bn].wCps.x,Binfo[Bn].wCps.y) Case WM_DROPFILES '563 Case Else UhspWndEvnt=DefWindowProc(hWnd,message,wParam,lParam) Exit Function End Select UhspWndEvnt=0 End Function '|=================================================[ ]=====| Sub UhspWnd_Scroll(ID as BYTE) With Binfo[ID] GetClientRect(.hwHnd,Uhsp_Rc) .wCsz.x = Uhsp_Rc.right-Uhsp_Rc.left .wCsz.y = Uhsp_Rc.bottom-Uhsp_Rc.top .wDsz.x = .wBsz.x- .wCsz.x .wDsz.y = .wBsz.y- .wCsz.y If (.aTba >= UHSP_ON) Then Dim ii as LONG ii = .aTba-UHSP_ON DelRgn(Oinfo[ID,ii].oCps.x,Oinfo[ID,ii].oCps.y, Oinfo[ID,ii].oCps.x+Oinfo[ID,ii].oCsz.x, Oinfo[ID,ii].oCps.y+Oinfo[ID,ii].oCsz.y) SendMessage(Oinfo[ID,ii].hoHnd,WM_SIZE,.wCsz.x,.wCsz.y) Oinfo[ID,ii].oCps.y = .wCsz.y-Oinfo[ID,ii].oCsz.y Oinfo[ID,ii].oCsz.x = .wCsz.x AddRgn(Oinfo[ID,ii].oCps.x,Oinfo[ID,ii].oCps.y, Oinfo[ID,ii].oCps.x+Oinfo[ID,ii].oCsz.x, Oinfo[ID,ii].oCps.y+Oinfo[ID,ii].oCsz.y) End If If (.aSba.x <> 0) Then If (.wDsz.x <= .wVps.x) Then .wVps.x=.wDsz.x .aSps.x = .wVps.x/(.wDsz.x/100) GetScrollInfo(.hwHnd,SB_HORZ,Uhsp_Si) Uhsp_Si.nPos = .aSps.x SetScrollInfo(.hwHnd,SB_HORZ,Uhsp_Si,TRUE) End If If (.aSba.y <> 0) Then If (.wDsz.y <= .wVps.y) Then .wVps.y=.wDsz.y .aSps.y = .wVps.y/(.wDsz.y/100) GetScrollInfo(.hwHnd,SB_VERT,Uhsp_Si) Uhsp_Si.nPos = .aSps.y SetScrollInfo(.hwHnd,SB_VERT,Uhsp_Si,TRUE) End If InvalidateRect(.hwHnd,ByVal NULL,TRUE) End With End Sub '|=================================================[ ]=====| Sub UhspWnd_Paint() Dim ii as BYTE Dim ps as PAINTSTRUCT For ii = 0 to UHSP_BUF With Binfo[ii] If (.wUid = 1) and (.wShw = SW_SHOW) Then BeginPaint(.hwHnd,ps) BitBlt(.hwDC,0,0,.wBsz.x,.wBsz.y,.hmDC,.wVps.x,.wVps.y,SRCCOPY) EndPaint(.hwHnd,ps) EndIf End With Next ii End Sub '|=================================================[ ]=====| Sub UhspWnd_Close() Dim ii as BYTE For ii= 0 to UHSP_BUF If (Binfo[ii].wUid = 1) Then DestroyWindow(Binfo[ii].hwHnd) Next ii End Sub '|=================================================[ ]=====| Sub UhspWnd_Destroy() Dim ii as BYTE Dim jj as BYTE For ii = 0 to UHSP_BUF With Binfo[ii] If (.wUid <> 0) Then DeleteDC(.hwDC) :DeleteDC(.hmDC) DeleteObject(.hwRgn) : DeleteObject(.hwBmp) :DeleteObject(.hmBmp) DeleteObject(.hwBsh) :DeleteObject(.hmBsh) DeleteObject(.hwPen) :DeleteObject(.hmPen) DeleteObject(.hwFnt) :DeleteObject(.hmFnt) EndIf End With Next ii For ii = 0 to UHSP_BUF For jj = 0 to UHSP_OBJ With Oinfo[ii,jj] If (.oUid <> 0) Then DeleteObject(.hoFnt) End If End With Next jj Next ii PostQuitMessage(0) End Sub '|=================================================[ ]=====| Dim msgMain as MSG,iResult as Long Do If PeekMessage(msgMain,0,0,0,PM_NOREMOVE) Then iResult=GetMessage(msgMain,0,0,0) If iResult=0 or iResult=-1 Then Exit Do TranslateMessage(msgMain) DispatchMessage(msgMain) Else Uhsp_Loop() End If Loop ExitProcess(0) '|============================================================================| '|============================================================================| '|============================================================================|雛形とサンプルです。 コード: '|============================================================================| #include "UhspFunc.abp" '|=====================[ UHSPFUNCTIONS 3.00 ]=====| '|============================================================================| '|=================================================[ ]=====| '|=================================================[ ]=====| Sub Uhsp_Init() /* Screen(0,,,,,UHSP_BS or WS_VSCROLL or WS_HSCROLL,,,Ginfo(20),Ginfo(21)+16) Screen(0,,,100,100,WS_POPUPWINDOW or WS_THICKFRAME) */ Dim ii as Long,px as Long,py as Long,ss as String Screen(0,,,,,UHSP_BS or WS_VSCROLL or WS_HSCROLL,,,Ginfo(20),Ginfo(21)+16) Object("statusbar",0) Buffer(1) ss = Dirinfo(1)+"\"+Exist(Dirinfo(1)+"\*.bmp",0) '0=FastFindBitmap ii = Picload(ss) px = HIWORD(ii) :py = LOWORD(ii) Gsel(0) Setobj(0,ss) Pos(0,0) Gmode(16,px,py,128) :Gcopy(1,0,0) Pos(0,py) Gmode(15,px,py) :Gcopy(1,0,0) Pos(0,py*2) Gmode(0) :Gzoom(1,px,py/2,0,0,px,py) Fcolor(Rnd()*&Hffffff) Font(32) Pos(px,0) Mes("- Uhsp "+UHSP_REV+" -") Fcolor(Rnd()*&Hffffff) Bcolor(Rnd()*&Hff,Rnd()*&Hff,Rnd()*&Hff) Font(32,"MS ゴシック") Bkmode(1) Mes("- Uhsp "+UHSP_REV+" -") Bkmode(0) Fcolor(255,255,255) Gline(px,96,px+206,96) Pen(1) Gline(px+206,96+64,-1,-1) Pen(2) Gline(px,96+64,-1,-1) Pen(3) Gline(px,96,-1,-1) Pen(4) Gline(px+206,96+64,-1,-1) For ii = 0 to 6 Fcolor(Rnd()*&Hffffff) Brush(ii) Boxf(px,ii*32+160+10,px+206,ii*32+160+32) Next Object("Button" , 1,px*2,-1,,,"TEST",BS_RIGHT) Object("Check" , 2,px*2+100,-1) Object("Radio" , 3,px*2,-1) Object("Label" , 4,px*2+100,-1) Object("Combo" , 5,px*2,-1,,120,,,WS_EX_CLIENTEDGE) Object("List" , 6,px*2+100,-1,200,70,,WS_VSCROLL) Object("Edit" , 7,px*2,-1,200,80,,WS_VSCROLL,WS_EX_CLIENTEDGE) Object("Input" , 8,px*2+100,-1,80,20,,,WS_EX_CLIENTEDGE) Object("TreeView" , 9,px*2,-1,80,100) Object("ListView" ,10,px*2+100,-1,80,100) Object("ProgressBar" ,11,px*2,-1,80,20) Object("HscrollBar" ,12,px*2+100,-1,80,20) Object("VscrollBar" ,13,px*2,-1,20,80) Objfont(6,32) SendMessage(Oinfo[Cbuf,6].hoHnd,LB_DIR,&H4000 or &H10 or &H0,"*.*") Objfont(7,24) Setobj(7,"TEST") For ii = 0 to 16 Setobj(5,Strf("%5x",Str$(ii))) Next Objmove(13,px*2+200,-1) Gsel(0,1) End Sub '|=================================================[ ]=====| Sub Uhsp_Loop() Sleep(1) End Sub '|=================================================[ ]=====| Sub Uhsp_Evnt(WM as DWORD,BN as BYTE,ID as DWORD,WP as DWORD,LP as DWORD) _ (P1 as DWORD,P2 as DWORD) Select Case WM Case EVT_KEY Case EVT_MOUSE Case EVT_MOUSELBUTTON Case EVT_MOUSERBUTTON Case EVT_MOUSEMBUTTON Case EVT_MOUSEWHELL Case EVT_COMMAND Case EVT_TIMER Case EVT_FORM Case EVT_FORMSIZE Case EVT_FORMMOVE Case EVT_FORMSCROLL Case EVT_NOTIFY Case EVT_MENU End Select Title(Strf("%d %d %d %d %d %d %d %d",WM,BN,ID,WP,LP,P1,P2,GetFocus())) End Sub '|============================================================================| '|=================================================[ ]=====| '|============================================================================| Function UhspWndProc(hWnd as DWord,dwMsg as DWord, wParam as DWord,lParam as DWord) as DWord UhspWndProc=UhspWndEvnt(hWnd,dwMsg,wParam,lParam) End Function '|============================================================================| '|============================================================================| '|============================================================================| |
作成者: | Uhsp [ 2005年10月23日(日) 18:35 ] |
記事の件名: | |
念のため上の部分を再書き込み。 管理人さま「2005年10月23日(日) 18:19」のレスの削除をお願いいたします。 コード: '|============================================================================| '|=================================================[ UHSPFUNCTIONS 3.00 ]=====| #include <api_mmsys.sbp> '|=====================[ ]=====| #include <api_commctrl.sbp> '|=====================[ ]=====| #include <api_richedit.sbp> '|=====================[ ]=====| #include <api_winsock2.sbp> '|=====================[ ]=====| '|============================================================================| '|=================================================[ ]=====| Const UHSP_REV = "3.01" Const UHSP_BUF = 31 Const UHSP_BN = 100 Const UHSP_BS = (WS_OVERLAPPED or _ WS_CAPTION or _ WS_SYSMENU or _ WS_MINIMIZEBOX or _ WS_THICKFRAME) Const UHSP_BX = (&H00000000) '|=================================================[ ]=====| Const UHSP_OBJ = 63 Const UHSP_ON = 1000 Const UHSP_OS = (WS_CHILD or _ WS_VISIBLE) Const UHSP_OX = (&H00000000) '|=================================================[ ]=====| Const UHSP_ALPHA = &H99999 Const UHSP_TRANS = &H99998 '|=================================================[ ]=====| Const AC_SRC_OVER = &H0 Const AC_SRC_ALPHA = &H1 Const WM_MOUSEWHELL = &H20A Const SB_LINLEFT = &H0 Const SB_LINRIGHT = &H1 Const SB_THUMTRACK = &H5 Const SB_BOTTMOM = &H7 Const DDL_READWRITE = &H0 Const DDL_READONLY = &H1 Const DDL_HIDDEN = &H2 Const DDL_SYSTEM = &H4 Const DDL_DIRECTORY = &H10 Const DDL_ARCHIVE = &H20 Const DDL_POSTMSGS = &H2000 Const DDL_DRIVES = &H4000 Const DDL_EXCLUSIVE = &H8000 '|=================================================[ ]=====| Const EVT_KEY = UHSP_BN Const EVT_MOUSE = UHSP_BN+10 Const EVT_MOUSELBUTTON = UHSP_BN+11 Const EVT_MOUSERBUTTON = UHSP_BN+12 Const EVT_MOUSEMBUTTON = UHSP_BN+13 Const EVT_MOUSEWHELL = UHSP_BN+14 Const EVT_COMMAND = UHSP_BN+20 Const EVT_TIMER = UHSP_BN+30 Const EVT_FORM = UHSP_BN+40 Const EVT_FORMMOVE = UHSP_BN+41 Const EVT_FORMSIZE = UHSP_BN+42 Const EVT_FORMSCROLL = UHSP_BN+43 Const EVT_NOTIFY = UHSP_BN+50 Const EVT_MENU = UHSP_BN+60 '|=================================================[ ]=====| Declare Function AlphaBlend Lib "msimg32" ( _ hdcDest as HDC,nXDest as Long,nYDest as Long,nDestWidth as Long, nDestHeight as Long,hdcSrc as HDC,XSrc as Long,YSrc as Long, nSrcWidth as Long,nSrcHeight as Long, ByRef blendfunc as BLENDFUNCTION) as Long Declare Function TransparentBlt Lib "msimg32" ( _ hdcDest as HDC,nXDest as Long,nYDest as Long,nDestWidth as Long, nDestHeight as Long,hdcSrc as HDC,XSrc As Long,YSrc as Long, nSrcWidth as Long,nSrcHeight as Long,dwRop as DWord) as Long Declare Function AdjustWindowRectEx Lib "user32" ( _ ByRef lpRect as RECT,dwStyle as DWord,bMenu as Long, dwExStyle as DWord) as Long Declare Function SHGetSpecialFolderPath Lib "shell32.dll" _ Alias "SHGetSpecialFolderPathA" ( _ hwndOwner As Long,lpszPath As String,nFolder As Long, fCreate As Long) As Long '|=================================================[ ]=====| Type BLENDFUNCTION BlendOp as BYTE BlendFlags as BYTE SourceConstantAlpha as BYTE AlphaFormat as BYTE End Type '|=================================================[ ]=====| Type BUF_INFO hwHnd as HWND hwDC as HDC hwBmp as HBITMAP hwBsh as HBRUSH hwPen as HPEN hwFnt as HFONT hwRgn as HRGN hmDC as HDC hmBmp as HBITMAP hmBsh as HBRUSH hmPen as HPEN hmFnt as HFONT wUid as BYTE wShw as LONG wFcs as LONG wDst as LONG wEst as LONG wCtx as STRING wCsz as POINTAPI wCps as POINTAPI wBsz as POINTAPI wDsz as POINTAPI wFsz as POINTAPI wVps as POINTAPI aSba as POINTAPI aSps as POINTAPI aMnu as LONG aMba as LONG aTba as LONG cPos as POINTAPI cFco as LONG cBco as LONG cBmo as LONG cBst as LONG cPst as LONG cPwd as LONG cFna as STRING cFsz as LONG cFwd as LONG cFit as LONG cFul as LONG cFhl as LONG cFch as LONG cFpt as LONG cGmo as LONG cGsz as POINTAPI cGbd as LONG oCsz as POINTAPI oCps as POINTAPI End Type '|=================================================[ ]=====| Type OBJ_INFO hoHnd as HWND oUid as BYTE oShw as LONG oDst as LONG oEst as LONG oCsz as POINTAPI oCps as POINTAPI oCtx as STRING oCna as STRING oFna as STRING hoFnt as HFONT oFsz as LONG oFwd as LONG oFit as LONG oFul as LONG oFhl as LONG oFch as LONG oFpt as LONG End Type '|=================================================[ ]=====| Dim Uhsp_Wc as WNDCLASSEX Dim Uhsp_Ti as TEXTMETRIC Dim Uhsp_Si as SCROLLINFO Dim Uhsp_Rc as RECT Dim Uhsp_Pt as POINTAPI Dim Uhsp_Fd as WIN32_FIND_DATA Dim Uhsp_Bm as BITMAP Dim Binfo[UHSP_BUF+1] as BUF_INFO Dim Oinfo[UHSP_BUF+1,UHSP_OBJ+1] as OBJ_INFO Dim Cbuf as BYTE Dim Fbuf as BYTE Dim Cobj as LONG Dim hInstance as DWORD Dim hwHnd as HWND Dim hwDC as HDC Dim hmDC as HDC Dim hmBmp as HBITMAP Dim hoMnu as HWND '|=================================================[ ]=====| FillMemory(VarPtr(Uhsp_Wc),Len(Uhsp_Wc),0) With Uhsp_Wc .cbSize = Len(Uhsp_Wc) .hInstance = GetModuleHandle(NULL) .style = CS_HREDRAW or CS_VREDRAW or CS_DBLCLKS .hCursor = LoadCursor(NULL,IDC_ARROW) .hIcon = LoadIcon(NULL,IDI_APPLICATION) .hIconSm = LoadIcon(NULL,IDI_WINLOGO) .lpszClassName = "UHSP_CL" .lpfnWndProc = AddressOf(UhspWndProc) ' .hbrBackground = hMainBrush End With RegisterClassEx(Uhsp_Wc) hInstance = GetModuleHandle(NULL) '|============================================================================| '|=================================================[ BUFFER ]=====| '|============================================================================| Function Buffer(ID as BYTE)(BX as LONG,BY as LONG) as LONG Buffer = Screen(ID,0,0,0,0,,,,BX,BY,2) End Function '|=================================================[ SCREEN ]=====| Function Screen (ID as BYTE) _ (SX as LONG,SY as LONG,PX as LONG,PY as LONG, WS as LONG,EX as LONG,TI as STRING, BX as LONG,BY as LONG,SW as BYTE) as LONG Screen = -1 If (ID < 0) or (ID > UHSP_BUF) Then Exit Function Dim Ck as LONG With Binfo[ID] If (SW = 0) Then SW = 1 If (.wUid = 0) and (SW = 1) Then Ck = 1 If (.wUid = 0) and (SW = 2) Then Ck = 2 If (.wUid = 1) and (SW = 1) Then Ck = -1 If (.wUid = 1) and (SW = 2) Then Ck = -1 If (.wUid = 2) and (SW = 1) Then Ck = 21 If (.wUid = 2) and (SW = 2) Then Ck = 22 Screen = Ck If (Ck = -1) Then Exit Function If (SX = 0) or (SX = -1) Then SX = 640 If (SY = 0) or (SY = -1) Then SY = 480 If (SX < GetSystemMetrics(SM_CXMINTRACK)) Then _ SX = GetSystemMetrics(SM_CXMINTRACK) If (SY < GetSystemMetrics(SM_CYMINTRACK)) Then _ SY = GetSystemMetrics(SM_CYMINTRACK) If (BX = 0) or (BX = -1) Then BX = SX If (BY = 0) or (BY = -1) Then BY = SY If (WS = 0) or (WS = -1) Then WS = UHSP_BS If (SX < BX) or (SY < BY) Then WS = (WS or WS_MAXIMIZEBOX) If (EX = 0) or (EX = -1) Then EX = UHSP_BX If (StrPtr(TI) = 0) Then TI = "- Uhsp "+UHSP_REV+" -" Select Case Ck Case 21,22 Ck = Ck - 20 DeleteDC(.hwDC) :DeleteDC(.hmDC) DeleteObject(.hwRgn) : DeleteObject(.hwBmp) :DeleteObject(.hmBmp) DeleteObject(.hwBsh) :DeleteObject(.hmBsh) DeleteObject(.hwPen) :DeleteObject(.hmPen) DeleteObject(.hwFnt) :DeleteObject(.hmFnt) End Select If (WS and WS_HSCROLL) Then _ .aSba.x = GetSystemMetrics(SM_CYHSCROLL) Else .aSba.x = 0 If (WS and WS_VSCROLL) Then _ .aSba.y = GetSystemMetrics(SM_CYVSCROLL) Else .aSba.y = 0 .wUid = SW .wShw = SW_HIDE .wFcs = 0 .wDst = WS .wEst = EX .wCtx = TI .wCsz.x = SX .wCsz.y = SY .wCps.x = PX .wCps.y = PY .wBsz.x = BX .wBsz.y = BY .wDsz.x = (BX-SX)+.aSba.x .wDsz.y = (BY-SY)+.aSba.y .wVps.x = 0 .wVps.y = 0 .aSps.x = 0 .aSps.y = 0 .aMnu = 0 .aMba = 0 .aTba = 0 .cPos.x = 0 .cPos.y = 0 .cFco = &Hffffff .cBco = &H000000 .cBmo = TRANSPARENT .cBst = PS_SOLID .cPst = PS_SOLID .cPwd = 0 .cFna = "MS 明朝" .cFsz = 16 .cFwd = FW_NORMAL .cFit = 0 .cFul = 0 .cFhl = 0 .cFch = SHIFTJIS_CHARSET .cFpt = DEFAULT_PITCH .cGmo = SRCCOPY .cGsz.x = SX .cGsz.y = SY .cGbd = 0 .oCsz.x = 80 .oCsz.y = 20 .oCps.x = 0 .oCps.y = 0 Select Case Ck Case 1 Uhsp_Rc.left = 0 Uhsp_Rc.right = SX+.aSba.x Uhsp_Rc.top = 0 Uhsp_Rc.bottom = SY+.aSba.y AdjustWindowRectEx(Uhsp_Rc,WS,.aMnu,EX) .wFsz.x = Uhsp_Rc.right-Uhsp_Rc.left .wFsz.y = Uhsp_Rc.bottom-Uhsp_Rc.top .hwHnd = CreateWindowEx(EX,"UHSP_CL","",WS, .wCps.x,.wCps.y, .wFsz.x,.wFsz.y,0,0, GetModuleHandle(NULL),0) SetWindowText(.hwHnd,.wCtx) .hwDC = GetDC(.hwHnd) Case 2 .wFsz.x = 0 .wFsz.y = 0 .hwHnd = 0 .hwDC = GetDC(0) End Select .hwRgn = CreateRectRgn(0,0,.wBsz.x,.wBsz.y) .hwBmp = CreateCompatibleBitmap(.hwDC,.wBsz.x,.wBsz.y) .hmDC = CreateCompatibleDC(.hwDC) .hmBmp = CreateCompatibleBitmap(.hwDC,.wBsz.x,.wBsz.y) .hmBsh = CreateSolidBrush(.cFco) .hmPen = CreatePen(.cPst,.cPwd,.cFco) .hmFnt = CreateFont(-.cFsz,0,0,0,.cFwd,.cFit,.cFul,.cFhl,.cFch, OUT_DEFAULT_PRECIS,CLIP_DEFAULT_PRECIS,DEFAULT_QUALITY, .cFpt,.cFna) .hwBmp = SelectObject(.hmDC,.hmBmp) .hwBsh = SelectObject(.hmDC,.hmBsh) .hwPen = SelectObject(.hmDC,.hmPen) .hwFnt = SelectObject(.hmDC,.hmFnt) SelectObject(.hwDC,.hwRgn) SetTextColor(.hmDC,.cFco) SetBkColor(.hmDC,.cBco) SetBkMode(.hmDC,.cBmo) Cbuf = ID hwHnd = .hwHnd hwDC = .hwDC hmDC = .hmDC hmBmp = .hmBmp End With End Function '|=================================================[ WIDTH ]=====| Function Width(PX as LONG,PY as LONG) _ (SX as LONG,SY as LONG,BX as LONG,BY as LONG) as LONG Width = -1 With Binfo[Cbuf] If (PX = -1) Then PX = .wCps.x If (PY = -1) Then PY = .wCps.y If (SX = 0) or (SX = -1) Then SX = .wCsz.x If (SY = 0) or (SY = -1) Then SY = .wCsz.y If (SX < GetSystemMetrics(SM_CXMINTRACK)) Then _ SX = GetSystemMetrics(SM_CXMINTRACK) If (SY < GetSystemMetrics(SM_CYMINTRACK)) Then _ SY = GetSystemMetrics(SM_CYMINTRACK) If (BX = 0) or (BX = -1) Then BX = .wBsz.x If (BY = 0) or (BY = -1) Then BY = .wBsz.y If (SX > BX) Then SX = BX If (SY > BY) Then SY = BY Width = 1 If (SX <> .wCsz.x) or (SY <> .wCsz.y) Then Width = 2 Dim htDC as HDC,htBmp as HBITMAP htDC = CreateCompatibleDC(.hmDC) htBmp = CreateCompatibleBitmap(.hmDC,.wCsz.x,.wCsz.y) SelectObject(htDC,htBmp) BitBlt(htDC,0,0,.wCsz.x,.wCsz.y,.hmDC,0,0,SRCCOPY) DeleteObject(.hwRgn) DeleteObject(.hwBmp) DeleteObject(.hmBmp) .hwBmp = CreateCompatibleBitmap(.hmDC,BX,BY) .hmBmp = CreateCompatibleBitmap(.hmDC,BX,BY) SelectObject(.hmDC,.hmBmp) BitBlt(.hmDC,0,0,BX,BY,htDC,0,0,SRCCOPY) DeleteDC(htDC) DeleteObject(htBmp) .wCsz.x = SX .wCsz.y = SY .wBsz.x = BX .wBsz.y = BY .hwRgn = CreateRectRgn(0,0,.wBsz.x,.wBsz.y) SelectObject(.hwDC,.hwRgn) End If If (.wUid = 1) Then Uhsp_Rc.left = 0 Uhsp_Rc.right = SX+.aSba.x Uhsp_Rc.top = 0 Uhsp_Rc.bottom = SY+.aSba.y AdjustWindowRectEx(Uhsp_Rc,.wDst,.aMnu,.wEst) .wCps.x = PX .wCps.y = PY .wFsz.x = Uhsp_Rc.right- Uhsp_Rc.left .wFsz.y = Uhsp_Rc.bottom-Uhsp_Rc.top .wDsz.x = BX-SX+.aSba.x .wDsz.y = BY-SY+.aSba.y MoveWindow(.hwHnd,PX,PY,.wFsz.x,.wFsz.y,TRUE) End If End With End Function '|=================================================[ TITLE ]=====| Function Title()(TI as STRING) as LONG Title = -1 With Binfo[Cbuf] If (.wUid <> 1) Then Exit Function If (StrPtr(TI) = 0) Then TI = "" .wCtx = TI Title = SetWindowText(.hwHnd,.wCtx) End With End Function '|=================================================[ FSEL ]=====| Function Fsel(ID as BYTE) as LONG Fsel = -1 If (ID < 0) or (ID > UHSP_BUF) Then Exit Function Dim ii as BYTE For ii = 0 to UHSP_BUF :Binfo[ii].wFcs = 0 :Next ii Binfo[ID].wFcs = 1 Fsel = SetFocus(Binfo[ID].hwHnd) Fbuf = ID End Function '|=================================================[ GSEL ]=====| Function Gsel(ID as BYTE)(SW as LONG) as LONG Gsel = -1 If (ID < 0) or (ID > UHSP_BUF) Then Exit Function With Binfo[ID] If (.wUid <> 1) Then Exit Function Select Case SW Case -1 :.wShw = SW_HIDE Case -2 :.wShw = SW_MINIMIZE Case 1 :.wShw = SW_SHOW Case 2 :.wShw = SW_RESTORE Case 3 :.wShw = SW_SHOWMAXIMIZED Case Else : End Select Cbuf = ID hwHnd = .hwHnd hwDC = .hwDC hmDC = .hmDC hmBmp = .hmBmp ShowWindow(.hwHnd,.wShw) Gsel = ID End With End Function '|=================================================[ POS ]=====| Function Pos()(PX as LONG,PY as LONG) as LONG Pos = -1 With Binfo[Cbuf] If (PX <> -1) Then .cPos.x = PX If (PY <> -1) Then .cPos.y = PY End With Pos = 1 End Function '|=================================================[ MES ]=====| Function Mes()(SS as STRING) as LONG Dim ii as LONG Dim jj as LONG Dim Tx as STRING Mes = 1 With Binfo[Cbuf] If (StrPtr(SS) = 0) Then .cPos.y = .cPos.y+.cFsz :Exit Function If (SS = "") Then .cPos.y = .cPos.y+.cFsz :Exit Function SS = SS+"\n" ii = 1 jj = 1 While 1 jj = InStr(ii,SS,"\n") If (jj = 0) Then Exit While Tx = (Mid$(SS,ii,jj-ii)) ii = jj+2 TextOut(.hmDC,.cPos.x,.cPos.y,Tx,Len(Tx)) .cPos.y = .cPos.y+.cFsz Wend End With End Function '|=================================================[ FCOLOR ]=====| Function Fcolor(RR as LONG)(GG as LONG,BB as LONG) as LONG Fcolor = -1 With Binfo[Cbuf] If (RR > 255) Then .cFco = RR Else .cFco = RGB(RR,GG,BB) Fcolor = SetTextColor(.hmDC,.cFco) Pen(.cPst,.cPwd) Brush(.cBst) End With End Function '|=================================================[ BCOLOR ]=====| Function Bcolor(RR as LONG)(GG as LONG,BB as LONG) as LONG Bcolor = -1 With Binfo[Cbuf] If (RR > 255) Then .cBco = RR Else .cBco = RGB(RR,GG,BB) Bcolor = SetBkColor(.hmDC,.cBco) End With End Function '|=================================================[ QCOLOR ]=====| Function Qcolor()(SW as LONG) as LONG Select Case SW Case 1 :Qcolor = RGB( 0, 0,132) '青 Case 2 :Qcolor = RGB( 0,132, 0) '緑 Case 3 :Qcolor = RGB( 0,132,132) 'シアン Case 4 :Qcolor = RGB(132, 0, 0) '赤 Case 5 :Qcolor = RGB(132, 0,132) 'マゼンタ Case 6 :Qcolor = RGB(132,132, 0) '黄 Case 7 :Qcolor = RGB(192,192,192) '白 Case 8 :Qcolor = RGB(128,128,128) '灰色 Case 9 :Qcolor = RGB( 0, 0,255) '明るい青 Case 10 :Qcolor = RGB( 0,255, 0) '明るい緑 Case 11 :Qcolor = RGB( 0,255,255) '明るいシアン Case 12 :Qcolor = RGB(255, 0, 0) '明るい赤 Case 13 :Qcolor = RGB(255, 0,255) '明るいマゼンタ Case 14 :Qcolor = RGB(255,255, 0) '明るい黄 Case 15 :Qcolor = RGB(255,255,255) '明るい白 Case 16 :Qcolor = GetSysColor(COLOR_3DDKSHADOW) Case 17 :Qcolor = GetSysColor(COLOR_3DFACE) Case 18 :Qcolor = GetSysColor(COLOR_3DHILIGHT) Case 19 :Qcolor = GetSysColor(COLOR_3DHIGHLIGHT) Case 20 :Qcolor = GetSysColor(COLOR_BTNHILIGHT) Case 21 :Qcolor = GetSysColor(COLOR_BTNHIGHLIGHT) Case 22 :Qcolor = GetSysColor(COLOR_3DLIGHT) Case 23 :Qcolor = GetSysColor(COLOR_3DSHADOW) Case 24 :Qcolor = GetSysColor(COLOR_ACTIVEBORDER) Case 25 :Qcolor = GetSysColor(COLOR_ACTIVECAPTION) Case 26 :Qcolor = GetSysColor(COLOR_APPWORKSPACE) Case 27 :Qcolor = GetSysColor(COLOR_BACKGROUND) Case 28 :Qcolor = GetSysColor(COLOR_BTNTEXT) Case 29 :Qcolor = GetSysColor(COLOR_CAPTIONTEXT) Case 30 :Qcolor = GetSysColor(COLOR_GRAYTEXT) Case 31 :Qcolor = GetSysColor(COLOR_HIGHLIGHT) Case 32 :Qcolor = GetSysColor(COLOR_HIGHLIGHTTEXT) Case 33 :Qcolor = GetSysColor(COLOR_INACTIVEBORDER) Case 34 :Qcolor = GetSysColor(COLOR_INACTIVECAPTION) Case 35 :Qcolor = GetSysColor(COLOR_INFOBK) Case 36 :Qcolor = GetSysColor(COLOR_INFOTEXT) Case 37 :Qcolor = GetSysColor(COLOR_MENU) Case 38 :Qcolor = GetSysColor(COLOR_MENUTEXT) Case 39 :Qcolor = GetSysColor(COLOR_SCROLLBAR) Case 40 :Qcolor = GetSysColor(COLOR_WINDOW) Case 41 :Qcolor = GetSysColor(COLOR_WINDOWFRAME) Case 42 :Qcolor = GetSysColor(COLOR_WINDOWTEXT) Case 62 :Qcolor = Binfo[Cbuf].cFco 'Binfo Fcolor Case 63 :Qcolor = Binfo[Cbuf].cBco 'Binfo Bcolor Case Else :Qcolor = RGB( 0, 0, 0) '黒 Qbcolor(0-16) End Select End Function '|=================================================[ BKMODE ]=====| Function Bkmode()(ID as BYTE) as LONG Bkmode = -1 With Binfo[Cbuf] Select Case ID Case 1 :.cBmo = OPAQUE Case Else :.cBmo = TRANSPARENT '0 End Select Bkmode = SetBkMode(.hmDC,.cBmo) End With End Function '|=================================================[ BRUSH ]=====| Function Brush()(BT as BYTE) as LONG Brush = -1 With Binfo[Cbuf] Select Case BT Case 6 :.cBst = HS_HORIZONTAL +1 Case 1 :.cBst = HS_VERTICAL +1 Case 2 :.cBst = HS_FDIAGONAL +1 Case 3 :.cBst = HS_BDIAGONAL +1 Case 4 :.cBst = HS_CROSS +1 Case 5 :.cBst = HS_DIAGCROSS +1 Case Else :.cBst = PS_SOLID End Select DeleteObject(.hmBsh) Select Case .cBst Case 0 :.hmBsh = CreateSolidBrush(.cFco) Case Else :.hmBsh = CreateHatchBrush(.cBst-1,.cFco) End Select Brush = SelectObject(.hmDC,.hmBsh) End With End Function '|=================================================[ PEN ]=====| Function Pen()(PT as BYTE,PW as LONG) as LONG Pen = -1 With Binfo[Cbuf] If (PW <> -1) Then .cPwd = PW Select Case PT Case 1 :.cPst = PS_DASH Case 2 :.cPst = PS_DOT Case 3 :.cPst = PS_DASHDOT Case 4 :.cPst = PS_DASHDOTDOT Case 5 :.cPst = PS_NULL Case Else :.cPst = PS_SOLID '0 End Select DeleteObject(.hmPen) .hmPen = CreatePen(.cPst,.cPwd,.cFco) Pen = SelectObject(.hmDC,.hmPen) End With End Function '|=================================================[ FONT ]=====| Function Font(FS as LONG) _ (FN as STRING,FW as LONG,FI as LONG,FU as LONG,FH as LONG, FC as LONG,FP as LONG) as LONG Font = -1 With Binfo[Cbuf] If (FS = 0) or (FS = -1) Then FS = .cFsz Else .cFsz = FS If (StrPtr(FN) = 0) Then FN = .cFna Else .cFna = FN If (FW = 0) or (FW = -1) Then FW = .cFwd Else .cFwd = FW If (FI = 0) or (FI = -1) Then FI = .cFit Else .cFit = FI If (FU = 0) or (FU = -1) Then FU = .cFul Else .cFul = FU If (FH = 0) or (FH = -1) Then FH = .cFhl Else .cFhl = FH If (FC = 0) or (FC = -1) Then FC = .cFch Else .cFch = FC If (FP = 0) or (FP = -1) Then FP = .cFpt Else .cFpt = FP DeleteObject(.hmFnt) .hmFnt = CreateFont(-FS,0,0,0,FW,FI,FU,FH,FC,OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS,DEFAULT_QUALITY,FP,FN) Font = SelectObject(.hmDC,.hmFnt) End With End Function '|=================================================[ GLINE ]=====| Function Gline(X1 as LONG,Y1 as LONG)(X2 as LONG,Y2 as LONG) as LONG Gline = -1 With Binfo[Cbuf] If (X2 = -1) Then X2 = X1 :X1 = .cPos.x If (Y2 = -1) Then Y2 = Y1 :Y1 = .cPos.y MoveToEx(.hmDC,X2,Y2,ByVal 0) Gline = LineTo(.hmDC,X1,Y1) .cPos.x = X2 .cPos.y = Y2 End With End Function '|=================================================[ BOXF ]=====| Function Boxf()(X1 as LONG,Y1 as LONG,X2 as LONG,Y2 as LONG) as LONG Boxf = -1 With Binfo[Cbuf] If (X1+Y1+X2+Y2 = 0) Then X2 = .wBsz.x :Y2 = .wBsz.y Uhsp_Rc.left = X1 Uhsp_Rc.top = Y1 Uhsp_Rc.right = X2 Uhsp_Rc.bottom = Y2 Boxf = FillRect(.hmDC,Uhsp_Rc,.hmBsh) End With End Function '|=================================================[ GPAINT ]=====| Function Gpaint()(PX as LONG,PY as LONG) as LONG Gpaint = -1 Gpaint = ExtFloodFill(Binfo[Cbuf].hmDC,PX,PY,Gpget(PX,PY),1) End Function '|=================================================[ GPSET ]=====| Function Gpset(PX as LONG,PY as LONG) as LONG Gpset = -1 Gpset = SetPixel(Binfo[Cbuf].hmDC,PX,PY,Binfo[Cbuf].cFco) End Function '|=================================================[ GPGET ]=====| Function Gpget(PX as LONG,PY as LONG) as LONG Gpget = -1 Gpget = GetPixel(Binfo[Cbuf].hmDC,PX,PY) End Function '|=================================================[ GCLS ]=====| Function Gcls()(SW as BYTE) as LONG Dim htBsh as HBRUSH With Binfo[Cbuf] Gcls = -1 Uhsp_Rc.left = 0 Uhsp_Rc.top = 0 Uhsp_Rc.right = .wBsz.x Uhsp_Rc.bottom = .wBsz.y htBsh = CreateSolidBrush(Qcolor(SW)) Gcls = FillRect(.hmDC,Uhsp_Rc,htBsh) DeleteObject(htBsh) .cPos.x = 0 .cPos.y = 0 End With End Function '|=================================================[ GMODE ]=====| Function Gmode()(SW as BYTE,SX as LONG,SY as LONG,BD as LONG) as LONG Gmode = -1 With Binfo[Cbuf] If (SX <> 0) Then .cGsz.x = SX If (SY <> 0) Then .cGsz.y = SY If (BD <> 0) Then .cGbd = BD Select Case SW Case 1 : .cGmo = SRCAND Case 2 : .cGmo = SRCERASE Case 3 : .cGmo = SRCINVERT Case 4 : .cGmo = SRCPAINT Case 5 : .cGmo = DSTINVERT Case 6 : .cGmo = MERGECOPY Case 7 : .cGmo = MERGEPAINT Case 8 : .cGmo = NOTSRCCOPY Case 9 : .cGmo = NOTSRCERASE Case 10 : .cGmo = PATCOPY Case 11 : .cGmo = PATINVERT Case 12 : .cGmo = PATPAINT Case 13 : .cGmo = BLACKNESS Case 14 : .cGmo = WHITENESS Case 15 : .cGmo = UHSP_TRANS Case 16 : .cGmo = UHSP_ALPHA Case Else : .cGmo = SRCCOPY '0 End Select Gmode = 1 End With End Function '|=================================================[ GCOPY ]=====| Function Gcopy(ID as BYTE) _ (PX as LONG,PY as LONG,SX as LONG,SY as LONG) as LONG Gcopy = -1 With Binfo[Cbuf] If (ID < 0) or (ID > UHSP_BUF) Then Exit Function If (SX = 0) Then Uhsp_Pt.x = .cGsz.x Else Uhsp_Pt.x = SX If (SY = 0) Then Uhsp_Pt.y = .cGsz.y Else Uhsp_Pt.y = SY Select Case .cGmo Case UHSP_TRANS TransparentBlt(.hmDC,.cPos.x,.cPos.y,Uhsp_Pt.x,Uhsp_Pt.y, Binfo[ID].hmDC,PX,PY,Uhsp_Pt.x,Uhsp_Pt.y, .cFco) Case UHSP_ALPHA Dim Bf as BLENDFUNCTION Bf.BlendOp = AC_SRC_OVER Bf.BlendFlags = 0 Bf.AlphaFormat = 0 Bf.SourceConstantAlpha = .cGbd Dim Mm as LONG memcpy(VarPtr(Mm),VarPtr(Bf),Len(Mm)) AlphaBlend(.hmDC,.cPos.x,.cPos.y,Uhsp_Pt.x,Uhsp_Pt.y, Binfo[ID].hmDC,PX,PY,Uhsp_Pt.x,Uhsp_Pt.y, ByVal Mm) Case Else BitBlt(.hmDC,.cPos.x,.cPos.y,Uhsp_Pt.x,Uhsp_Pt.y, Binfo[ID].hmDC,PX,PY,.cGmo) End Select .cPos.x = .cPos.x+Uhsp_Pt.x .cPos.y = .cPos.y+Uhsp_Pt.y Gcopy = 1 End With End Function '|=================================================[ GZOOM ]=====| Function Gzoom(ID as BYTE,ZX as LONG,ZY as LONG,PX as LONG,PY as LONG, SX as LONG,SY as LONG) as LONG Gzoom = -1 With Binfo[Cbuf] StretchBlt(.hmDC,.cPos.x,.cPos.y,ZX,ZY, Binfo[ID].hmDC,PX,PY,SX,SY,.cGmo) .cPos.x = .cPos.x+ZX .cPos.y = .cPos.y+ZY Gzoom = 1 End With End Function '|=================================================[ GROLL ]=====| Function Groll()(PX as LONG,PY as LONG) as LONG Groll = -1 With Binfo[Cbuf] If (PX = -1) or (PX < 0) Then PX = .wVps.x If (PY = -1) or (PY < 0) Then PY = .wVps.y If (PX > .wDsz.x) Then .wVps.x = .wDsz.x Else .wVps.x = PX If (PY > .wDsz.y) Then .wVps.y = .wDsz.y Else .wVps.y = PY Groll = 1 End With End Function '|=================================================[ REDRAW ]=====| Function Redraw()(X1 as LONG,Y1 as LONG,X2 as LONG,Y2 as LONG) as LONG Redraw = -1 With Binfo[Cbuf] If (.wUid = 1) and (.wShw = SW_SHOW) Then Select Case (X1+Y1+X2+Y2) Case 0 BitBlt(.hwDC,0,0,.wBsz.x,.wBsz.y, .hmDC,.wVps.x,.wVps.y,SRCCOPY) Case Else Uhsp_Rc.left = X1 Uhsp_Rc.top = Y1 Uhsp_Rc.right = X2 Uhsp_Rc.bottom = Y2 BitBlt(.hwDC,Uhsp_Rc.left,Uhsp_Rc.top, Uhsp_Rc.right,Uhsp_Rc.bottom, .hmDC,Uhsp_Rc.left,Uhsp_Rc.top,SRCCOPY) End Select End If Redraw = 1 End With End Function '|=================================================[ PICLOAD ]=====| Function Picload(FN as STRING)(SW as BYTE) as LONG Dim htDC as HDC Dim htBmp as HBITMAP Picload = -1 With Binfo[Cbuf] htDC = CreateCompatibleDC(.hwDC) htBmp = LoadImage(0,FN,IMAGE_BITMAP,0,0,LR_LOADFROMFILE) SelectObject(htDC,htBmp) GetObject(htBmp,Len(Uhsp_Bm),Uhsp_Bm) Select Case SW Case 1 Width(-1,-1,Uhsp_Bm.bmWidth,Uhsp_Bm.bmHeight) Case Else End Select BitBlt(.hmDC,.cPos.x,.cPos.y,Uhsp_Bm.bmWidth,Uhsp_Bm.bmHeight, htDC,0,0,SRCCOPY) DeleteDC(htDC) DeleteObject(htBmp) Picload = (Uhsp_Bm.bmWidth << 16)+Uhsp_Bm.bmHeight If (Picload = 0) Then Picload = -1 End With End Function '|=================================================[ BMPSAVE ]=====| Function Bmpsave(FN as STRING)(CB as BYTE) as LONG Dim hFile as LONG,htDC as HDC 'Dim Bmp as BITMAP Dim Bmf as BITMAPFILEHEADER Dim Bmi as BITMAPINFO Dim Dsz as DWORD,Dps as BytePtr,Wtp as LONG,Dck as INTEGER Bmpsave = -1 Select Case CB Case 1 :CB = 1 Case 2 :CB = 4 Case 3 :CB = 8 Case 4 :CB = 16 Case 5 :CB = 24 Case 6 :CB = 32 Case Else :CB = 24 '0 End Select Bmi.bmiHeader.biSize = 40 Bmi.bmiHeader.biWidth = Binfo[Cbuf].wBsz.x Bmi.bmiHeader.biHeight = Binfo[Cbuf].wBsz.y Bmi.bmiHeader.biPlanes = 1 Bmi.bmiHeader.biBitCount = CB Bmi.bmiHeader.biCompression = BI_RGB Bmi.bmiHeader.biSizeImage = 0 Bmi.bmiHeader.biXPelsPerMeter = 0 Bmi.bmiHeader.biYPelsPerMeter = 0 Bmi.bmiHeader.biClrUsed = 0 Bmi.bmiHeader.biClrImportant = 0 Dsz = ((CB*Bmi.bmiHeader.biWidth+31)\32)*4*Abs(Bmi.bmiHeader.biHeight) Bmf.bfType = &H4D42 Bmf.bfReserved1 = 0 Bmf.bfReserved2 = 0 If (CB <= 8) Then Bmf.bfOffBits = 54+(4*(1<<CB)) Else Bmf.bfOffBits = 54 Bmf.bfSize = Dsz+Bmf.bfOffBits Dps = GlobalAlloc(GPTR, Dsz) htDC = CreateCompatibleDC(Binfo[Cbuf].hmDC) SelectObject(htDC, Binfo[Cbuf].hmBmp) Dck = GetDIBits(htDC,Binfo[Cbuf].hmBmp, 0,Binfo[Cbuf].wBsz.y,Dps,Bmi,DIB_RGB_COLORS) DeleteDC(htDC) hFile = CreateFile(FN,GENERIC_WRITE,0,ByVal NULL, CREATE_ALWAYS,FILE_ATTRIBUTE_NORMAL,NULL) WriteFile(hFile,VarPtr(Bmf),14,VarPtr(Wtp),ByVal NULL) WriteFile(hFile,VarPtr(Bmi),Bmf.bfOffBits-14,VarPtr(Wtp),ByVal NULL) WriteFile(hFile,Dps,Dsz,VarPtr(Wtp),ByVal NULL) CloseHandle(hFile) GlobalFree(Dps) Bmpsave = 1 End Function '|=================================================[ DIALOG ]=====| Function Dialog(SS as STRING)(TI as STRING,BS as LONG,HD as LONG) as LONG Dim Rx as DWORD Dialog = -1 If (StrPtr(TI) = 0) Then TI = "" If (HD = 0) Then HD = Binfo[Cbuf].hwHnd Else HD = 0 If (BS = 0) Then BS = MB_OK MsgBox HD,SS,TI,BS,Rx Dialog = Rx InvalidateRect(HD,ByVal NULL,TRUE) End Function '|=================================================[ GETKEY ]=====| Function Getkey(SW as LONG) as LONG Dim htHnd as HANDLE Getkey = -1 htHnd = GetForegroundWindow() If (htHnd = Binfo[Cbuf].hwHnd) and (GetAsyncKeyState(SW) and &H8000) Then Getkey = 1 End If End Function '|=================================================[ STRF ]=====| Function Strf(FM as STRING) _ (P0 as DWORD,P1 as DWORD,P2 as DWORD,P3 as DWORD, P4 as DWORD,P5 as DWORD,P6 as DWORD,P7 as DWORD, P8 as DWORD,P9 as DWORD ) as STRING Dim Tx[ELM(1024)] as Byte Strf = "" wvsprintf(Tx,FM,VarPtr(FM)+SizeOf(*Byte)) Strf = Tx End Function '|=================================================[ EXIST ]=====| Function Exist(FN as STRING)(NN as LONG) as STRING Dim Sh as LONG Sh = FindFirstFile(FN,Uhsp_Fd) While (NN <> 0) FindNextFile(Sh,Uhsp_Fd) NN = NN-1 Wend FindClose(Sh) Exist = Uhsp_Fd.cFileName End Function '|=================================================[ DIRINFO ]=====| Function Dirinfo(SW as BYTE)(OP as LONG) as STRING Dim Tx as STRING Tx = String$(255,Chr$(0)) If (OP <> 0) Then SW = 255 Select Case SW Case 1 :GetWindowsDirectory(Tx,255) Case 2 :GetSystemDirectory(Tx,255) Case 3 :GetTempPath(255,Tx) Case 4 :SHGetSpecialFolderPath(GetDesktopWindow(),Tx,&H0,FALSE) Case 255 :SHGetSpecialFolderPath(GetDesktopWindow(),Tx,OP ,FALSE) Case Else :GetCurrentDirectory(255,Tx) End Select Dirinfo = Left$(Tx,InStr(1,Tx,Chr$(0))-1) End Function '|=================================================[ GINFO ]=====| Function Ginfo(SW as BYTE) as LONG With Binfo[Cbuf] Select Case SW Case 0 :GetCursorPos(Uhsp_Pt) :Ginfo = Uhsp_Pt.x Case 1 :GetCursorPos(Uhsp_Pt) :Ginfo = Uhsp_Pt.y Case 2 :Ginfo = Fbuf Case 3 :Ginfo = Cbuf Case 4 :Ginfo = .wCps.x Case 5 :Ginfo = .wCps.y Case 6 :Ginfo = .wCps.x+.wFsz.x Case 7 :Ginfo = .wCps.y+.wFsz.y Case 8 :Ginfo = .wVps.x Case 9 :Ginfo = .wVps.y Case 10 :Ginfo = .wFsz.x Case 11 :Ginfo = .wFsz.y Case 12 :Ginfo = .wCsz.x Case 13 :Ginfo = .wCsz.y Case 14 :Ginfo = -1 'mes size X Case 15 :Ginfo = -1 'mes size Y Case 16 :Ginfo = .cFco and &HFF Case 17 :Ginfo = .cFco >> 8 and &HFF Case 18 :Ginfo = .cFco >> 16 and &HFF Case 19 :Ginfo = 0 'color mode Case 20 :Ginfo = GetSystemMetrics(SM_CXFULLSCREEN) Case 21 :Ginfo = GetSystemMetrics(SM_CYFULLSCREEN) Case 22 :Ginfo = .cPos.x Case 23 :Ginfo = .cPos.y Case 24 :Ginfo = 0 Case Else :Ginfo = -1 'int wnd ID End Select End With End Function '|============================================================================| '|=================================================[ GBUFID ]=====| '|============================================================================| Function Gbufid(HN as HANDLE) as LONG Dim ii as BYTE Gbufid = -1 For ii = 0 to UHSP_BUF If (HN = Binfo[ii].hwHnd) Then Gbufid = ii :Exit For Next ii End Function '|=================================================[ GOBJID ]=====| Function Gobjid(HN as HANDLE) as LONG Dim ii as BYTE Gobjid = -1 For ii = 0 to UHSP_BUF If (Oinfo[Fbuf,ii].oUid = 1) and (HN = Oinfo[Fbuf,ii].hoHnd) Then _ Gobjid = ii :Exit For Next ii End Function '|============================================================================| '|=================================================[ OBJECT ]=====| '|============================================================================| Function Object(ON as STRING) _ (ID as BYTE ,PX as LONG,PY as LONG,SX as LONG,SY as LONG, TI as STRING,WS as LONG,EX as LONG,CN as STRING) as LONG Object = -1 If (ID < 0) or (ID > UHSP_OBJ) Then Exit Function If (Oinfo[Cbuf,ID].oUid <> 0) Then Exit Function If (PX = -1) Then PX = Binfo[Cbuf].oCps.x If (PY = -1) Then PY = Binfo[Cbuf].oCps.y If (SX = 0) Then SX = Binfo[Cbuf].oCsz.x Else Binfo[Cbuf].oCsz.x = SX If (SY = 0) Then SY = Binfo[Cbuf].oCsz.y Else Binfo[Cbuf].oCsz.y = SY If (StrPtr(ON) = 0) Then ON = "Button" If (StrPtr(CN) = 0) Then CN = "BUTTON" If (StrPtr(TI) = 0) Then TI = "" Select Case MakeStr(CharLower(ON)) Case "button" WS = UHSP_OS or BS_PUSHBUTTON or WS EX = UHSP_OX or EX CN = "BUTTON" Uhsp_Pt.x = 0 Uhsp_Pt.y = 0 Case "check" WS = UHSP_OS or BS_AUTOCHECKBOX or WS EX = UHSP_OX or EX CN = "BUTTON" Uhsp_Pt.x = 0 Uhsp_Pt.y = 0 Case "group" WS = UHSP_OS or BS_GROUPBOX or WS EX = UHSP_OX or EX CN = "BUTTON" Uhsp_Pt.x = 0 Uhsp_Pt.y = 0 Case "radio" WS = UHSP_OS or BS_AUTORADIOBUTTON or WS EX = UHSP_OX or EX CN = "BUTTON" Uhsp_Pt.x = 0 Uhsp_Pt.y = 0 Case "label" WS = UHSP_OS or SS_NOTIFY or WS EX = UHSP_OX or EX CN = "STATIC" Uhsp_Pt.x = 0 Uhsp_Pt.y = 0 Case "combo" WS = UHSP_OS or CBS_DROPDOWN or WS EX = UHSP_OX or EX CN = "COMBOBOX" Uhsp_Pt.x = 0 Uhsp_Pt.y = 2 Case "list" WS = UHSP_OS or LBS_STANDARD or LBS_NOINTEGRALHEIGHT or WS '(WS_BORDER | WS_VSCROLL | LBS_SORT | LBS_NOTIFY) EX = UHSP_OX or WS_EX_CLIENTEDGE or EX CN = "LISTBOX" Uhsp_Pt.x = 0 Uhsp_Pt.y = 0 Case "edit" WS = UHSP_OS or ES_MULTILINE or _ ES_AUTOHSCROLL or ES_AUTOVSCROLL or WS EX = UHSP_OX or EX CN = "EDIT" Uhsp_Pt.x = 0 Uhsp_Pt.y = 0 Case "input" WS = UHSP_OS or WS EX = UHSP_OX or EX CN = "EDIT" Uhsp_Pt.x = 0 Uhsp_Pt.y = 0 Case "treeview" WS = UHSP_OS or WS EX = UHSP_OX or EX CN = "SysTreeView32" Uhsp_Pt.x = 0 Uhsp_Pt.y = 0 Case "listview" WS = UHSP_OS or WS EX = UHSP_OX or EX CN = "SysListView32" Uhsp_Pt.x = 0 Uhsp_Pt.y = 0 Case "progressbar" WS = UHSP_OS or WS EX = UHSP_OX or EX CN = "msctls_progress32" Uhsp_Pt.x = 0 Uhsp_Pt.y = 0 Case "hscrollbar" WS = UHSP_OS or WS EX = UHSP_OX or EX CN = "SCROLLBAR" Uhsp_Pt.x = 0 Uhsp_Pt.y = 0 Case "vscrollbar" WS = UHSP_OS or SBS_VERT or WS EX = UHSP_OX or EX CN = "SCROLLBAR" Uhsp_Pt.x = 0 Uhsp_Pt.y = 0 Case "statusbar" If (Binfo[Cbuf].aTba <> 0) Then Exit Function WS = UHSP_OS or CCS_BOTTOM or SBARS_SIZEGRIP or WS EX = UHSP_OX or EX CN = "UHSP_STATUS" Uhsp_Pt.x = 0 Uhsp_Pt.y = 0 Case "menu" If (Binfo[Cbuf].aMnu <> 0) Then Exit Function WS = 0 EX = UHSP_OX or EX CN = "UHSP_MENU" Uhsp_Pt.x = 0 Uhsp_Pt.y = 0 Case Else End Select With Oinfo[Cbuf,ID] .oUid = 1 .oShw = SW_SHOW .oDst = WS .oEst = EX .oCna = CN .oCtx = TI .oCps.x = PX .oCps.y = PY .oFna = "MS 明朝" .oFsz = 16 .oFwd = FW_NORMAL .oFit = 0 .oFul = 0 .oFhl = 0 .oFch = SHIFTJIS_CHARSET .oFpt = DEFAULT_PITCH Select Case CN Case "UHSP_MENU" .hoHnd = CreateMenu() hoMnu = .hoHnd Case "UHSP_STATUS" .hoHnd = CreateStatusWindow(WS,NULL, Binfo[Cbuf].hwHnd,UHSP_ON+ID) Case Else .hoHnd = CreateWindowEx(EX,CN,TI,WS,PX,PY,SX,SY, Binfo[Cbuf].hwHnd,UHSP_ON+ID, GetModuleHandle(NULL),0) End Select Object = .hoHnd .hoFnt = CreateFont(-.oFsz,0,0,0,.oFwd,.oFit,.oFul,.oFhl,.oFch, OUT_DEFAULT_PRECIS,CLIP_DEFAULT_PRECIS,DEFAULT_QUALITY, .oFpt,.oFna) SendMessage(GetDlgItem(Binfo[Cbuf].hwHnd,UHSP_ON+ID), WM_SETFONT,.hoFnt,0) GetWindowRect(.hoHnd,Uhsp_Rc) .oCsz.x = Uhsp_Rc.right-Uhsp_Rc.left-Uhsp_Pt.x .oCsz.y = Uhsp_Rc.bottom-Uhsp_Rc.top-Uhsp_Pt.y Select Case CN Case "UHSP_MENU" Case "UHSP_STATUS" Binfo[Cbuf].aTba = UHSP_ON+ID .oCps.x = 0 .oCps.y = Binfo[Cbuf].wCsz.y-.oCsz.y AddRgn(.oCps.x,.oCps.y,.oCps.x+.oCsz.x,.oCps.y+.oCsz.y) Case Else Binfo[Cbuf].oCps.x = Binfo[Cbuf].oCps.x+.oCsz.x Binfo[Cbuf].oCps.y = Binfo[Cbuf].oCps.y+.oCsz.y AddRgn(.oCps.x,.oCps.y,.oCps.x+.oCsz.x,.oCps.y+.oCsz.y) End Select End With End Function '|=================================================[ OBJMOVE ]=====| Function Objmove(ID as BYTE) _ (PX as LONG,PY as LONG,SX as LONG,SY as LONG) as LONG Objmove = -1 With Oinfo[Cbuf,ID] If (ID < 0) or (ID > UHSP_OBJ) Then Exit Function If (.oUid = 0) Then Exit Function If (PX = -1) Then PX = .oCps.x If (PY = -1) Then PY = .oCps.y If (SX = -1) or (SX = 0) Then SX = .oCsz.x If (SY = -1) or (SY = 0) Then SY = .oCsz.y DelRgn(.oCps.x,.oCps.y,.oCps.x+.oCsz.x,.oCps.y+.oCsz.y) .oCps.x = PX .oCps.y = PY MoveWindow(.hoHnd,PX,PY,SX,SY,TRUE) If (SX <> .oCsz.x) or (SY <> .oCsz.y) Then Select Case .oCna Case "COMBOBOX" Uhsp_Pt.x = 0 :Uhsp_Pt.y = 2 CAse Else :Uhsp_Pt.x = 0 :Uhsp_Pt.y = 0 End Select GetWindowRect(.hoHnd,Uhsp_Rc) .oCsz.x = Uhsp_Rc.right-Uhsp_Rc.left-Uhsp_Pt.x .oCsz.y = Uhsp_Rc.bottom-Uhsp_Rc.top-Uhsp_Pt.y End If AddRgn(PX,PY,PX+.oCsz.x,PY+.oCsz.y) Objmove = 1 End With End Function '|=================================================[ OBJFONT ]=====| Function Objfont(ID as BYTE,FS as LONG) _ (FN as STRING,FW as LONG,FI as LONG,FU as LONG,FH as LONG, FC as LONG,FP as LONG) as LONG Objfont = -1 With Oinfo[Cbuf,ID] If (ID < 0) or (ID > UHSP_OBJ) Then Exit Function If (.oUid = 0) Then Exit Function If (FS = 0) or (FS = -1) Then FS = .oFsz Else .oFsz = FS If (StrPtr(FN) = 0) Then FN = .oFna Else .oFna = FN If (FW = 0) or (FW = -1) Then FW = .oFwd Else .oFwd = FW If (FI = 0) or (FI = -1) Then FI = .oFit Else .oFit = FI If (FU = 0) or (FU = -1) Then FU = .oFul Else .oFul = FU If (FH = 0) or (FH = -1) Then FH = .oFhl Else .oFhl = FH If (FC = 0) or (FC = -1) Then FC = .oFch Else .oFch = FC If (FP = 0) or (FP = -1) Then FP = .oFpt Else .oFpt = FP DeleteObject(.hoFnt) .hoFnt = CreateFont(-FS,0,0,0,FW,FI,FU,FH,FC,OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS,DEFAULT_QUALITY,FP,FN) SendMessage(GetDlgItem(Binfo[Cbuf].hwHnd,UHSP_ON+ID), WM_SETFONT,.hoFnt,0) Objfont = 1 End With End Function '|=================================================[ DELOBJ ]=====| Function Delobj(ID as BYTE) as LONG Delobj = -1 With Oinfo[Cbuf,ID] If (ID < 0) or (ID > UHSP_OBJ) Then Exit Function If (Oinfo[Cbuf,ID].oUid = 0) Then Exit Function DeleteObject(.hoFnt) DestroyWindow(.hoHnd) DelRgn(.oCps.x,.oCps.y,.oCps.x+.oCsz.x,.oCps.y+.oCsz.y) .oUid = 0 .oShw = 0 .oDst = 0 .oEst = 0 .oCna = "" .oCtx = "" .oCps.x = 0 .oCps.y = 0 .oFna = "" .oFsz = 0 .oFwd = 0 .oFit = 0 .oFul = 0 .oFhl = 0 .oFch = 0 .oFpt = 0 Delobj = 1 End With End Function '|=================================================[ SETOBJ ]=====| Function Setobj(ID as BYTE,SS as STRING)(SW as LONG,NN as LONG) as LONG Setobj = -1 With Oinfo[Cbuf,ID] If (ID < 0) or (ID > UHSP_OBJ) Then Exit Function If (.oUid = 0) Then Exit Function If (StrPtr(SS) = 0) Then SS = "" Select Case .oCna Case "STATIC" Select Case SW Case Else :SW = WM_SETTEXT End Select Case "BUTTON" Select Case SW Case 1 :SW = BM_SETCHECK Case Else :SW = WM_SETTEXT End Select Case "LISTBOX" Select Case SW Case 1 :SW = LB_INSERTSTRING Case 2 :SW = LB_DELETESTRING Case 3 :SW = LB_RESETCONTENT Case 4 :SW = LB_SETCURSEL Case Else :SW = LB_ADDSTRING End Select Case "COMBOBOX" Select Case SW Case 1 :SW = CB_INSERTSTRING Case 2 :SW = CB_DELETESTRING Case 3 :SW = CB_RESETCONTENT Case 4 :SW = CB_SETCURSEL Case 5 :SW = CB_SHOWDROPDOWN Case Else :SW = CB_ADDSTRING End Select Case "EDIT" Select Case SW Case Else :SW = WM_SETTEXT End Select Case "UHSP_STATUS" Select Case SW Case Else :SW = SB_SETTEXT End Select Case Else End Select Select Case SW Case BM_SETCHECK SendMessage(.hoHnd,SW,NN,0) Case LB_RESETCONTENT SendMessage(.hoHnd,SW,NN,0) Case CB_RESETCONTENT,CB_SHOWDROPDOWN SendMessage(.hoHnd,SW,NN,0) Case SB_SETTEXT SendMessage(.hoHnd,SW,NN,StrPtr(SS)) Case Else :SendMessage(.hoHnd,SW,NN,StrPtr(SS)) End Select Setobj = 1 End With End Function '|=================================================[ GETOBJ ]=====| Function Getobj(ID as BYTE)(SW as LONG,NN as LONG) as STRING Getobj = "-1" With Oinfo[Cbuf,ID] If (ID < 0) or (ID > UHSP_OBJ) Then Exit Function If (.oUid = 0) Then Exit Function Select Case .oCna Case "STATIC" Select Case SW Case Else :SW = WM_GETTEXT End Select Case "BUTTON" Select Case SW Case 1 :SW = BM_GETCHECK Case Else :SW = WM_GETTEXT End Select Case "LISTBOX" Select Case SW Case 1 :SW = LB_GETCURSEL Case 2 :SW = LB_GETCOUNT Case Else :SW = LB_GETTEXT If (NN = 0) Then _ NN = SendMessage(.hoHnd,LB_GETCURSEL,0,0) End Select Case "COMBOBOX" Select Case SW Case 1 :SW = CB_GETCURSEL Case 2 :SW = CB_GETCOUNT Case Else :SW = CB_GETLBTEXT If (NN = 0) Then _ NN = SendMessage(.hoHnd,CB_GETCURSEL,0,0) End Select Case "EDIT" Select Case SW Case Else :SW = WM_GETTEXT End Select Case Else End Select Dim Tx as STRING Tx = ZeroString(255) Select Case SW Case BM_GETCHECK Tx = Str$(SendMessage(.hoHnd,SW,0,0)) Case LB_GETCURSEL,LB_GETCOUNT Tx = Str$(SendMessage(.hoHnd,SW,0,0)) Case CB_GETCURSEL,CB_GETCOUNT Tx = Str$(SendMessage(.hoHnd,SW,0,0)) Case WM_GETTEXT SendMessage(.hoHnd,SW,255,StrPtr(Tx)) Case Else :SendMessage(.hoHnd,SW,NN ,StrPtr(Tx)) End Select Getobj = Tx End With End Function '|============================================================================| '|=================================================[ ]=====| '|============================================================================| Function AddRgn(X1 as LONG,Y1 as LONG,X2 as LONG,Y2 as LONG) as LONG Dim hRgn as HRGN hRgn = CreateRectRgn(X1,Y1,X2,Y2) ExtSelectClipRgn(Binfo[Cbuf]0.hwDC,hRgn,RGN_DIFF) End Function '|=================================================[ ]=====| Function DelRgn(X1 as LONG,Y1 as LONG,X2 as LONG,Y2 as LONG) as LONG Dim hRgn as HRGN hRgn = CreateRectRgn(X1,Y1,X2,Y2) ExtSelectClipRgn(Binfo[Cbuf]0.hwDC,hRgn,RGN_OR) End Function '|============================================================================| '|=================================================[ ]=====| '|============================================================================| Randomize Uhsp_Init() '|============================================================================| '|=================================================[ ]=====| '|============================================================================| 'Function UhspWndProc(hWnd as DWord,dwMsg as DWord, ' wParam as DWord,lParam as DWord) as DWord ' UhspWndProc=UhspWndEvnt(hWnd,dwMsg,wParam,lParam) 'End Function |
作成者: | ゲスト [ 2005年10月27日(木) 16:50 ] |
記事の件名: | |
これ、本家と比べると速度はどれくらい出るんだろう? |
作成者: | Uhsp [ 2005年11月07日(月) 22:08 ] |
記事の件名: | |
ここが重たくなってしまったので(原因は私)コードを張るのを止めて再度 URLを貼ります。 上の方のコードで程度はわかって頂けたと思いますから 興味のある方はDLして問題点とか改善策など教えて頂けると嬉しいです。 Uhsp 3.x |
作成者: | Uhsp [ 2005年12月02日(金) 23:26 ] |
記事の件名: | |
Uhsp3.10β ActiveBasiv/Sample/TextEditor の真似ごとサンプルですが コンパイルには別途「Uhsp3.10」が必要です。 (上記ファイルのsrcフォルダにコンパイル済みのサンプルあり) コード: '|============================================================================| #include "../inc/UhspInc3.sbp" '|=====[ UHSPFUNCTION 3.10 ]=====| #resource "Uhsp0000.res" '|=====[ UHSPRESOUCE ]=====| #strict '|=====[ ]=====| '|============================================================================| '|=================================================[ ]=====| Sub Uhsp_Init() Boots("Uhsp0004.exe") Screen(0,,,,,,Ginfo(0,20),Ginfo(0,21),UHSP_BWS or UHSP_WS_MAX) Icoload(,,100) :Object(0,"STATUS") :Setobj(0,,1,0,150) Object(1,"MENU") Setobj(1,,,1) Setobj(1,Ex"編集(&E)" ,1,1) Setobj(1,Ex"書体(&S)" ,2,1,40) Setobj(1,,,0) Setobj(1,Ex"ファイル(&F)",1,0) Setobj(1,Ex"終了(&X)" ,2,0,30) Setobj(1,,2,0) Setobj(1,Ex"保存(&S)" ,2,0,20) Setobj(1,Ex"開く(&O)" ,2,0,10) Setobj(1,,2,0) Setobj(1,Ex"新規作成(&N)",2,0,00) Object(2,"TOOL",200,3) hImg = ImageList_LoadImage(GetModuleHandle(0),201,16,0,RGB(192,192,192), IMAGE_BITMAP,LR_CREATEDIBSECTION) SendMessage(hoHnd,TB_SETHOTIMAGELIST,0,hImg) Object(3,"EDIT",0,Objinfo(0,2,6),640,480-Objinfo(0,0,6)-Objinfo(0,2,6),, UHSP_WS_SCROLL,UHSP_BEX) Setinisect("Position",Dirinfo(0)+"/Uhsp0004.ini") Width(Getinin("PosX",10),Getinin("PosY",10)) Ms = "Text(*.txt)"+Chr$(0)+"*.txt"+Chr$(0)+"All(*.*) "+Chr$(0)+"*.*" Gsel(0,1) End Sub '|=================================================[ ]=====| Dim hImg as HANDLE Dim Ms as String Dim Fn as String '|=================================================[ ]=====| Sub Uhsp_Loop() Sleep(1) End Sub '|=================================================[ ]=====| Function Uhsp_Evnt(EN as DWORD,BN as LONG,WN as DWORD, WP as DWORD,LP as DWORD)(P1 as DWORD,P2 as DWORD) as LONG Select Case EN Case EVT_KEY Case EVT_MOUSE Case EVT_LBUTTON Case EVT_RBUTTON Case EVT_MBUTTON Case EVT_WHELL Case EVT_COMMAND Select Case (P2-UHSP_TID) Case 0 :P2 = (UHSP_MID) Case 1 :P2 = (UHSP_MID+10) Case 2 :P2 = (UHSP_MID+20) End Select Select Case (P2-UHSP_MID) Case 0 :Setobj(3,"") Case 10 Fn = Dialog(,,16,Ms) If (Fn <> "") Then Setobj(3,Bload(Fn)) Case 20 Fn = Dialog(,,17,Ms) If (Fn <> "") Then Dialog(Fn) Case 30 :END Case 40 lstrcpy(Uhsp_Lf.lfFaceName,MakeStr(Objinfo(0,3,12))) Uhsp_Lf.lfHeight = Objinfo(0,3,13) Fn = Dialog(,,20) Objfont(3,Uhsp_Lf.lfHeight,Fn)'96*12/72=16 End Select Select Case (P1-UHSP_OID) Case 3 If (HIWORD(WP) = EN_CHANGE) Then _ Setobj(0," 何かされた~",0,1) End Select Case EVT_TIMER Case EVT_FORM Case EVT_MOVE Case EVT_SIZE Objmove(3,0,Objinfo(0,2,6),Bufinfo(0,19), Bufinfo(0,20)-Objinfo(0,0,6)-Objinfo(0,2,6)) Case EVT_CLOSE Setini("PosX",Str$(Bufinfo(0,17))) Setini("PosY",Str$(Bufinfo(0,18))) ImageList_Destroy(hImg) Case EVT_SCROLL Case EVT_NOTIFY Case EVT_MENU Case EVT_CTLCOLOR End Select Setobj(0,Strf("%d %d %d %d %d %d %d",EN,BN,WN,WP,LP,P1,P2)) End Function '|=================================================[ ]=====| Function UhspWndProc(hWnd as HWND, dwMsg as DWord,wParam as DWord,lParam as DWord) as DWord UhspWndProc=UhspWndEvnt(hWnd,dwMsg,wParam,lParam) End Function '|============================================================================| '|============================================================================| '|============================================================================| |
作成者: | Uhsp [ 2005年12月19日(月) 03:17 ] |
記事の件名: | |
VisualBasicライクなファイル選択方式のビットマップビューアーサンプル です。 コンパイルには別途「Uhsp3.10」が必要ですがダウンロードされた「Uhsp3.lzh」に「Uhsp0011.exe」コンパイル済み実行形式があります。 コード: '|============================================================================| #include "../inc/UhspInc3.sbp" '|=====[ UHSPINCLUDE 3.10 ]=====| #resource "Uhsp0000.res" '|=====[ UHSPRESOUCE ]=====| #strict '|=====[ ]=====| '|============================================================================| '|=================================================[ ]=====| Sub Uhsp_Init() Boots("Uhsp0011.exe") 'Screen(0,,,,,,Ginfo(0,20),Ginfo(0,21),UHSP_BWS or UHSP_WS_MAX) 'Screen(0,,,,,,2000,2000,UHSP_BWS or UHSP_WS_SCROLL) Screen(0) Icoload(,,100) Object( 0,"STATUS") :Setobj( 0,,1,0,330) Drive = "C:/" Folder = "Ausers/Xfiles/Uhsp3/" Folder = "" Mask = "*.bmp" FileName = "" Object( 1,"COMBO",, ,200,200,,,UHSP_BEX) Object( 2,"LIST" ,, 27,200,170,,,UHSP_BEX) Object( 3,"LIST" ,,196,200,280,,,UHSP_BEX) Setobj( 1,"",6,DDL_DRIVES) Setobj( 1,,4,1) Update_List() Gsel(0,1) End Sub '|=================================================[ ]=====| Dim Drive as String Dim Folder as String Dim Mask as String Dim FileName as String Dim ss as String Sub Update_List() Setobj( 2,,3) Setobj( 2,Drive+Folder+"<",6,DDL_DIRECTORY) Setobj( 3,,3) Setobj( 3,Drive+Folder+Mask,6,DDL_READWRITE) End Sub '|=================================================[ ]=====| Sub Uhsp_Loop() Sleep(1) End Sub '|=================================================[ ]=====| Function Uhsp_Evnt(EN as DWORD,BN as LONG,WN as DWORD, WP as DWORD,LP as DWORD)(P1 as DWORD,P2 as DWORD) as LONG Select Case EN Case EVT_KEY Case EVT_MOUSE Case EVT_LBUTTON Case EVT_RBUTTON Case EVT_MBUTTON Case EVT_WHELL Case EVT_COMMAND Select Case (P1-UHSP_OID) Case 1 :If (HIWORD(WP) = CBN_SELCHANGE ) Then ss = Getobj( 1,0) ss = Mid$(ss,3,Len(ss)-4)+":/" Drive = ss Update_List() End If Case 2 :If (HIWORD(WP) = LBN_DBLCLK) Then ss = Getobj( 2,0,Vals(Getobj( 2,1))) ss = Mid$(ss,2,Len(ss)-2) If (ss <> "..") Then Folder = Folder+ss+"/" Else Dim ii as long For ii = 2 to Len(Folder) If (Chr$(GetByte(StrPtr(Folder)+ _ Len(Folder)-ii)) = "/") Then Exit For Next Select Case ii Case Len(Folder)+1 Folder = "" Case Else Folder = Mid$(Folder,1, Len(Folder)-ii+1) End Select End If Update_List() End If Case 3 :If (HIWORD(WP) = LBN_DBLCLK) Then FileName = Getobj( 3,0,Vals(Getobj( 3,1))) Setobj( 0," "+Drive+Folder+FileName,0,1) Gcls() :Pos(205,0) Picload(Drive+Folder+FileName) Redraw() End If End Select Case EVT_TIMER Case EVT_FORM Case EVT_MOVE Case EVT_SIZE Case EVT_CLOSE Case EVT_SCROLL Case EVT_NOTIFY Case EVT_MENU Case EVT_CTLCOLOR Case EVT_DRAWITEM End Select Setobj(0,Strf("%d %d %d %d %d %d %d %d %d",EN,BN,WN,WP,LP,P1,P2,Cbuf,Cobj)) End Function '|=================================================[ ]=====| Function UhspWndProc(hWnd as HWND, dwMsg as DWord,wParam as DWord,lParam as DWord) as DWord UhspWndProc=UhspWndEvnt(hWnd,dwMsg,wParam,lParam) End Function '|============================================================================| '|============================================================================| '|============================================================================| |
作成者: | Uhsp [ 2006年1月23日(月) 21:09 ] |
記事の件名: | |
Uhsp3.10 on ActiveBasic を Uhsp5.01 on FreeBasic として、 ほぼ移植が完了しました。 (同じ場所に Uhsp5.lzh があります。:この板の上の方のURLから参照可能) ActiveBasicとFreeBasicは殆ど似た構文なので修正箇所の大部分は、 1.配列の[ ]を( )へ 2.BytePtrからzString ptr 又は Byte Ptr へ 3.行の継続(_省略) , を正式に ,_ へ 4.大文字小文字が同一扱の混乱を修正 5.関数の仮引数に初期値が設定できるので判断部分の修正・削除 6.戻り値が文字列の関数は受けが無いとエラーなのでポインター扱いにし MakeStr or * で取得に修正 のみでした。 再三言いますが素人がAPIを羅列しただけの物なので参考になるか否かは不明 です。 |
ページ 1 / 1 | 全ての表示時間は UTC+09:00 です |
Powered by phpBB® Forum Software © phpBB Limited https://www.phpbb.com/ |