Контрол в форме того, что а нем нарисовано

[VB-constructor]

Сейчас расскажу свою историю:
Я пишу графический компонент, который должен принимать форму того, что на нем нарисовано.
Через АПИ я нашел три способа это сделать:
1)BeginPath, рисую фигуру ,EndPath, SetWindowRgn
Но в конце концов мне пришлось от него отказаться, потому что в нем можно было рисовать только фигуры с замкнутым контуром. А назначение компонента - и в том, чтобы делать окно хоть в форме точки.
2)SetWindowRgn - при этом проходиться по всему фону циклом, проверяя цвет каждого пикселя. Если он не соответствует фону, то CreateRectRgn его, ну и SetWindowRgn. Увы этот способ оказался слишком медленным. Аж до нескольких секунд (в зависимости от размеров фона). Пришлось от него отказаться
3)GetWindowLong, SetWindowLong, SetLayeredWindowAttributes - но это работало только для главных форм, но не для контролов.

В итоге я остался ни с чем.
Помогите, как-нибудь, советом, что ли?

Спасибо сем ответившим

[tyomitch]

1) точка -- тоже фигура с замкнутым контуром. Не вижу проблемы.
2) тормозов можно избежать. У тебя в цикле, поди, GetPixel?

[VB-constructor]

2) тормозов можно избежать. У тебя в цикле, поди, GetPixel?

Ага, люблю телепатов

Код: Выделить всё

            If GetPixel(Me.hdc, X, Y) = 0 Then


Я сначала думал на конструкцию If...
А если getpixel тормозит, то...
А как еще проверять цвет?

[VB-constructor]

1) точка -- тоже фигура с замкнутым контуром. Не вижу проблемы.

А это идея!!!
Спасибо, tyomitch!

Правда это только идея. Я не знаю, как её реализовать. Например на обычную линию она не действует. Тогда надо будет чтоли опять по циклу каждый пиксель проходит
x,y
x+1,y
x+1,y+1
x,y+1
?

[tyomitch]

2) тормозов можно избежать. У тебя в цикле, поди, GetPixel?

Ага, люблю телепатов

Код: Выделить всё

            If GetPixel(Me.hdc, X, Y) = 0 Then


Я сначала думал на конструкцию If...
А если getpixel тормозит, то...
А как еще проверять цвет?

При помощи поиска по форуму, ессно
http://bbs.vbstreets.ru/viewtopic.php?p=71370#71370

[VB-constructor]

Вообще идея классная! Можно я как начинающий и долго соображающий задам вопрос, на который никак не могу найти ответ:

Не первый раз не пойму, зачем используют

Код: Выделить всё

    lSkinRgn = CreateRectRgn(0, 0, 0, 0)

а потом

Код: Выделить всё

    CombineRgn lSkinRgn, lSkinRgn, lRgn, RGN_OR

Я не могу понять связь этих регионов: почему

[tyomitch]

Начинаем с пустого региона. Потом добавляем к нему тонкие горизонтальные полоски.

[VB-constructor]

Начинаем с пустого региона. Потом добавляем к нему тонкие горизонтальные полоски

Ага, ясно. Спасибо. Теперь понял.

Самое печальное то, что этот вариант все равно медленный:
Этот код у меня выполняется за
300(сек в минус третьей степени )
(из rgn_1)

Код: Выделить всё

Option Explicit

Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Const RGN_OR = 2

Private Type BITMAPINFOHEADER
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFOHEADER, ByVal wUsage 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 Function lGetRegion(ByVal lBackColor As Long, ByVal Picture As StdPicture) As Long
Dim lRgn As Long
Dim lSkinRgn As Long
Dim lStart As Long
Dim lX As Long
Dim lY As Long
Dim ms As Long

