الصورة الشفافة ذات السحب الخاص

Question

حصلت على مربع صور (يسمى i_mc) ورسم صورة بسيطة (m_imgmcn) على ذلك:

Call i_MC.PaintPicture(m_ImgMCN, 0, 0, i_MC.width, i_MC.height)

الآن أود أن أضع صورة شفافة على هذه الصورة ، في موضع معين. لقد وجدت رمزًا عينة ، والذي يقوم بالوظيفة بشكل جيد مع مشكلة واحدة: أجزاء من الصورة التي لا ينبغي المبالغة فيها مع الصورة الثانية (الشفافة) يتم المبالغة في السحب باللون الأسود العادي.

يعمل Algo تمامًا إذا تم رسم صورة الخلفية من الأعلى عن طريق ضبط الشركة. لا يمكن القيام بذلك لأن هذا لا يسمح بأي تمدد.

الصورة الشفافة هي صورة بسيطة أصغر من المربع الذي يحتوي على لون مقنع. لقد استخدمت رمز العينة التالي (.AutoredRaw = صحيح لجميع المربعات و .scalemode = 3 'بكسل):

Option Explicit
Private Declare Function BitBlt Lib "gdi32" (ByVal hDCDest As _
        Long, ByVal XDest As Long, ByVal YDest As Long, ByVal _
        nWidth As Long, ByVal nHeight As Long, ByVal hDCSrc _
        As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal _
        dwRop As Long) As Long

Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth _
        As Long, ByVal nHeight As Long, ByVal nPlanes As Long, _
        ByVal nBitCount As Long, lpBits As Any) As Long

Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As _
        Long, ByVal crColor As Long) As Long

Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As _
        Long, ByVal hObject 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 CreateCompatibleDC Lib "gdi32" (ByVal hdc _
        As Long) As Long

Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) _
        As Long

Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject _
       As Long) As Long

Private Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type
Dim R As RECT

Private Sub TranspPic(OutDstDC&, DstDC&, SrcDC&, SrcRect _
                      As RECT, ByVal DstX&, ByVal DstY&, _
                      TransColor&)

  Dim Result&, W&, H&
  Dim MonoMaskDC&, hMonoMask&, MonoInvDC&, hMonoInv&
  Dim ResultDstDC&, hResultDst&, ResultSrcDC&, hResultSrc&
  Dim hPrevMask&, hPrevInv&, hPrevSrc&, hPrevDst&

    W = SrcRect.Right - SrcRect.Left
    H = SrcRect.Bottom - SrcRect.Top

    'Generieren einer Monochromen & einer inversen Maske
    MonoMaskDC = CreateCompatibleDC(DstDC)
    MonoInvDC = CreateCompatibleDC(DstDC)
    hMonoMask = CreateBitmap(W, H, 1, 1, ByVal 0&)
    hMonoInv = CreateBitmap(W, H, 1, 1, ByVal 0&)
    hPrevMask = SelectObject(MonoMaskDC, hMonoMask)
    hPrevInv = SelectObject(MonoInvDC, hMonoInv)

    'Puffer erstellen
    ResultDstDC = CreateCompatibleDC(DstDC)
    ResultSrcDC = CreateCompatibleDC(DstDC)
    hResultDst = CreateCompatibleBitmap(DstDC, W, H)
    hResultSrc = CreateCompatibleBitmap(DstDC, W, H)
    hPrevDst = SelectObject(ResultDstDC, hResultDst)
    hPrevSrc = SelectObject(ResultSrcDC, hResultSrc)

    'Sourcebild in die monochrome Maske kopieren
    Dim OldBC As Long
    OldBC = SetBkColor(SrcDC, TransColor)
    Result = BitBlt(MonoMaskDC, 0, 0, W, H, SrcDC, _
                  SrcRect.Left, SrcRect.Top, vbSrcCopy)
    TransColor = SetBkColor(SrcDC, OldBC)

    'Inverse Maske erstellen
    Result = BitBlt(MonoInvDC, 0, 0, W, H, _
                  MonoMaskDC, 0, 0, vbNotSrcCopy)

    'Hintergrund des Zielbildes auslesen
    Result = BitBlt(ResultDstDC, 0, 0, W, H, _
                  DstDC, DstX, DstY, vbSrcCopy)

    'AND mit der Maske
    Result = BitBlt(ResultDstDC, 0, 0, W, H, _
                  MonoMaskDC, 0, 0, vbSrcAnd)

    'Überlappung des Sourcebildes mit dem Zielbild auslesen
    Result = BitBlt(ResultSrcDC, 0, 0, W, H, SrcDC, _
                  SrcRect.Left, SrcRect.Top, vbSrcCopy)

    'AND mit der invertierten, monochromen Maske
    Result = BitBlt(ResultSrcDC, 0, 0, W, H, _
                  MonoInvDC, 0, 0, vbSrcAnd)

    'XOR mit beiden
    Result = BitBlt(ResultDstDC, 0, 0, W, H, _
                  ResultSrcDC, 0, 0, vbSrcInvert)

    'Ergebnis in das Zielbild kopieren
    Result = BitBlt(OutDstDC, DstX, DstY, W, H, _
                  ResultDstDC, 0, 0, vbSrcCopy)

    'Erstellte Objekte & DCs wieder freigeben
    hMonoMask = SelectObject(MonoMaskDC, hPrevMask)
    DeleteObject hMonoMask
    DeleteDC MonoMaskDC

    hMonoInv = SelectObject(MonoInvDC, hPrevInv)
    DeleteObject hMonoInv
    DeleteDC MonoInvDC

    hResultDst = SelectObject(ResultDstDC, hPrevDst)
    DeleteObject hResultDst
    DeleteDC ResultDstDC

    hResultSrc = SelectObject(ResultSrcDC, hPrevSrc)
    DeleteObject hResultSrc
    DeleteDC ResultSrcDC
End Sub

Private Sub MovePicTo(ByVal X&, ByVal Y&)
    i_MC.Cls
    picSrc.Picture = m_ImgMCN
    With R
        .Left = 0
        .Top = 0
        .Right = Picture2.ScaleWidth
        .Bottom = Picture2.ScaleHeight
    End With
    Call TranspPic(i_MC.hdc, i_MC.hdc, picSrc.hdc, R, X, Y, vbWhite)
    i_MC.Refresh
    DoEvents
End Sub

يتواجد هذا الرمز في الأصل على Activevb.de ، لقد قمت بتعديله قليلاً دون تغيير الخوارزمية أو الوظيفة. يمكنني نشر رابط لمقال أصلي.

بدون نجاح ، حاولت تعديل أحجام الصور الوسيطة المختلفة ، لكنها تستمر في رسم الصورة بشكل خاطئ:

جزء من الصورة التي يتم رسم الصورة الشفافة صحيحة ، يتم تضمين الخلفية. يتم كتابة ما تبقى من الصورة (التي لا ينبغي أن يلمسها algo) مع الأسود.

أي فكرة موضع تقدير. خوارزمية لطلاء الصور ألفابيلد 24 بت ستكون جيدة أيضًا! لقد غوغل لفترة طويلة ولم أجد قطعة رمز تعمل.

ملاحظة: هذا هو VB6 القديم العادي ، والانتقال إلى .NET أو أي لغة أخرى ليس للأسف خيار.

شكرا مقدما ومع أطيب التحيات

Answer 1

اللعنة. أعطاني صديق لي النصيحة باستخدام شفاف (MSDN)-وظيفي من وينابي. يعمل الآن بشكل جيد. بفضل أولئك الذين ألقوا نظرة عليه.

TY & GN8

تحياتي