谁会在Picture控件里实现这个颜色的渐变填充

[liangzhunyu]

如下图
http://www.jmty.com.cn/images/pic.gif

[lndlwwh830]

用peset
你自己试试吧··
Option Explicit

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

Dim pos As Long
pos = InStr(1, Me.Caption, ": ")
Me.Caption = IIf(pos > 0, Left$(Me.Caption, pos + 1), Me.Caption & ": ") & Format(Time, "#,##0.0000") & "|" & Format(MinTime, "#,##0.0000")

End Sub

'绘制
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

End Sub

[northwolves]

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

[猪头堂主]

把楼上的Picture1.Line (0, I)-(255, I), RGB(I, I, 255)改为Picture1.Line (I, 0)-(I, 255)才像上面给出的图

[cso]

楼上的代码虽不多，不过用vb实现这种图象效率可能比较差一点。
用这个很不错，尽管代码比较多，但是速度相当快。满屏幕的画速度是非常快的，几乎看不出来，但是VB就.......：

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: [e-mail]
'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