Dim bi As BITMAPINFOHEADER, bits() As Long, hdc As Long
With bi
    .biSize = LenB(bi)
    .biWidth = ScaleX(Picture.Width, vbHimetric, vbPixels)
    .biHeight = ScaleY(Picture.Width, vbHimetric, vbPixels)
    .biPlanes = 1
    .biBitCount = 32
    .biCompression = 0
    ReDim bits(0 To .biWidth - 1, 0 To .biHeight - 1)
    hdc = CreateCompatibleDC(0)
    GetDIBits hdc, Picture, 0, bi.biHeight, bits(0, 0), bi, 0
    DeleteDC (hdc)
   
    lSkinRgn = CreateRectRgn(0, 0, 0, 0)

    For lX = 0 To .biHeight - 1
        lY = 0
        Do While lY < .biWidth
            Do While lY < .biWidth
                If bits(lY, lX) <> lBackColor Then Exit Do
                lY = lY + 1
            Loop

            If lY < .biWidth Then
                lStart = lY
                Do While lY < .biWidth
                    If bits(lY, lX) = lBackColor Then Exit Do
                    lY = lY + 1
                Loop
                If lY > .biWidth Then lY = .biWidth
                lRgn = CreateRectRgn(lStart, .biHeight - lX - 1, lY, .biHeight - lX)
                CombineRgn lSkinRgn, lSkinRgn, lRgn, RGN_OR
                DeleteObject lRgn
            End If
        Loop
    Next
End With
lGetRegion = lSkinRgn
End Function

Private Sub Form_DblClick()
    Unload Me
End Sub

Private Sub Form_Load()
Dim lRgn As Long, Start As Long
Screen.MousePointer = 13
    Show
    Start = GetTickCount
    lRgn = lGetRegion(RGB(239, 239, 239), Picture)
    SetWindowRgn hWnd, lRgn, True
    Debug.Print GetTickCount - Start        'ó ìåíÿ 1482
    Screen.MousePointer = vbDefault
End Sub



И борьба за улучшение скорости в 2-3 раза, дальше этот алгоритм врядли можно разогнать.
Его альтернатива: (выбивает ноль)

Код: Выделить всё

