Option Explicit
Private Type TRIVERTEX
x As Long
y As Long
Red As Integer 'Ushort value
Green As Integer 'Ushort value
Blue As Integer 'ushort value
Alpha As Integer 'ushort
End Type
Private Type GRADIENT_RECT
UpperLeft As Long 'In reality this is a UNSIGNED Long
LowerRight As Long 'In reality this is a UNSIGNED Long
End Type
Const GRADIENT_FILL_RECT_H As Long = &H0 'In this mode, two endpoints describe a rectangle. The rectangle is
'defined to have a constant color (specified by the TRIVERTEX structure) for the left and right edges. GDI interpolates
'the color from the top to bottom edge and fills the interior.
Const GRADIENT_FILL_RECT_V As Long = &H1 'In this mode, two endpoints describe a rectangle. The rectangle
' is defined to have a constant color (specified by the TRIVERTEX structure) for the top and bottom edges. GDI interpolates
' the color from the top to bottom edge and fills the interior.
Const GRADIENT_FILL_TRIANGLE As Long = &H2 'In this mode, an array of TRIVERTEX structures is passed to GDI
'along with a list of array indexes that describe separate triangles. GDI performs linear interpolation between triangle vertices
'and fills the interior. Drawing is done directly in 24- and 32-bpp modes. Dithering is performed in 16-, 8.4-, and 1-bpp mode.
Const GRADIENT_FILL_OP_FLAG As Long = &HFF
Private Declare Function GradientFillRect Lib "msimg32" Alias "GradientFill" (ByVal hdc As Long, pVertex As TRIVERTEX, ByVal dwNumVertex As Long, pMesh As GRADIENT_RECT, ByVal dwNumMesh As Long, ByVal dwMode As Long) As Long
Private Function LongToUShort(Unsigned As Long) As Integer
'A small function to convert from long to unsigned short
LongToUShort = CInt(Unsigned - &H10000)
End Function
Private Sub Form_Load()
'KPD-Team 1999
'URL: http://www.allapi.net/
'E-Mail: KPDTeam@Allapi.net
'API uses pixels
Picture1.ScaleMode = vbPixels
End Sub
Private Sub Picture1_Paint()
Dim vert(1) As TRIVERTEX
Dim gRect As GRADIENT_RECT
'from black
With vert(0)
.x = 0
.y = 0
.Red = 0&
.Green = 0& '& '0&
.Blue = 0&
.Alpha = 0&
End With
'to blue
With vert(1)
.x = Picture1.ScaleWidth
.y = Picture1.ScaleHeight
.Red = 0&
.Green = 0&
.Blue = LongToUShort(&HFF00&)
.Alpha = 0&
End With
gRect.UpperLeft = 0
gRect.LowerRight = 1
GradientFillRect Picture1.hdc, vert(0), 2, gRect, 1, GRADIENT_FILL_RECT_H
End Sub
Private Sub Command1_Click()
Dim I As Integer
Picture1.Scale (0, 0)-(255, 255)
For I = 0 To 255
Picture1.Line (0, I)-(255, I), RGB(I, I, 255)
Next
End Sub
Private Declare Function InvalidateRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT, ByVal bErase As Long) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long
Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
Private mInit As Boolean
Private mFrequency As Currency
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long
Private Const ImgWidth As Long = &H100
Private Const ImgHeight As Long = &H100
'用高精度计时器得到当前时间
'单位:毫秒
Public Function GetCurTime() As Currency
If mInit = False Then
If QueryPerformanceFrequency(mFrequency) = 0 Then
mFrequency = 0
End If
mInit = True
End If
If mFrequency <> 0 Then
Dim CurCount As Currency
Call QueryPerformanceCounter(CurCount)
GetCurTime = CurCount * 1000@ / mFrequency
'Debug.Print GetCurTime
Else
GetCurTime = GetTickCount()
End If
End Function
'显示时间
Private Sub ShowTime(ByVal Time As Currency)
Static MinTime As Currency
If MinTime = 0 Then MinTime = Timer
If Time < MinTime Then MinTime = Time
'绘制
Private Sub DrawIt()
Dim I As Long, J As Long
Static K As Long
For I = 0 To ImgHeight - 1 'Y
For J = 0 To ImgWidth - 1 'X
Me.PSet (J, I), RGB(J And &HFF, I And &HFF, (J + K) And &HFF)
Next J
Next I
K = (K + 1) And &HFF
End Sub
Private Sub Form_Load()
'
End Sub
Private Sub Form_Paint()
Dim t As Currency
t = GetCurTime()
Call DrawIt
t = GetCurTime() - t
Call ShowTime(t)
'故意设置无效区,使WM_PAINT(VB会转为Paint事件)能反复触发
Dim rct As RECT
rct.Left = 0
rct.Top = 0
rct.Right = 1
rct.Bottom = 1
Call InvalidateRect(Me.hWnd, rct, 0)
End Sub
Private Sub Form_Resize()
If Me.WindowState = 1 Then Exit Sub
On Error Resume Next
Dim tX As Single, tY As Single
tX = Me.ScaleX(Me.ScaleX(Me.Width, vbTwips, vbPixels) - Me.ScaleWidth + ImgWidth, vbPixels, vbTwips)
tY = Me.ScaleY(Me.ScaleY(Me.Height, vbTwips, vbPixels) - Me.ScaleHeight + ImgHeight, vbPixels, vbTwips)
If Me.Width < tX Then Me.Width = tX
If Me.Height < tY Then Me.Height = tY