LOOK LIKE HSP ?
LOOK LIKE HSP ?
HSPに似た構文でコーディング出来ないものかとActiveBasicの学習を兼ねて
APIの羅列でここまで出来ましたが
初心者なので問題点や間違った使用法などが察知できませんよろしければ
助言などいただければ嬉しいです。
(Classにしなさいは能力的に見通しが悪いのでゆるしてください)
あと、前にも質問しましたが関数の省略値(0)を判断する良い方法があれば
あわせてご教授いただきたいと思います。
長いのでURLを貼らせていただきますが問題ならば管理人さんに削除を
お願いいたします。
http://fortunehill.ld.infoseek.co.jp/sample/uhsp3.lzh
APIの羅列でここまで出来ましたが
初心者なので問題点や間違った使用法などが察知できませんよろしければ
助言などいただければ嬉しいです。
(Classにしなさいは能力的に見通しが悪いのでゆるしてください)
あと、前にも質問しましたが関数の省略値(0)を判断する良い方法があれば
あわせてご教授いただきたいと思います。
長いのでURLを貼らせていただきますが問題ならば管理人さんに削除を
お願いいたします。
http://fortunehill.ld.infoseek.co.jp/sample/uhsp3.lzh
> そんなにHSPが好きならABを使わずとも初めからHSP使えばいいじゃん。
> って言っちゃいけない暗黙の了解?
おっしゃる通りですが、好き嫌いの問題では無く
ABは従来のBASIC感覚ではとっつき難い構文なのでもう少しBASIC感覚で利用
したいと思い
HSPのフォーム・バッファ・オブジェクト管理方法を真似しました
しかしHSPとABは全く異なった言語なので
関数名を似せた物マクロだと思って頂いたほうがいいと思います。
(HSPも従来のBASICとは程遠いですが)
これがある程度安定してHSPからABへの足がかりになればと思いますが
ABを普通に利用している方には意味のない物だと言うのも事実でしょう。
(特に現状はGDI・CONTROL関係の扱いのみですから)
> って言っちゃいけない暗黙の了解?
おっしゃる通りですが、好き嫌いの問題では無く
ABは従来のBASIC感覚ではとっつき難い構文なのでもう少しBASIC感覚で利用
したいと思い
HSPのフォーム・バッファ・オブジェクト管理方法を真似しました
しかしHSPとABは全く異なった言語なので
関数名を似せた物マクロだと思って頂いたほうがいいと思います。
(HSPも従来のBASICとは程遠いですが)
これがある程度安定してHSPからABへの足がかりになればと思いますが
ABを普通に利用している方には意味のない物だと言うのも事実でしょう。
(特に現状はGDI・CONTROL関係の扱いのみですから)
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
長すぎて途中で切れてしまいました。
雛形とサンプルです。
コード: 全て選択
'|============================================================================|
'|=================================================[ ]=====|
'|============================================================================|
'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
'|============================================================================|
'|============================================================================|
'|============================================================================|
念のため上の部分を再書き込み。
管理人さま「2005年10月23日(日) 18:19」のレスの削除をお願いいたします。
管理人さま「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
Uhsp3.10β ActiveBasiv/Sample/TextEditor の真似ごとサンプルですが
コンパイルには別途「Uhsp3.10」が必要です。
(上記ファイルのsrcフォルダにコンパイル済みのサンプルあり)
コンパイルには別途「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
'|============================================================================|
'|============================================================================|
'|============================================================================|
VisualBasicライクなファイル選択方式のビットマップビューアーサンプル
です。
コンパイルには別途「Uhsp3.10」が必要ですがダウンロードされた「Uhsp3.lzh」に「Uhsp0011.exe」コンパイル済み実行形式があります。
です。
コンパイルには別途「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
'|============================================================================|
'|============================================================================|
'|============================================================================|
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を羅列しただけの物なので参考になるか否かは不明
です。
ほぼ移植が完了しました。
(同じ場所に Uhsp5.lzh があります。:この板の上の方のURLから参照可能)
ActiveBasicとFreeBasicは殆ど似た構文なので修正箇所の大部分は、
1.配列の[ ]を( )へ
2.BytePtrからzString ptr 又は Byte Ptr へ
3.行の継続(_省略) , を正式に ,_ へ
4.大文字小文字が同一扱の混乱を修正
5.関数の仮引数に初期値が設定できるので判断部分の修正・削除
6.戻り値が文字列の関数は受けが無いとエラーなのでポインター扱いにし
MakeStr or * で取得に修正
のみでした。
再三言いますが素人がAPIを羅列しただけの物なので参考になるか否かは不明
です。