Option Explicit
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
    (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
    (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, _
    ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long

Private Const GWL_EXSTYLE = (-20)
Private Const WS_EX_LAYERED = &H80000
Private Const LWA_COLORKEY = &H1
Private Const CLR_BLACK = &H0&

Private Const LWA_ALPHA = &H2
Private Const CLR_WHITE = &HFFFFFF

Private Sub Form_Load()
    Dim ret As Long
    Dim n As Long
    n = GetTickCount
    ret = GetWindowLong(Me.hWnd, GWL_EXSTYLE)
    ret = ret Or WS_EX_LAYERED
    SetWindowLong Me.hWnd, GWL_EXSTYLE, ret
    SetLayeredWindowAttributes Me.hWnd, CLR_WHITE, 255, LWA_COLORKEY
    Debug.Print GetTickCount - n
End Sub

Но попиксельный обход. Это - медлено так или иначе. Мой компонент будет должен менять свою форму при каждом mousemove , а это значит, что нужно обеспечить максимальную скорость этого действия.

Она д/выбивать ноль или рядом с тем

[VB-constructor]

Сейчас же проверил другой вариант:
Еще одна альтернатива:

Код: Выделить всё

Option Explicit
Private Declare Function BeginPath Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function EndPath Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function PathToRegion Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long

Private Type POINTAPI
        x As Long
        y As Long
End Type
Private Declare Function Ellipse 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 Function SetCreateForm(ByVal propHwnd As Long, ByVal propHDC As Long)
Dim rComb As Long
Dim dl As Long
Dim vFont As Long
Dim vFontOld As Long
Dim vDC As Long
Dim f As POINTAPI

    vDC = propHDC
    vFont = CreateFont(24, 0, 0, 0, 400, 0, 0, 0, 1, 1, 1, 2, 2, "Times New Roman")
    vFontOld = SelectObject(vDC, vFont)
    dl = BeginPath(vDC)
        Call TextOut(vDC, 107, 60, "Íîâûé", 5)
        Ellipse hdc, 100, 100, 300, 500

        Call MoveToEx(vDC, 0, 0, f)
        Call LineTo(vDC, 100, 100)
    dl = EndPath(vDC)
    rComb = PathToRegion(vDC)
    dl = SelectObject(vDC, vFontOld)
    dl = DeleteObject(vFont)
    dl = SetWindowRgn(propHwnd, rComb, 1)
End Function

Private Sub Form_Load()
    Dim n As Long
    n = GetTickCount
    Call SetCreateForm(Form1.hwnd, Form1.hdc)
    Debug.Print GetTickCount - n
End Sub

И тоже нооль. А у вас?
Может можно как-то вручную сделать с такой же скоростью?

[tyomitch]

Если форма -- произвольная битмапина, то нельзя.

[VB-constructor]

А если не произвольная, а в виде линии, например?

[tyomitch]

Линия -- это параллелограмм единичной ширины.
Параллелограммы рисовать умеем?

[VB-constructor]

Если бы все ыло так просто: еще по краям две дуги. + линии всегда должны быть параллельны и на одном расстоянии. (так наз. мультилиния). Тож не все ок

[tyomitch]

Любые линии -- это параллелограммы единичной ширины.
Дугу тоже можно сделать, если из эллипса вырезать эллипс.

[VB-constructor]

tyomitch,

Любые линии -- это параллелограммы единичной ширины.

А для того чтобы чертить такие есть специальная функция?

Дугу тоже можно сделать, если из эллипса вырезать эллипс.

Если сделать вручную мультилинию, то окружность - дело техники...

[tyomitch]

2tyomitch,

Любые линии -- это параллелограммы единичной ширины.

А для того чтобы чертить такие есть специальная функция?

Polygon устроит?

[VB-constructor]

Гы, полигон смешно

Полигон он на то и полигон, чтобы чертить полигон. Чтобы начертить вышеописанную трапецию нужно составить для него зверский алгоритм.
Все к этому идет?

[Viper]

Нды... а то что трапеция есть частный случай многоугольника (он же полигон) в голову не приходило?

[VB-constructor]

Нды... а то что трапеция есть частный случай многоугольника (он же полигон) в голову не приходило?

!Viper!, См. пост перед тобой

[Kovu]

VB-constructor
Вот, для линии, а ты что собиался мудрить тут?

Код: Выделить всё


Private Declare Function BeginPath Lib "gdi32.dll" ( _
     ByVal hdc As Long) As Long
Private Declare Function EndPath Lib "gdi32.dll" ( _
     ByVal hdc As Long) As Long
Private Declare Function PathToRegion Lib "gdi32.dll" ( _
     ByVal hdc As Long) As Long
Private Declare Function SetWindowRgn Lib "user32.dll" ( _
     ByVal hWnd As Long, _
     ByVal hRgn As Long, _
     ByVal bRedraw As Boolean) As Long
Private Declare Function Polygon Lib "gdi32.dll" ( _
     ByVal hdc As Long, _
     ByRef lpPoint As POINTAPI, _
     ByVal nCount As Long) As Long

Private Type POINTAPI
    x As Long
    y As Long
End Type



Dim Rgn As Long, PT(3) As POINTAPI


Private Sub Form_Load()
Me.BackColor = RGB(0, 255, 0)
PT(0).x = 0
PT(0).y = 0
PT(1).x = 100
PT(1).y = 150
PT(2).x = 100
PT(2).y = 151
PT(3).x = 0
PT(3).y = 1
BeginPath Me.hdc
    Polygon Me.hdc, PT(0), 4
EndPath Me.hdc
Rgn = PathToRegion(Me.hdc)
SetWindowRgn Me.hWnd, Rgn, False
End Sub



Трапеция -4 точки, что зверского ты собрался для неё придумывать?

[VB-constructor]

Kovu, спасибо за вопрос

Я тоже так делал, даже не BeginPath(см. прикрепленный док.),
но недостатки можно увидеть в том примере кот. я прикрепил:

Запустите и посмотрите на "линию" в разных её положениях.
То она прямоуогольник шириной в неск. дес. пикселей, а то (если вертикально) - то вообще превращается в волосок...

[keks-n]

VB-constructor
Просьба правильно писать ники участников конференции - при чтении раздражает.

[VB-constructor]

VB-constructor
Просьба правильно писать ники участников конференции - при чтении раздражает.

Пордон, уже исправил

[keks-n]

В последнем посте так и осталось

Covu, спасибо за вопрос

Kovu

[VB-constructor]

В последнем посте так и осталось

Covu, спасибо за вопрос

Kovu

Это было давно и неправда