نمایش نتایج 1 تا 1 از 1

نام تاپیک: رسم کردن کد زنگ آلف روی هم (حتما ببنید)

  1. #1
    کاربر دائمی
    تاریخ عضویت
    فروردین 1389
    محل زندگی
    اصفهان
    پست
    717

    Cool رسم کردن کد زنگ آلف روی هم (حتما ببنید)



    '=========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
















    تشکر یادتون نره
    آخرین ویرایش به وسیله www.pc3enter.tk : چهارشنبه 06 مرداد 1395 در 13:59 عصر

تاپیک های مشابه

  1. سوال: ترسپرنت کردن دوتا label که روی هم قرار گرفته اند
    نوشته شده توسط mahboube در بخش C#‎‎
    پاسخ: 8
    آخرین پست: پنج شنبه 07 بهمن 1389, 08:41 صبح
  2. ااشکال در رسم 2 تا عکس بر روی هم !!!
    نوشته شده توسط mahdi68 در بخش Java ME : نگارش میکرو جاوا
    پاسخ: 2
    آخرین پست: دوشنبه 25 مرداد 1389, 18:29 عصر
  3. پاسخ: 6
    آخرین پست: چهارشنبه 15 مهر 1388, 13:51 عصر
  4. پیدا کردن کد پستی از روی تلفن
    نوشته شده توسط vahid_d_0101 در بخش برنامه نویسی در 6 VB
    پاسخ: 3
    آخرین پست: شنبه 22 فروردین 1388, 21:13 عصر
  5. بر طرف کردن حالت پرشی اشیای روی هم
    نوشته شده توسط s_mbk2001 در بخش برنامه نویسی در 6 VB
    پاسخ: 8
    آخرین پست: سه شنبه 13 دی 1384, 04:18 صبح

قوانین ایجاد تاپیک در تالار

  • شما نمی توانید تاپیک جدید ایجاد کنید
  • شما نمی توانید به تاپیک ها پاسخ دهید
  • شما نمی توانید ضمیمه ارسال کنید
  • شما نمی توانید پاسخ هایتان را ویرایش کنید
  •