www.pc3enter.tk
چهارشنبه 06 مرداد 1395, 12:13 عصر
'=========Gdi32 Api========
Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function GdiAlphaBlend Lib "gdi32.dll" (ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT As Long) As Long
Private Declare Function CreatePen Lib "gdi32.dll" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32.dll" (ByVal crColor As Long) As Long
'=========user32 Api========
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long
'=========Oleaut32 Api========
Private Declare Function OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor As Long, ByVal lHPalette As Long, ByVal lColorRef As Long) As Long
'=========Kernel32 Api========
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Type UcsRgbQuad
R As Byte
G As Byte
B As Byte
a As Byte
End Type
Private Type BLENDFUNCTION
BlendOp As Byte
BlendFlags As Byte
SourceConstantAlpha As Byte
AlphaFormat As Byte
End Type
Private Sub DrawAlphaSelection(hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal Width As Long, ByVal Height As Long, ByVal Color As OLE_COLOR)
Dim BF As BLENDFUNCTION
Dim hDCMemory As Long
Dim hBmp As Long
Dim hOldBmp As Long
Dim DC As Long
Dim lColor As Long
Dim hPen As Long
Dim hBrush As Long
Dim lBF As Long
BF.SourceConstantAlpha = 128
DC = GetDC(0)
hDCMemory = CreateCompatibleDC(0)
hBmp = CreateCompatibleBitmap(DC, Width, Height)
hOldBmp = SelectObject(hDCMemory, hBmp)
hPen = CreatePen(0, 1, Color)
hBrush = CreateSolidBrush(pvAlphaBlend(Color, vbWhite, 120))
DeleteObject SelectObject(hDCMemory, hBrush)
DeleteObject SelectObject(hDCMemory, hPen)
Rectangle hDCMemory, 0, 0, Width, Height
CopyMemory VarPtr(lBF), VarPtr(BF), 4
GdiAlphaBlend hdc, X, Y, Width, Height, hDCMemory, 0, 0, Width, Height, lBF
SelectObject hDCMemory, hOldBmp
DeleteObject hBmp
ReleaseDC 0&, DC
DeleteDC hDCMemory
DeleteObject hPen
DeleteObject hBrush
End Sub
Private Function pvAlphaBlend(ByVal clrFirst As Long, ByVal clrSecond As Long, ByVal lAlpha As Long) As Long
Dim clrFore As UcsRgbQuad
Dim clrBack As UcsRgbQuad
OleTranslateColor clrFirst, 0, VarPtr(clrFore)
OleTranslateColor clrSecond, 0, VarPtr(clrBack)
With clrFore
.R = (.R * lAlpha + clrBack.R * (255 - lAlpha)) / 255
.G = (.G * lAlpha + clrBack.G * (255 - lAlpha)) / 255
.B = (.B * lAlpha + clrBack.B * (255 - lAlpha)) / 255
End With
CopyMemory VarPtr(pvAlphaBlend), VarPtr(clrFore), 4
End Function
Private Sub Form_Paint()
Cls
DrawAlphaSelection Me.hdc, 10, 50, 100, 200, vbRed
DrawAlphaSelection Me.hdc, 50, 30, 200, 100, vbBlue
DrawAlphaSelection Me.hdc, 200, 80, 100, 100, vbGreen
DrawAlphaSelection Me.hdc, 80, 200, 200, 30, vbYellow
DrawAlphaSelection Me.hdc, 130, 70, 50, 200, vbMagenta
End Sub
این کد دیگری هست فقط یک اسکرول باید به صفحه اضافه کنید
Option ExplicitPrivate Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function CreatePatternBrush Lib "gdi32.dll" (ByVal hBitmap As Long) As Long
Private Declare Function SetPixelV Lib "gdi32.dll" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Private Declare Function RoundRect Lib "gdi32.dll" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
Private Declare Function CreatePen Lib "gdi32.dll" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor 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 OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor As Long, ByVal lHPalette As Long, ByVal lColorRef As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Type UcsRgbQuad
R As Byte
G As Byte
B As Byte
a As Byte
End Type
Private Sub DrawSelectionEx(DestDC As Long, DestX As Long, DestY As Long, DestWidth As Long, DestHeight As Long, oColorStar As Long, oColorEnd As Long)
Dim DC As Long, hDCMemory As Long, hBmp As Long
Dim hPen1 As Long, hPen2 As Long, hBrush As Long
Dim OldhBmp As Long, OldhPen As Long, OldhBrush As Long
Dim DivValue As Double
Dim i As Long
hPen1 = CreatePen(0, 1, pvAlphaBlend(vbBlack, oColorEnd, 10))
hPen2 = CreatePen(0, 1, pvAlphaBlend(oColorStar, vbWhite, 10))
DC = GetDC(0)
hDCMemory = CreateCompatibleDC(0)
hBmp = CreateCompatibleBitmap(DC, 1, DestHeight)
OldhBmp = SelectObject(hDCMemory, hBmp)
For i = 1 To DestHeight
DivValue = ((i * 255) / DestHeight)
SetPixelV hDCMemory, 0, i, pvAlphaBlend(oColorEnd, oColorStar, DivValue)
Next
hBrush = CreatePatternBrush(hBmp)
DeleteObject hBmp
hBmp = CreateCompatibleBitmap(DC, DestWidth, DestHeight)
Call SelectObject(hDCMemory, hBmp)
BitBlt hDCMemory, 0, 0, DestWidth, DestHeight, DestDC, DestX, DestY, vbSrcCopy
OldhPen = SelectObject(hDCMemory, hPen1)
RoundRect hDCMemory, 0, 0, DestWidth, DestHeight, 9, 9
Call SelectObject(hDCMemory, hPen2)
OldhBrush = SelectObject(hDCMemory, hBrush)
RoundRect hDCMemory, 1, 1, DestWidth - 1, DestHeight - 1, 8, 8
BitBlt DestDC, DestX, DestY, DestWidth, DestHeight, hDCMemory, 0, 0, vbSrcCopy
' Descargamos todo
SelectObject hDCMemory, OldhPen
SelectObject hDCMemory, OldhBrush
SelectObject hDCMemory, OldhBmp
DeleteObject hPen1
DeleteObject hPen2
DeleteObject hBrush
DeleteObject hBmp
ReleaseDC 0&, DC
DeleteDC hDCMemory
End Sub
Private Function pvAlphaBlend(ByVal clrFirst As Long, ByVal clrSecond As Long, ByVal lAlpha As Long) As Long
Dim clrFore As UcsRgbQuad
Dim clrBack As UcsRgbQuad
OleTranslateColor clrFirst, 0, VarPtr(clrFore)
OleTranslateColor clrSecond, 0, VarPtr(clrBack)
With clrFore
.R = (.R * lAlpha + clrBack.R * (255 - lAlpha)) / 255
.G = (.G * lAlpha + clrBack.G * (255 - lAlpha)) / 255
.B = (.B * lAlpha + clrBack.B * (255 - lAlpha)) / 255
End With
CopyMemory VarPtr(pvAlphaBlend), VarPtr(clrFore), 4
End Function
Private Sub Form_Load()
Me.ScaleMode = vbPixels
Me.FontSize = 12
Me.BackColor = vbWhite
Me.Width = 8500
Me.Height = 8700
HScroll1.Max = 255
HScroll1.Value = 70
HScroll1.Move 320, 210, 230, 30
End Sub
Private Sub Form_Paint()
Dim i As Integer
DrawSelectionEx Me.hdc, 320, 10, 100, 100, RGB(249, 253, 255), RGB(234, 247, 255)
DrawSelectionEx Me.hdc, 440, 10, 100, 100, RGB(251, 251, 251), RGB(231, 231, 231)
For i = 0 To 15
DrawSelectionEx Me.hdc, 10, 10 + (i * 35), 300, 30, Me.BackColor, pvAlphaBlend(QBColor(i), Me.BackColor, HScroll1.Value)
Next
DrawSelectionEx Me.hdc, 320, 120, 220, 70, Me.BackColor, pvAlphaBlend(vbHighlight, Me.BackColor, 50)
Me.CurrentX = 330
Me.CurrentY = 145
Me.Print "hi barnamenevis.org"
End Sub
Private Sub HScroll1_Change()
Form_Paint
End Sub
به شکل دایره
Option Explicit
Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hdc As Long, ByRef graphics As Long) As Long
Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As Long) As Long
Private Declare Function GdiplusStartup Lib "gdiplus" (ByRef token As Long, ByRef lpInput As GDIPlusStartupInput, Optional ByRef lpOutput As Any) As Long
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long
Private Declare Function GdipSetSmoothingMode Lib "GdiPlus.dll" (ByVal mGraphics As Long, ByVal mSmoothingMode As Long) As Long
Private Declare Function GdipDeleteBrush Lib "GdiPlus.dll" (ByVal mBrush As Long) As Long
Private Declare Function GdipFillEllipseI Lib "GdiPlus.dll" (ByVal mGraphics As Long, ByVal mBrush As Long, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GdipCreatePath Lib "GdiPlus.dll" (ByVal mBrushMode As Long, ByRef mPath As Long) As Long
Private Declare Function GdipDeletePath Lib "GdiPlus.dll" (ByVal mPath As Long) As Long
Private Declare Function GdipCreateLineBrushFromRectI Lib "GdiPlus.dll" (ByRef mRect As RECTL, ByVal mColor1 As Long, ByVal mColor2 As Long, ByVal mMode As LinearGradientMode, ByVal mWrapMode As WrapMode, ByRef mLineGradient As Long) As Long
Private Declare Function GdipAddPathEllipseI Lib "GdiPlus.dll" (ByVal mPath As Long, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long) As Long
Private Declare Function GdipSetPathGradientCenterColor Lib "GdiPlus.dll" (ByVal mBrush As Long, ByVal mColors As Long) As Long
Private Declare Function GdipSetPathGradientSurroundColorsWithCount Lib "GdiPlus.dll" (ByVal mBrush As Long, ByRef mColor As Long, ByRef mCount As Long) As Long
Private Declare Function GdipCreatePathGradientFromPath Lib "GdiPlus.dll" (ByVal mPath As Long, ByRef mPolyGradient As Long) As Long
Private Declare Function GdipSetLinePresetBlend Lib "GdiPlus.dll" (ByVal mBrush As Long, ByRef mBlend As Long, ByRef mPositions As Single, ByVal mCount As Long) As Long
Private Declare Function OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor As Long, ByVal lHPalette As Long, ByVal lColorRef As Long) As Long
Private Type RECTL
Left As Long
Top As Long
Width As Long
Height As Long
End Type
Private Enum LinearGradientMode
LinearGradientModeHorizontal = &H0
LinearGradientModeVertical = &H1
LinearGradientModeForwardDiagonal = &H2
LinearGradientModeBackwardDiagonal = &H3
End Enum
Private Enum WrapMode
WrapModeTile = &H0
WrapModeTileFlipX = &H1
WrapModeTileFlipy = &H2
WrapModeTileFlipXY = &H3
WrapModeClamp = &H4
End Enum
Private Type GDIPlusStartupInput
GdiPlusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Const SmoothingModeAntiAlias As Long = &H4
Dim GdipToken As Long
Private Sub Form_Load()
Call InitGDI
Me.AutoRedraw = True
DrawSphere Me.hdc, vbBlue, 10, 20, 150, 150
DrawSphere Me.hdc, vbGreen, 180, 20, 150, 150
DrawSphere Me.hdc, vbRed, 350, 20, 150, 150
DrawSphere Me.hdc, vbYellow, 10, 210, 150, 150
DrawSphere Me.hdc, vbBlack, 180, 210, 150, 150
DrawSphere Me.hdc, vbMagenta, 350, 210, 150, 150
DrawSphere Me.hdc, vbCyan, 10, 400, 150, 150
DrawSphere Me.hdc, vbWhite, 180, 400, 150, 150
DrawSphere Me.hdc, &H99FF&, 350, 400, 150, 150
End Sub
Private Sub Form_Unload(Cancel As Integer)
Call TerminateGDI
End Sub
Public Function DrawSphere(ByVal hdc As Long, _
ByVal lColor As Long, _
ByVal X As Long, _
ByVal Y As Long, _
ByVal Width As Long, _
ByVal Height As Long, _
Optional ByVal bDrawShadow As Boolean = True, _
Optional ByVal lAlpha As Long = 100) As Boolean
Dim hGraphics As Long
Dim hBrush As Long
Dim mPath As Long
Dim mRect As RECTL
Dim col(2) As Long
Dim pos(2) As Single
If GdipCreateFromHDC(hdc, hGraphics) = 0 Then
Call GdipSetSmoothingMode(hGraphics, SmoothingModeAntiAlias)
' ----------------------------- Shadow -------------------------------------
If bDrawShadow Then
Call GdipCreatePath(&H0, mPath)
GdipAddPathEllipseI mPath, X, Y + Height / 1.1, Width, Height / 4
GdipCreatePathGradientFromPath mPath, hBrush
GdipSetPathGradientCenterColor hBrush, ConvertColor(lColor, lAlpha / 3)
GdipSetPathGradientSurroundColorsWithCount hBrush, 0, 1
Call GdipFillEllipseI(hGraphics, hBrush, X, Y + Height / 1.1, Width, Height / 4)
Call GdipDeleteBrush(hBrush)
Call GdipDeletePath(mPath)
End If
'----------------------------- Sphere -------------------------------------
Call GdipCreatePath(&H0, mPath)
GdipAddPathEllipseI mPath, X - (Width / 1.75), Y - Height / 2, Width * 2, Height * 2
GdipCreatePathGradientFromPath mPath, hBrush
GdipSetPathGradientCenterColor hBrush, ConvertColor(lColor, lAlpha)
GdipSetPathGradientSurroundColorsWithCount hBrush, ConvertColor(ShiftColor(lColor, vbBlack, 100), lAlpha), 1
Call GdipFillEllipseI(hGraphics, hBrush, X, Y, Width, Height)
Call GdipDeleteBrush(hBrush)
Call GdipDeletePath(mPath)
'----------------------------- Light -------------------------------------
mRect.Left = X + Width / 10
mRect.Top = Y + Height / 50
mRect.Width = Width - Width / 5
mRect.Height = Height / 1.5
GdipCreateLineBrushFromRectI mRect, 0, 0, LinearGradientModeVertical, WrapModeTileFlipy, hBrush
col(0) = ConvertColor(vbWhite, lAlpha / 1.25)
col(1) = 0
col(2) = 0
pos(0) = 0
pos(1) = 0.6
pos(2) = 1
Call GdipSetLinePresetBlend(hBrush, col(0), pos(0), 3)
Call GdipFillEllipseI(hGraphics, hBrush, mRect.Left, mRect.Top, mRect.Width, mRect.Height - 1)
Call GdipDeleteBrush(hBrush)
' ------------------------------------------------------------------------
Call GdipDeleteGraphics(hGraphics)
End If
End Function
Private Function ConvertColor(Color As Long, Opacity As Long) As Long
Dim BGRA(0 To 3) As Byte
BGRA(3) = CByte((Abs(Opacity) / 100) * 255)
BGRA(0) = ((Color \ &H10000) And &HFF)
BGRA(1) = ((Color \ &H100) And &HFF)
BGRA(2) = (Color And &HFF)
CopyMemory ConvertColor, BGRA(0), 4&
End Function
Private Function ShiftColor(ByVal clrFirst As Long, ByVal clrSecond As Long, ByVal lAlpha As Long) As Long
Dim clrFore(3) As Byte
Dim clrBack(3) As Byte
OleTranslateColor clrFirst, 0, VarPtr(clrFore(0))
OleTranslateColor clrSecond, 0, VarPtr(clrBack(0))
clrFore(0) = (clrFore(0) * lAlpha + clrBack(0) * (255 - lAlpha)) / 255
clrFore(1) = (clrFore(1) * lAlpha + clrBack(1) * (255 - lAlpha)) / 255
clrFore(2) = (clrFore(2) * lAlpha + clrBack(2) * (255 - lAlpha)) / 255
CopyMemory ShiftColor, clrFore(0), 4
End Function
Private Sub InitGDI()
Dim GdipStartupInput As GDIPlusStartupInput
GdipStartupInput.GdiPlusVersion = 1&
Call GdiplusStartup(GdipToken, GdipStartupInput, ByVal 0)
End Sub
Private Sub TerminateGDI()
Call GdiplusShutdown(GdipToken)
End Sub
تشکر یادتون نره
Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function GdiAlphaBlend Lib "gdi32.dll" (ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT As Long) As Long
Private Declare Function CreatePen Lib "gdi32.dll" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32.dll" (ByVal crColor As Long) As Long
'=========user32 Api========
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long
'=========Oleaut32 Api========
Private Declare Function OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor As Long, ByVal lHPalette As Long, ByVal lColorRef As Long) As Long
'=========Kernel32 Api========
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Type UcsRgbQuad
R As Byte
G As Byte
B As Byte
a As Byte
End Type
Private Type BLENDFUNCTION
BlendOp As Byte
BlendFlags As Byte
SourceConstantAlpha As Byte
AlphaFormat As Byte
End Type
Private Sub DrawAlphaSelection(hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal Width As Long, ByVal Height As Long, ByVal Color As OLE_COLOR)
Dim BF As BLENDFUNCTION
Dim hDCMemory As Long
Dim hBmp As Long
Dim hOldBmp As Long
Dim DC As Long
Dim lColor As Long
Dim hPen As Long
Dim hBrush As Long
Dim lBF As Long
BF.SourceConstantAlpha = 128
DC = GetDC(0)
hDCMemory = CreateCompatibleDC(0)
hBmp = CreateCompatibleBitmap(DC, Width, Height)
hOldBmp = SelectObject(hDCMemory, hBmp)
hPen = CreatePen(0, 1, Color)
hBrush = CreateSolidBrush(pvAlphaBlend(Color, vbWhite, 120))
DeleteObject SelectObject(hDCMemory, hBrush)
DeleteObject SelectObject(hDCMemory, hPen)
Rectangle hDCMemory, 0, 0, Width, Height
CopyMemory VarPtr(lBF), VarPtr(BF), 4
GdiAlphaBlend hdc, X, Y, Width, Height, hDCMemory, 0, 0, Width, Height, lBF
SelectObject hDCMemory, hOldBmp
DeleteObject hBmp
ReleaseDC 0&, DC
DeleteDC hDCMemory
DeleteObject hPen
DeleteObject hBrush
End Sub
Private Function pvAlphaBlend(ByVal clrFirst As Long, ByVal clrSecond As Long, ByVal lAlpha As Long) As Long
Dim clrFore As UcsRgbQuad
Dim clrBack As UcsRgbQuad
OleTranslateColor clrFirst, 0, VarPtr(clrFore)
OleTranslateColor clrSecond, 0, VarPtr(clrBack)
With clrFore
.R = (.R * lAlpha + clrBack.R * (255 - lAlpha)) / 255
.G = (.G * lAlpha + clrBack.G * (255 - lAlpha)) / 255
.B = (.B * lAlpha + clrBack.B * (255 - lAlpha)) / 255
End With
CopyMemory VarPtr(pvAlphaBlend), VarPtr(clrFore), 4
End Function
Private Sub Form_Paint()
Cls
DrawAlphaSelection Me.hdc, 10, 50, 100, 200, vbRed
DrawAlphaSelection Me.hdc, 50, 30, 200, 100, vbBlue
DrawAlphaSelection Me.hdc, 200, 80, 100, 100, vbGreen
DrawAlphaSelection Me.hdc, 80, 200, 200, 30, vbYellow
DrawAlphaSelection Me.hdc, 130, 70, 50, 200, vbMagenta
End Sub
این کد دیگری هست فقط یک اسکرول باید به صفحه اضافه کنید
Option ExplicitPrivate Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function CreatePatternBrush Lib "gdi32.dll" (ByVal hBitmap As Long) As Long
Private Declare Function SetPixelV Lib "gdi32.dll" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Private Declare Function RoundRect Lib "gdi32.dll" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
Private Declare Function CreatePen Lib "gdi32.dll" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor 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 OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor As Long, ByVal lHPalette As Long, ByVal lColorRef As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Type UcsRgbQuad
R As Byte
G As Byte
B As Byte
a As Byte
End Type
Private Sub DrawSelectionEx(DestDC As Long, DestX As Long, DestY As Long, DestWidth As Long, DestHeight As Long, oColorStar As Long, oColorEnd As Long)
Dim DC As Long, hDCMemory As Long, hBmp As Long
Dim hPen1 As Long, hPen2 As Long, hBrush As Long
Dim OldhBmp As Long, OldhPen As Long, OldhBrush As Long
Dim DivValue As Double
Dim i As Long
hPen1 = CreatePen(0, 1, pvAlphaBlend(vbBlack, oColorEnd, 10))
hPen2 = CreatePen(0, 1, pvAlphaBlend(oColorStar, vbWhite, 10))
DC = GetDC(0)
hDCMemory = CreateCompatibleDC(0)
hBmp = CreateCompatibleBitmap(DC, 1, DestHeight)
OldhBmp = SelectObject(hDCMemory, hBmp)
For i = 1 To DestHeight
DivValue = ((i * 255) / DestHeight)
SetPixelV hDCMemory, 0, i, pvAlphaBlend(oColorEnd, oColorStar, DivValue)
Next
hBrush = CreatePatternBrush(hBmp)
DeleteObject hBmp
hBmp = CreateCompatibleBitmap(DC, DestWidth, DestHeight)
Call SelectObject(hDCMemory, hBmp)
BitBlt hDCMemory, 0, 0, DestWidth, DestHeight, DestDC, DestX, DestY, vbSrcCopy
OldhPen = SelectObject(hDCMemory, hPen1)
RoundRect hDCMemory, 0, 0, DestWidth, DestHeight, 9, 9
Call SelectObject(hDCMemory, hPen2)
OldhBrush = SelectObject(hDCMemory, hBrush)
RoundRect hDCMemory, 1, 1, DestWidth - 1, DestHeight - 1, 8, 8
BitBlt DestDC, DestX, DestY, DestWidth, DestHeight, hDCMemory, 0, 0, vbSrcCopy
' Descargamos todo
SelectObject hDCMemory, OldhPen
SelectObject hDCMemory, OldhBrush
SelectObject hDCMemory, OldhBmp
DeleteObject hPen1
DeleteObject hPen2
DeleteObject hBrush
DeleteObject hBmp
ReleaseDC 0&, DC
DeleteDC hDCMemory
End Sub
Private Function pvAlphaBlend(ByVal clrFirst As Long, ByVal clrSecond As Long, ByVal lAlpha As Long) As Long
Dim clrFore As UcsRgbQuad
Dim clrBack As UcsRgbQuad
OleTranslateColor clrFirst, 0, VarPtr(clrFore)
OleTranslateColor clrSecond, 0, VarPtr(clrBack)
With clrFore
.R = (.R * lAlpha + clrBack.R * (255 - lAlpha)) / 255
.G = (.G * lAlpha + clrBack.G * (255 - lAlpha)) / 255
.B = (.B * lAlpha + clrBack.B * (255 - lAlpha)) / 255
End With
CopyMemory VarPtr(pvAlphaBlend), VarPtr(clrFore), 4
End Function
Private Sub Form_Load()
Me.ScaleMode = vbPixels
Me.FontSize = 12
Me.BackColor = vbWhite
Me.Width = 8500
Me.Height = 8700
HScroll1.Max = 255
HScroll1.Value = 70
HScroll1.Move 320, 210, 230, 30
End Sub
Private Sub Form_Paint()
Dim i As Integer
DrawSelectionEx Me.hdc, 320, 10, 100, 100, RGB(249, 253, 255), RGB(234, 247, 255)
DrawSelectionEx Me.hdc, 440, 10, 100, 100, RGB(251, 251, 251), RGB(231, 231, 231)
For i = 0 To 15
DrawSelectionEx Me.hdc, 10, 10 + (i * 35), 300, 30, Me.BackColor, pvAlphaBlend(QBColor(i), Me.BackColor, HScroll1.Value)
Next
DrawSelectionEx Me.hdc, 320, 120, 220, 70, Me.BackColor, pvAlphaBlend(vbHighlight, Me.BackColor, 50)
Me.CurrentX = 330
Me.CurrentY = 145
Me.Print "hi barnamenevis.org"
End Sub
Private Sub HScroll1_Change()
Form_Paint
End Sub
به شکل دایره
Option Explicit
Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hdc As Long, ByRef graphics As Long) As Long
Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As Long) As Long
Private Declare Function GdiplusStartup Lib "gdiplus" (ByRef token As Long, ByRef lpInput As GDIPlusStartupInput, Optional ByRef lpOutput As Any) As Long
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long
Private Declare Function GdipSetSmoothingMode Lib "GdiPlus.dll" (ByVal mGraphics As Long, ByVal mSmoothingMode As Long) As Long
Private Declare Function GdipDeleteBrush Lib "GdiPlus.dll" (ByVal mBrush As Long) As Long
Private Declare Function GdipFillEllipseI Lib "GdiPlus.dll" (ByVal mGraphics As Long, ByVal mBrush As Long, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GdipCreatePath Lib "GdiPlus.dll" (ByVal mBrushMode As Long, ByRef mPath As Long) As Long
Private Declare Function GdipDeletePath Lib "GdiPlus.dll" (ByVal mPath As Long) As Long
Private Declare Function GdipCreateLineBrushFromRectI Lib "GdiPlus.dll" (ByRef mRect As RECTL, ByVal mColor1 As Long, ByVal mColor2 As Long, ByVal mMode As LinearGradientMode, ByVal mWrapMode As WrapMode, ByRef mLineGradient As Long) As Long
Private Declare Function GdipAddPathEllipseI Lib "GdiPlus.dll" (ByVal mPath As Long, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long) As Long
Private Declare Function GdipSetPathGradientCenterColor Lib "GdiPlus.dll" (ByVal mBrush As Long, ByVal mColors As Long) As Long
Private Declare Function GdipSetPathGradientSurroundColorsWithCount Lib "GdiPlus.dll" (ByVal mBrush As Long, ByRef mColor As Long, ByRef mCount As Long) As Long
Private Declare Function GdipCreatePathGradientFromPath Lib "GdiPlus.dll" (ByVal mPath As Long, ByRef mPolyGradient As Long) As Long
Private Declare Function GdipSetLinePresetBlend Lib "GdiPlus.dll" (ByVal mBrush As Long, ByRef mBlend As Long, ByRef mPositions As Single, ByVal mCount As Long) As Long
Private Declare Function OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor As Long, ByVal lHPalette As Long, ByVal lColorRef As Long) As Long
Private Type RECTL
Left As Long
Top As Long
Width As Long
Height As Long
End Type
Private Enum LinearGradientMode
LinearGradientModeHorizontal = &H0
LinearGradientModeVertical = &H1
LinearGradientModeForwardDiagonal = &H2
LinearGradientModeBackwardDiagonal = &H3
End Enum
Private Enum WrapMode
WrapModeTile = &H0
WrapModeTileFlipX = &H1
WrapModeTileFlipy = &H2
WrapModeTileFlipXY = &H3
WrapModeClamp = &H4
End Enum
Private Type GDIPlusStartupInput
GdiPlusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Const SmoothingModeAntiAlias As Long = &H4
Dim GdipToken As Long
Private Sub Form_Load()
Call InitGDI
Me.AutoRedraw = True
DrawSphere Me.hdc, vbBlue, 10, 20, 150, 150
DrawSphere Me.hdc, vbGreen, 180, 20, 150, 150
DrawSphere Me.hdc, vbRed, 350, 20, 150, 150
DrawSphere Me.hdc, vbYellow, 10, 210, 150, 150
DrawSphere Me.hdc, vbBlack, 180, 210, 150, 150
DrawSphere Me.hdc, vbMagenta, 350, 210, 150, 150
DrawSphere Me.hdc, vbCyan, 10, 400, 150, 150
DrawSphere Me.hdc, vbWhite, 180, 400, 150, 150
DrawSphere Me.hdc, &H99FF&, 350, 400, 150, 150
End Sub
Private Sub Form_Unload(Cancel As Integer)
Call TerminateGDI
End Sub
Public Function DrawSphere(ByVal hdc As Long, _
ByVal lColor As Long, _
ByVal X As Long, _
ByVal Y As Long, _
ByVal Width As Long, _
ByVal Height As Long, _
Optional ByVal bDrawShadow As Boolean = True, _
Optional ByVal lAlpha As Long = 100) As Boolean
Dim hGraphics As Long
Dim hBrush As Long
Dim mPath As Long
Dim mRect As RECTL
Dim col(2) As Long
Dim pos(2) As Single
If GdipCreateFromHDC(hdc, hGraphics) = 0 Then
Call GdipSetSmoothingMode(hGraphics, SmoothingModeAntiAlias)
' ----------------------------- Shadow -------------------------------------
If bDrawShadow Then
Call GdipCreatePath(&H0, mPath)
GdipAddPathEllipseI mPath, X, Y + Height / 1.1, Width, Height / 4
GdipCreatePathGradientFromPath mPath, hBrush
GdipSetPathGradientCenterColor hBrush, ConvertColor(lColor, lAlpha / 3)
GdipSetPathGradientSurroundColorsWithCount hBrush, 0, 1
Call GdipFillEllipseI(hGraphics, hBrush, X, Y + Height / 1.1, Width, Height / 4)
Call GdipDeleteBrush(hBrush)
Call GdipDeletePath(mPath)
End If
'----------------------------- Sphere -------------------------------------
Call GdipCreatePath(&H0, mPath)
GdipAddPathEllipseI mPath, X - (Width / 1.75), Y - Height / 2, Width * 2, Height * 2
GdipCreatePathGradientFromPath mPath, hBrush
GdipSetPathGradientCenterColor hBrush, ConvertColor(lColor, lAlpha)
GdipSetPathGradientSurroundColorsWithCount hBrush, ConvertColor(ShiftColor(lColor, vbBlack, 100), lAlpha), 1
Call GdipFillEllipseI(hGraphics, hBrush, X, Y, Width, Height)
Call GdipDeleteBrush(hBrush)
Call GdipDeletePath(mPath)
'----------------------------- Light -------------------------------------
mRect.Left = X + Width / 10
mRect.Top = Y + Height / 50
mRect.Width = Width - Width / 5
mRect.Height = Height / 1.5
GdipCreateLineBrushFromRectI mRect, 0, 0, LinearGradientModeVertical, WrapModeTileFlipy, hBrush
col(0) = ConvertColor(vbWhite, lAlpha / 1.25)
col(1) = 0
col(2) = 0
pos(0) = 0
pos(1) = 0.6
pos(2) = 1
Call GdipSetLinePresetBlend(hBrush, col(0), pos(0), 3)
Call GdipFillEllipseI(hGraphics, hBrush, mRect.Left, mRect.Top, mRect.Width, mRect.Height - 1)
Call GdipDeleteBrush(hBrush)
' ------------------------------------------------------------------------
Call GdipDeleteGraphics(hGraphics)
End If
End Function
Private Function ConvertColor(Color As Long, Opacity As Long) As Long
Dim BGRA(0 To 3) As Byte
BGRA(3) = CByte((Abs(Opacity) / 100) * 255)
BGRA(0) = ((Color \ &H10000) And &HFF)
BGRA(1) = ((Color \ &H100) And &HFF)
BGRA(2) = (Color And &HFF)
CopyMemory ConvertColor, BGRA(0), 4&
End Function
Private Function ShiftColor(ByVal clrFirst As Long, ByVal clrSecond As Long, ByVal lAlpha As Long) As Long
Dim clrFore(3) As Byte
Dim clrBack(3) As Byte
OleTranslateColor clrFirst, 0, VarPtr(clrFore(0))
OleTranslateColor clrSecond, 0, VarPtr(clrBack(0))
clrFore(0) = (clrFore(0) * lAlpha + clrBack(0) * (255 - lAlpha)) / 255
clrFore(1) = (clrFore(1) * lAlpha + clrBack(1) * (255 - lAlpha)) / 255
clrFore(2) = (clrFore(2) * lAlpha + clrBack(2) * (255 - lAlpha)) / 255
CopyMemory ShiftColor, clrFore(0), 4
End Function
Private Sub InitGDI()
Dim GdipStartupInput As GDIPlusStartupInput
GdipStartupInput.GdiPlusVersion = 1&
Call GdiplusStartup(GdipToken, GdipStartupInput, ByVal 0)
End Sub
Private Sub TerminateGDI()
Call GdiplusShutdown(GdipToken)
End Sub
تشکر یادتون نره