الصورة الشفافة ذات السحب الخاص
-
21-09-2019 - |
سؤال
حصلت على مربع صور (يسمى 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 أو أي لغة أخرى ليس للأسف خيار.
شكرا مقدما ومع أطيب التحيات
المحلول
اللعنة. أعطاني صديق لي النصيحة باستخدام شفاف (MSDN)-وظيفي من وينابي. يعمل الآن بشكل جيد. بفضل أولئك الذين ألقوا نظرة عليه.
TY & GN8
تحياتي