一个简易界面UI的实现
本帖最后由 imperialeast 于 2026-7-8 09:42 编辑Option Explicit
'作者:夏*
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Const GWL_WNDPROC = (-4)
Private Const GWL_STYLE = (-16)
Private Const WS_CAPTION = &HC00000 'WS_BORDER Or WS_DLGFRAME
Private Const WS_BORDER = &H800000
Private Const WS_OVERLAPPED = &H0&
Private Const WS_OVERLAPPEDWINDOW = (WS_OVERLAPPED Or WS_CAPTION)
Private Const WM_KEYDOWN = &H100
Private Const WM_MOUSEMOVE = &H200
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const WM_LBUTTONDBLCLK = &H203
Private Const WM_NCMOUSEMOVE = &HA0
Private Const WM_NCLBUTTONUP = &HA2
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const WM_NCLBUTTONDBLCLK = &HA3
Private Const WM_PAINT = &HF
Private Const WM_NCPAINT = &H85
Private Const WM_NCHITTEST = &H84
Private Const WM_SETCURSOR = &H20
Private Const WM_VSCROLL = &H115
Private Const WM_HSCROLL = &H114
Private Const WM_COMMAND = &H111
Private Const WM_CLOSE = &H10
Private Const HTCAPTION = 2
Private Const HTCLIENT = 1
Private Const SW_MINIMIZE = 6
Private Const VK_LBUTTON = &H1
Private Const VK_RBUTTON = &H2
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32" (Destination As Any, Source As Any, ByVal length As Long)
Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (Destination As Any, ByVal length As Long)
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal x1 As Long, ByVal y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long
'GDI
Private Const BI_RGB = 0&
Private Const TRANSPARENT = 1
Private Type BITMAPINFOHEADER
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type BITMAPFILEHEADER
bfType As Integer '位图文件的类型，必须为BM
bfsize As Long '位图文件的大小，以字节为单位
bfreserved1 As Integer '0
bfreserved2 As Integer '0
bfoffbits As Long '位图数据的起始位置，以相对于位图文件头的偏移量表示，以字节为单位
End Type
Private Type OVERLAPPED
Internal As Long
InternalHigh As Long
offset As Long
OffsetHigh As Long
hEvent As Long
End Type
Private Type SAFEARRAYBOUND
cElements As Long
lLbound As Long
End Type
Private Type SAFEARRAY2D
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As Long
Bounds(0 To 1) As SAFEARRAYBOUND
End Type
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hDC As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hDC As Long, ByVal nBkMode As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal H As Long, ByVal W As Long, ByVal E As Long, ByVal O As Long, _
ByVal W As Long, ByVal I As Long, ByVal u As Long, ByVal s As Long, _
ByVal C As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, _
ByVal PAF As Long, ByVal F As String) As Long
'Cursor
Private Const GCL_HCURSOR = (-12)
Private Declare Function SetClassLong Lib "user32.dll" Alias "SetClassLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetClassLong Lib "user32.dll" Alias "GetClassLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetCursor Lib "user32" (ByVal hCursor As Long) As Long
Private Declare Function LoadCursorFromFile Lib "user32.dll" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
'Private Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
'获取分辨率
Private Const SM_CYSCREEN = 1
Private Const SM_CXSCREEN = 0
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Const SPI_GETWORKAREA = 48
'Image BMP
Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal dwImageType As Long, ByVal dwDesiredWidth As Long, ByVal dwDesiredHeight As Long, ByVal dwFlags As Long) As Long
Private Const LR_LOADFROMFILE = &H10
Private Const LR_LOADMAP3DCOLORS = &H1000
'从指定的模块或应用程序实例中载入一幅位图。LoadBitmapBynum是LoadBitmap函数的类型安全声明
Private Declare Function LoadBitmap Lib "user32" Alias "LoadBitmapA" (ByVal hInstance As Long, ByVal lpBitmapName As String) As Long
'Call Back Message
Private Declare Function SafeArrayGetDim Lib "oleaut32" (ByRef saArray() As Any) As Long
Public Type URECT
Caption As String
ID As Long
Left As Long
Top As Long
Right As Long
Bottom As Long
Cursor As Long
OutRect As Boolean
PrevID As Long
HasOverAs Boolean
HasDown As Boolean
HasUp As Boolean
DownX As Long
DownY As Long
End Type
Public Type XForm
hDC As Long
hWnd As Long
lpRect As String
lpButton As String
XNormal As Long
XOver As Long
XDown As Long
XMask As Long
End Type
Public Type UIDRAWINFO
hDC As Long
Width As Long
Height As Long
Dat As Long
End Type
'Ubound()最大空间是127MB即133169152
Public lpPrevWndFunc As Long
Private HasREC As URECT, UREC() As URECT, hDC As Long, Width As Long, Height As Long
Public ByFuncAddress As Long, XF As XForm
Public Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim I As Long, Pram(1) As Long
Select Case uMsg
Case WM_PAINT, WM_NCPAINT
WindowProc = CallWindowProc(lpPrevWndFunc, hWnd, uMsg, wParam, lParam)
' 'Refresh
'DrawPicture hDC, UIBMP(0), 0, 0, UIBMP(0).Width, UIBMP(0).Height, 0, 0, UIBMP(0).Width, UIBMP(0).Height
DrawBmp XF.hDC, XF.XNormal, 0, 0, Width, Height, 0, 0
Exit Function
Case WM_SETCURSOR
'拦截光标设置,否则VB会自动修改
Exit Function
Case WM_MOUSEMOVE, WM_LBUTTONDOWN, WM_LBUTTONUP
WindowProc = CallWindowProc(lpPrevWndFunc, hWnd, uMsg, wParam, lParam)
Dim CurPos As POINTAPI, lpRect As RECT, WinState As Long, X As Long, Y As Long, MouseKeyAs Long, Rtn As Long ', lpRect2 As RECT
Rtn = GetCursorPos(CurPos)
Rtn = GetWindowRect(hWnd, lpRect)
WinState = GetWindowState(hWnd)
'GetClientRect hWnd, lpRect2
X = CurPos.X - lpRect.Left
Y = CurPos.Y - lpRect.Top
'查询鼠标按键
If GetAsyncKeyState(VK_LBUTTON) <> 0 Then
MouseKey = 1
ElseIf GetAsyncKeyState(VK_RBUTTON) <> 0 Then
MouseKey = 2
End If
If uMsg = WM_MOUSEMOVE Then
If WinState <> 1 Then
If HasREC.HasDown = True Then GoTo Over
If MouseKey = 1 And X > 0 And Y > 0 And X < 600 And Y < 26 Then
If HasREC.OutRect = True And HasREC.DownX < 600 And HasREC.DownY < 26 Then AnyMove hWnd
End If
For I = 0 To UBound(UREC)
If HasREC.ID <> UREC(I).ID And (UREC(I).HasOver = True Or UREC(I).HasDown = True) Then
DrawPicture XF.hDC, XF.XNormal, UREC(I).Left, UREC(I).Top, UREC(I).Right - UREC(I).Left, UREC(I).Bottom - UREC(I).Top, UREC(I).Left, UREC(I).Top, UREC(I).Right - UREC(I).Left, UREC(I).Bottom - UREC(I).Top
UREC(I).HasOver = False
End If
Next
Over:
For I = 0 To UBound(UREC)
'Debug.Print urec(I).Left & "," & urec(I).Right & "," & urec(I).Top & "," & urec(I).Bottom
If X > UREC(I).Left And X < UREC(I).Right And Y > UREC(I).Top And Y < UREC(I).Bottom Then
' SetWindowCursor hWnd, App.Path & "\" & UREC(I).tst此函数不适合频繁密集式使用,会造成句柄绘图内存溢出(Class Error)
SetCursor UREC(I).Cursor
' Debug.Print urec(I).Caption
If HasREC.ID <> UREC(I).ID Then
If HasREC.PrevID = UREC(I).ID Then
Call DrawPicture(XF.hDC, XF.XDown, UREC(I).Left, UREC(I).Top, UREC(I).Right - UREC(I).Left, UREC(I).Bottom - UREC(I).Top, UREC(I).Left, UREC(I).Top, UREC(I).Right - UREC(I).Left, UREC(I).Bottom - UREC(I).Top)
Else
If HasREC.HasDown <> True Then
Call DrawPicture(XF.hDC, XF.XOver, UREC(I).Left, UREC(I).Top, UREC(I).Right - UREC(I).Left, UREC(I).Bottom - UREC(I).Top, UREC(I).Left, UREC(I).Top, UREC(I).Right - UREC(I).Left, UREC(I).Bottom - UREC(I).Top)
UREC(I).HasOver = True
Else
DrawPicture XF.hDC, XF.XNormal, HasREC.Left, HasREC.Top, HasREC.Right - HasREC.Left, HasREC.Bottom - HasREC.Top, HasREC.Left, HasREC.Top, HasREC.Right - HasREC.Left, HasREC.Bottom - HasREC.Top
End If
End If
Else
End If
'LSet hasrec = urec(I)
With HasREC
.Left = UREC(I).Left
.Right = UREC(I).Right
.Top = UREC(I).Top
.Bottom = UREC(I).Bottom
.Caption = UREC(I).Caption
.Cursor = UREC(I).Cursor
.ID = UREC(I).ID
End With
Exit For
Else
If HasREC.ID = UREC(I).ID Then
Call DrawPicture(XF.hDC, XF.XNormal, UREC(I).Left, UREC(I).Top, UREC(I).Right - UREC(I).Left, UREC(I).Bottom - UREC(I).Top, UREC(I).Left, UREC(I).Top, UREC(I).Right - UREC(I).Left, UREC(I).Bottom - UREC(I).Top)
HasREC.ID = 0
Exit For
End If
End If
Next I
End If
End If
If uMsg = WM_LBUTTONDOWN Then
If WinState <> 1 Then
For I = 0 To UBound(UREC)
If X > UREC(I).Left And X < UREC(I).Right And Y > UREC(I).Top And Y < UREC(I).Bottom Then
UREC(I).HasDown = True
If HasREC.ID = UREC(I).ID Then
Call DrawPicture(XF.hDC, XF.XDown, UREC(I).Left, UREC(I).Top, UREC(I).Right - UREC(I).Left, UREC(I).Bottom - UREC(I).Top, UREC(I).Left, UREC(I).Top, UREC(I).Right - UREC(I).Left, UREC(I).Bottom - UREC(I).Top)
End If
HasREC.OutRect = False
HasREC.PrevID = UREC(I).ID
HasREC.HasDown = True
Exit For
Else
HasREC.OutRect = True
HasREC.DownX = X
HasREC.DownY = Y
'Exit For
End If
Next
End If
End If
If uMsg = WM_LBUTTONUP Then
If WinState <> 1 Then
For I = 0 To UBound(UREC)
'Debug.Print urec(I).Left & "," & urec(I).Right & "," & urec(I).Top & "," & urec(I).Bottom
If X > UREC(I).Left And X < UREC(I).Right And Y > UREC(I).Top And Y < UREC(I).Bottom Then
UREC(I).HasDown = False
'Me.Cls
If HasREC.OutRect = False And HasREC.PrevID = UREC(I).ID Then
'处理点击事件
'
If UREC(I).ID = 2 Then SendMessage hWnd, WM_CLOSE, 0, 0
If UREC(I).ID = 1 Then ShowWindow hWnd, SW_MINIMIZE
If UREC(I).ID < 9000000 And UREC(I).ID > 2 Then
'//建立数据通道
Pram(0) = UREC(I).ID
Pram(1) = StrPtr(UREC(I).Caption)
CallFuncByAddress ByFuncAddress, Pram
End If
If UREC(I).ID <> 2 Then DrawPicture XF.hDC, XF.XNormal, UREC(I).Left, UREC(I).Top, UREC(I).Right - UREC(I).Left, UREC(I).Bottom - UREC(I).Top, UREC(I).Left, UREC(I).Top, UREC(I).Right - UREC(I).Left, UREC(I).Bottom - UREC(I).Top
End If
Exit For
End If
Next
HasREC.PrevID = 0
HasREC.HasDown = False
End If
End If
' Case WM_NCMOUSEMOVE, WM_NCLBUTTONDOWN, WM_NCLBUTTONUP
'标题区域鼠标事件
' OnMouseEvents uMsg, 0, 0, 0
'Exit Function
' Case WM_NCLBUTTONDBLCLK
' Exit Function
'Case WM_NCHITTEST
Case Else
WindowProc = CallWindowProc(lpPrevWndFunc, hWnd, uMsg, wParam, lParam)
End Select
End Function
Public Function GetWindowState(ByVal hWnd As Long) As Long
Dim Rtn As Long, RCT As RECT, REC As RECT
Rtn = SystemParametersInfo(SPI_GETWORKAREA, vbNull, REC, 0)
Rtn = GetWindowRect(hWnd, RCT)
If RCT.Top = -32000 Then
GetWindowState = 1
ElseIf (RCT.Right - RCT.Left) >= GetSystemMetrics(SM_CXSCREEN) And (RCT.Bottom - RCT.Top) > (REC.Bottom - REC.Top) Then
GetWindowState = 2
Else
GetWindowState = 0
End If
End Function
Public Function SetMyWindow(XForm As XForm, Optional ByVal lpFunc As Long) As Long
Dim Rtn As Long, REC As RECT
lpPrevWndFunc = SetWindowLong(XForm.hWnd, GWL_WNDPROC, AddressOf WindowProc)
LSet XF = XForm
'Init Byval
XForm.lpButton = StrConv(XForm.lpButton, vbUnicode)
XForm.lpRect = StrConv(XForm.lpRect, vbUnicode)
hDC = GetWindowDC(XForm.hWnd)
XF.hDC = hDC
'ReSet Window Size
Rtn = GetWindowRect(XForm.hWnd, REC)
Rtn = GetBmpSize(GetBmpHandle(XForm.XNormal), Width, Height)
Rtn = SetWindowPos(XForm.hWnd, 1, REC.Left, REC.Top, (Width + 6), (Height + 6), &H20)
'Set Window Style
Rtn = GetWindowLong(XForm.hWnd, GWL_STYLE)
Rtn = Rtn And Not WS_BORDER '去除BORDER 标示
Call SetWindowLong(XForm.hWnd, GWL_STYLE, Rtn)
'Set Window Owner Style
CreateMyRECT XForm.hWnd, XForm.lpRect 'App.Path & "\face.ini"
CreateNewRect XForm.lpButton, UREC() 'App.Path & "\newface.ini"
ByFuncAddress = lpFunc
' On Error GoTo Err_SetMyWindow
'XiaYu
SetMyWindow = 1
Exit Function
Err_SetMyWindow:
SetMyWindow = -1
End Function
Public Sub Refresh()
'绘制窗体
'If MainCur <> 0 Then
' SetCursor MainCur
'End If
DrawBmp XF.hDC, XF.XNormal, 0, 0, Width, Height, 0, 0
'绘制窗体背景
' UIBMP(3).Blt 0, 0, UIBMP(3).Width, UIBMP(3).Height, UIBMP(0)
' DrawPicture XF.hDC, XF.XNormal, 0, 0, Width, Height, 0, 0, XF.XNormal, Width, Height
'For I = 1 To m_Controls.Count
' m_Controls.Item(I).Render
' Next
'UIBMP(3).Render hDC
End Sub
Public Function UnHook(ByVal hWnd As Long) As Long
UnHook = SetWindowLong(hWnd, GWL_WNDPROC, lpPrevWndFunc)
End Function
'// Draw Bmp
Private Function DrawPicture(ByVal hDC As Long, ByVal hPicture As Long, ByVal PosX As Long, ByVal PosY As Long, ByVal Width As Long, ByVal Height As Long, ByVal hPicX As Long, ByVal hPicY As Long, ByVal hPictureW As Long, ByVal hPictureH As Long) As Long
Dim DC As Long, Obj As Long, SBlt As Long, Rtn As Long
On Error GoTo Draw_PIC:
DC = CreateCompatibleDC(0)
Obj = SelectObject(DC, hPicture)
SBlt = StretchBlt(hDC, PosX, PosY, Width, Height, DC, hPicX, hPicY, hPictureW, hPictureH, vbSrcCopy)
Rtn = DeleteObject(Obj)
Rtn = DeleteObject(SBlt)
Rtn = DeleteDC(DC)
DrawPicture = 1
Exit Function
Draw_PIC:
DrawPicture = -1
End Function
'// Draw Bmp
Private Function DrawBmp(ByVal hDC As Long, ByVal hPicture As Long, ByVal PosX As Long, ByVal PosY As Long, ByVal Width As Long, ByVal Height As Long, ByVal hPicX As Long, ByVal hPicY As Long) As Long
Dim DC As Long, Obj As Long, SBlt As Long, Rtn As Long
On Error GoTo Draw_PIC:
DC = CreateCompatibleDC(0)
Obj = SelectObject(DC, hPicture)
SBlt = BitBlt(hDC, PosX, PosY, Width, Height, DC, hPicX, hPicY, vbSrcCopy)
Rtn = DeleteObject(Obj)
Rtn = DeleteObject(SBlt)
Rtn = DeleteDC(DC)
DrawBmp = 1
Exit Function
Draw_PIC:
DrawBmp = -1
End Function
Private Function DrawBmpA(ByVal hDC As Long, ByVal xDC As Long, ByVal PosX As Long, ByVal PosY As Long, ByVal Width As Long, ByVal Height As Long, ByVal hPicX As Long, ByVal hPicY As Long) As Long
Dim SBlt As Long, Rtn As Long
On Error GoTo Draw_PIC:
SBlt = BitBlt(hDC, PosX, PosY, Width, Height, xDC, hPicX, hPicY, vbSrcCopy)
Rtn = DeleteObject(SBlt)
DrawBmpA = 1
Exit Function
Draw_PIC:
DrawBmpA = -1
End Function
Private Function IsStop(ByVal lTime As Long) As Boolean
Dim UseT As Long
UseT = 0
UseT = GetTickCount
Do Until GetTickCount - UseT > lTime
DoEvents
Loop
IsStop = True
End Function
Sub CreateMyRECT(ByVal hWnd As Long, ByVal FileName As String)
Dim hForm As Long, hFormRgn As Long, Rtn As Long
Dim uStr As String, lStr As String, StrX() As String, Data() As String, I As Integer
On Error Resume Next
hForm = CreateRectRgn(0, 0, 0, 0)
Open FileName For Input As #1
Do While Not EOF(1)
Line Input #1, lStr
If lStr <> "" Then
uStr = uStr & lStr & vbCrLf
End If
Loop
Close #1
StrX = Split(uStr, vbCrLf)
For I = 0 To UBound(StrX) - 1
Data = Split(StrX(I), ",")
If UBound(Data) = 3 Then
hFormRgn = CreateRectRgn(Data(0), Data(1), Data(2), Data(3) + 1)
Rtn = CombineRgn(hForm, hForm, hFormRgn, 2)
Rtn = DeleteObject(hFormRgn)
End If
Next I
Rtn = SetWindowRgn(hWnd, hForm, True)
Rtn = DeleteObject(hForm)
End Sub
Sub CreateNewRect(ByVal FileName As String, URECT() As URECT)
Dim tCursor As Long, A As String, B As String, Dat() As String, Data()As String, I As Integer
Dim lpCursor As String
lpCursor = Left(FileName, InStrRev(FileName, "\"))
Open FileName For Input As #1
Do Until EOF(1)
Line Input #1, A
If A <> "" And InStr(UCase(A), "BUTTON") <> 0 And InStr(UCase(A), "BUTTONNUM") = 0 And InStr(UCase(A), "=") <> 0 Then
A = Right(A, Len(A) - InStr(1, A, "="))
B = B & A & vbCrLf
End If
Loop
Close #1
Dat = Split(B, vbCrLf)
For I = 0 To UBound(Dat) - 1
Data = Split(Dat(I), ",")
ReDim Preserve URECT(I) As URECT
With URECT(I)
.ID = CLng(Data(0))
.Left = CLng(Data(1))
.Top = CLng(Data(2))
.Right = CLng(Data(3))
.Bottom = CLng(Data(4))
.Caption = Trim(Data(5))
.Cursor = LoadCursorFromFile(lpCursor & Data(6))
End With
Next
End Sub
Private Function SetWindowCursor(ByVal hWnd As Long, ByVal CursorPos As String) As Long
Dim Rtn As Long, handle As Long
handle = LoadCursorFromFile(CursorPos)
Rtn = SetClassLong(hWnd, GCL_HCURSOR, handle)
SetWindowCursor = Rtn
End Function
Private Function AnyMove(ByVal hWnd As Long) As Long
Dim Rtn As Long
ReleaseCapture
Rtn = SendMessage(hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
AnyMove = Rtn
End Function
Public Function GetBmpHandle(ByVal Pram As Variant, Optional ByVal Width As Long, Optional ByVal Height As Long) As Long
Dim hBmp As Long
If TypeName(Pram) = "Long" Then
GetBmpHandle = Pram
Else
If TypeName(Pram) = "String" Then
hBmp = GetPictureHandle(Pram, Width, Height)
If hBmp = 0 Then
GetBmpHandle = LoadBitmap(4194304, Pram)
Else
GetBmpHandle = hBmp
End If
Else
GetBmpHandle = -1
End If
End If
End Function
Private Function GetPictureHandle(ByVal lpStr As String, Optional ByVal Width As Long, Optional ByVal Height As Long) As Long
If lpStr = "" Then
GetPictureHandle = -1: Exit Function
Else
GetPictureHandle = LoadImage(4194304, lpStr, 0, Width, Height, LR_LOADFROMFILE Or LR_LOADMAP3DCOLORS)
End If
End Function
'// Get Bmp Width And Height
Public Function GetBmpSize(ByVal BmpFile As Variant, ByRef Width As Long, ByRef Height As Long) As Long
Dim hBmpAs Long, BMP As BITMAP, Rtn As Long
On Error GoTo GetBMP
hBmp = GetBmpHandle(BmpFile)
Rtn = GetObject(hBmp, Len(BMP), BMP)
Width = BMP.bmWidth
Height = BMP.bmHeight
hBmp = 0
GetBmpSize = 1
Exit Function
GetBMP:
GetBmpSize = -1
End Function
Public Function CallFuncByAddress(ByVal Address As Long, Parameter() As Long) As Long
Dim OptionCode() As Byte, OptionIndex As Long, CodeLen As Long, CodeStart As Long, I As Long
If Address = 0 Then Exit Function
'// Get Code Length
If SafeArrayGetDim(Parameter) Then
CodeLen = UBound(Parameter) - LBound(Parameter) + 1
Else
CodeLen = 0
End If
If SafeArrayGetDim(Parameter) Then
ReDim OptionCode(8 + (5 * CodeLen))
Else
ReDim OptionCode(0 To 7)
End If
If Address <> 0 Then
'// VarPtr Get Func Address
CodeStart = VarPtr(OptionCode(0))
'// Start Position
OptionIndex = 0
'// Push Parameter '由于是stdcall CALL 参数由最后一个开始放到堆栈
If SafeArrayGetDim(Parameter) Then
For I = UBound(Parameter) To LBound(Parameter) Step -1
'//Push 的机器码为 H68 Use "Push" Order
OptionCode(OptionIndex) = &H68
OptionIndex = OptionIndex + 1
'Change Data To Byte=Address
RtlMoveMemory OptionCode(OptionIndex), Parameter(I), 4
OptionIndex = OptionIndex + 4
Next
End If
'//Call 的机器码为 HE8 'Use "Call" Order
OptionCode(OptionIndex) = &HE8
OptionIndex = OptionIndex + 1
'// 函数地址 用call的定址
Call RtlMoveMemory(OptionCode(OptionIndex), Address - VarPtr(OptionCode(OptionIndex)) - 4, 4)
OptionIndex = OptionIndex + 4
'-----------结束程序操作--------------
'Back Call Function
'// 10h
OptionCode(OptionIndex) = &HC2
OptionIndex = OptionIndex + 1
'//&H10
OptionCode(OptionIndex) = &H10
OptionIndex = OptionIndex + 1
'//&H0
OptionCode(OptionIndex) = &H0
OptionIndex = OptionIndex + 1
CallFuncByAddress = CallWindowProc(CodeStart, 0, 1, 2, 3)
End If
End Function
本帖最后由 imperialeast 于 2026-7-8 09:40 编辑
:D 代码文件在这里 代码文件在这里
直接贴上去的代码格式很奇葩,缩进太大,你试过用编辑器上的代码插入按钮吗? 为什么不用 编辑器中的"添加代码文字"功能插入代码呢?
JavaScript:alert("书签脚本"); bwz26452938 发表于 2026-7-27 12:21
直接贴上去的代码格式很奇葩,缩进太大,你试过用编辑器上的代码插入按钮吗? ...
我直接粘贴的 imperialeast 发表于 2026-7-27 13:38
我直接粘贴的
有时候编辑器的某些隐式转换会破坏代码内容,还是建议使用 编辑器中的"添加代码文字"功能插入代码
页:
[1]