Перекинуть Label из окна в контейнер пользовательского контрола - VB

Узнай цену своей работы

Формулировка задачи:

Добрый день сейчас самостоятельно разрабатываю компонент Спойлер.. исходники здесь модификация здесь:
Листинг программы 
  1. Option Explicit
  2. '
  3. '   © Антихакер32™
  4. '
  5. Private Const def_cm1_Height = 300 'Высота кнопки
  6. Private Const HWND_TOPMOST = -1
  7. Private Const SWP_NOSIZE = &H1
  8. Private Const SWP_NOMOVE = &H2
  9. Private Const GWL_EXSTYLE = (-20)
  10. Private Const WS_EX_TOOLWINDOW = 128
  11. '
  12. Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
  13. Private Declare Sub SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long)
  14. Private Declare Function GetForegroundWindow Lib "user32" () As Long
  15. '
  16. Dim WithEvents cm1 As CommandButton
  17. Dim WithEvents Pic As PictureBox
  18. Dim Amb As Object
  19. Dim mSpoilerAction As Boolean
  20. '''''Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
  21. '''''Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
  22. '''''Private Declare Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long
  23. '''''Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
  24.  
  25. Public Sub WActivate()
  26.     On Error GoTo errr
  27.     SpoilerAction = False
  28. errr:
  29. End Sub
  30.  
  31. Public Sub WindowPosChaning()
  32.     On Error GoTo errr
  33.     Const ram = 60
  34.     Static Left&, top&
  35.     Left = Parent.Left - (Parent.ScaleWidth - Parent.Width + ram) + Amb.Left
  36.     top = Parent.top - (Parent.ScaleHeight - Parent.Height + ram) + Amb.top + cm1.Height
  37.     Pic.Move Left, top, Amb.Width, Amb.Height - cm1.Height
  38. errr:
  39. End Sub
  40.  
  41. Private Property Get SpoilerAction() As Boolean
  42.     SpoilerAction = mSpoilerAction
  43. End Property
  44.  
  45. Private Property Let SpoilerAction(ByVal vNewValue As Boolean)
  46.     mSpoilerAction = vNewValue
  47.     If vNewValue Then
  48.         SetWindowPos Pic.hWnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE + SWP_NOSIZE
  49.         Pic.Visible = True
  50.     Else
  51.         SetWindowPos Pic.hWnd, 0, 0, 0, 0, 0, SWP_NOMOVE + SWP_NOSIZE
  52.         Pic.Visible = False
  53.     End If
  54. End Property
  55.  
  56. Private Sub cm1_Click()
  57.     SpoilerAction = Not SpoilerAction
  58. End Sub
  59.  
  60. Private Sub UserControl_ExitFocus()
  61. SpoilerAction = False
  62. End Sub
  63.  
  64. Private Sub UserControl_Initialize()
  65.     Set cm1 = Controls.Add("vb.CommandButton", "cm1_" & hWnd)
  66.     cm1.Visible = 1
  67.     Set Pic = Controls.Add("vb.PictureBox", "pic_" & hWnd)
  68. End Sub
  69.  
  70. Private Sub UserControl_Resize()
  71.     On Error Resume Next
  72.     cm1.Move 0, 0, Width, def_cm1_Height
  73.     Pic.Move 0, cm1.Height, Width, Height - cm1.Height
  74. End Sub
  75.  
  76. Private Sub UserControl_Show()
  77.     Dim j$(), id$, indAmb&, o As Object, hW&, py&
  78.     j = Split(Ambient.DisplayName, "(")
  79.  
  80.     If UBound(j) Then
  81.          indAmb = Val(Split(j(1), ")")(0))
  82.         Set Amb = CallByName(Parent, j(0), VbGet, indAmb)
  83.     Else: indAmb = -1
  84.         Set Amb = CallByName(Parent, j(0), VbGet)
  85.     End If
  86.     On Error Resume Next
  87.     If Ambient.UserMode Then
  88.         For Each o In Parent
  89.             id = o.Container.Name 'Если произойдет ошибка, то останеться это id
  90.             id = id & "(" & o.Container.Index & ")"
  91.             If id = Ambient.DisplayName Then
  92.                 hW = 0: hW = o.hWnd
  93.                 If hW = 0 Then
  94.                     '
  95.                     'Здесь лейбл, значит надо напечатать на PictureBox эту надпись :(
  96.                     '
  97.                 Else: SetParent hW, Pic.hWnd
  98.                 End If
  99.                 
  100.                 o.top = o.top - def_cm1_Height
  101.             End If
  102.         Next
  103.         SetParent Pic.hWnd, 0
  104.         SetWindowLong Pic.hWnd, GWL_EXSTYLE, _
  105.         GetWindowLong(Pic.hWnd, GWL_EXSTYLE) Or WS_EX_TOOLWINDOW
  106.         WindowPosChaning
  107.         Hook Amb
  108.     Else 'Режим проектирования
  109.         SetParent Pic.hWnd, hWnd
  110.         Pic.Visible = True: Pic.Enabled = 0
  111.         Pic.ZOrder 1
  112.     End If
  113. End Sub
  114.  
  115. Private Sub UserControl_Terminate()
  116.      UnHook
  117. End Sub
Листинг программы 
  1. Option Explicit
  2. '
  3. Public Const GWL_WNDPROC = -4
  4. ' Сообщения windows
  5. Public Const WM_CLOSE = &H10
  6. Private Const WM_MOVE = &H3
  7.  
  8. Const WM_ACTIVATE = &H6
  9.  
  10. Const HTCAPTION = 2
  11. Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  12. Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  13. Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
  14. '
  15. Dim SWL As Long
  16. Dim mTypeName As String
  17. Dim mParent  As Object
  18. Dim mParent_hWnd As Long
  19.  
  20. Function Hook(Child As Object) As Long
  21.     On Error GoTo errr
  22.     If Child.Parent.hWnd <> mParent_hWnd Then
  23.         mTypeName = TypeName(Child)
  24.         Set mParent = Child.Parent
  25.         mParent_hWnd = mParent.hWnd
  26.         SWL = SetWindowLong(mParent_hWnd, GWL_WNDPROC, AddressOf WindowProc)
  27.     End If
  28. errr:
  29. End Function
  30.  
  31. Sub UnHook()
  32.     Call CallWindowProc(SWL, mParent_hWnd, WM_CLOSE, 0, 0)
  33. End Sub
  34.  
  35. Public Function WindowProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  36.    Dim o As Object
  37.    On Error GoTo errr
  38.    Select Case Msg
  39.    Case WM_ACTIVATE
  40.         For Each o In mParent
  41.             If TypeName(o) = mTypeName Then
  42.                 Call o.WActivate
  43.             End If
  44.         Next
  45.         Exit Function
  46.     Case WM_MOVE
  47.         For Each o In mParent
  48.             If TypeName(o) = mTypeName Then
  49.                 Call o.WindowPosChaning
  50.             End If
  51.         Next
  52.         Exit Function
  53.    End Select
  54.    WindowProc = CallWindowProc(SWL, hWnd, Msg, wParam, lParam)
  55. errr:
  56. End Function
так вот, есть ли нормальный способ чтоб перекинуть лейбл из окна в контейнер пользовательского контрола
Там проблемное место, это 101-я строчка, в модуле UserControl'а ..Какие будут предложения коллеги ?
вот как я придумал пока сделать, но это решение меня мало радует
Листинг программы 
  1. Private Sub UserControl_Show()
  2.     Dim j$(), id$, indAmb&, o As Object, hW&, hP&
  3.     Dim lab As Label, col As Collection, f&, v As Object
  4.     j = Split(Ambient.DisplayName, "(")
  5.  
  6.     If UBound(j) Then
  7.          indAmb = Val(Split(j(1), ")")(0))
  8.         Set Amb = CallByName(Parent, j(0), VbGet, indAmb)
  9.     Else: indAmb = -1
  10.         Set Amb = CallByName(Parent, j(0), VbGet)
  11.     End If
  12.     On Error Resume Next
  13.     If Ambient.UserMode Then
  14.         For Each o In Parent
  15.             id = o.Container.Name 'Если произойдет ошибка, то останеться это id
  16.             id = id & "(" & o.Container.Index & ")"
  17.             If id = Ambient.DisplayName Then
  18.                 hW = 0: hW = o.hWnd
  19.                 hP = GetParent(hW)
  20.                 If hW = 0 Then
  21.                     '
  22.                     'Здесь лейбл, значит
  23.                     '
  24.                     Set lab = Controls.Add("vb." & TypeName(o), "lab_" & hWnd, Pic)
  25.                     With lab
  26.                         .Alignment = o.Appearance
  27.                         .Appearance = o.Appearance
  28.                         .AutoSize = o.AutoSize
  29.                         .BackColor = o.BackColor
  30.                         .BorderStyle = o.BorderStyle
  31.                         .Left = o.Left
  32.                         .top = o.top
  33.                         .Width = o.Width
  34.                         .Height = o.Height
  35.                         .Font = o.Font
  36.                         .Caption = o.Caption
  37.                         o.Visible = False
  38.                         .Visible = True
  39.                     End With
  40.  
  41.                 ElseIf hP = hWnd Then
  42.                     SetParent hW, Pic.hWnd
  43.                 End If
  44.                 o.top = o.top - def_cm1_Height
  45.             End If
  46.         Next
  47.         SetParent Pic.hWnd, 0
  48.         SetWindowLong Pic.hWnd, GWL_EXSTYLE, _
  49.         GetWindowLong(Pic.hWnd, GWL_EXSTYLE) Or WS_EX_TOOLWINDOW
  50.         WindowPosChaning
  51.         Hook Amb
  52.     Else 'Режим проектирования
  53.         SetParent Pic.hWnd, hWnd
  54. '        Pic.Visible = True: Pic.Enabled = 0
  55.         Pic.ZOrder 1
  56.     End If
  57. End Sub

Решение задачи: «Перекинуть Label из окна в контейнер пользовательского контрола»

textual
Листинг программы 
  1. Option Explicit
  2. '
  3. '   © Антихакер32™
  4. '
  5. '
  6. Private Type RECT
  7.         Left As Long
  8.         Top As Long
  9.         Right As Long
  10.         Bottom As Long
  11. End Type
  12. '
  13. Public Enum FlagsSpoilerStyle
  14.     [По умолчанию] = 0
  15.     [Кнопка слева] = 1
  16. End Enum
  17. '
  18. Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
  19. Private Declare Sub SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long)
  20. Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
  21. Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
  22. Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
  23. Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
  24. '
  25. 'Default Property Values:
  26. Const m_def_Style = 0
  27. Const def_Exp = 280 'Высота кнопки
  28. Const HWND_TOPMOST = -1
  29. Const SWP_NOSIZE = &H1
  30. Const SWP_NOMOVE = &H2
  31. Const GWL_EXSTYLE = (-20)
  32. Const WS_EX_TOOLWINDOW = 128
  33. 'Property Variables:
  34. Dim m_Style As FlagsSpoilerStyle
  35. Dim WithEvents cm1 As CommandButton
  36. Dim sh1 As Shape
  37. Dim mSpoilerAction As Boolean
  38. Dim oldParRect As RECT, mRect As RECT
  39. Dim ResizeAction As Boolean
  40.  
  41. Public Sub WActivate()
  42.     On Error GoTo errr
  43.     If SpoilerAction Then SpoilerAction = False
  44. errr:
  45. End Sub
  46.  
  47. Public Sub WMove()
  48.     Static Rect1 As RECT, Rect2 As RECT
  49.     On Error GoTo errr
  50.     If mSpoilerAction Then
  51.         GetWindowRect Parent.hWnd, Rect1
  52.         GetWindowRect hWnd, Rect2
  53.         With Rect2
  54.             .Left = .Left + (Rect1.Left - oldParRect.Left)
  55.             .Top = .Top + (Rect1.Top - oldParRect.Top)
  56.             SetWindowPos hWnd, -1, .Left, .Top, 0, 0, SWP_NOSIZE
  57.         End With
  58.         oldParRect = Rect1
  59.     End If
  60. errr:
  61. End Sub
  62.  
  63. Private Property Get SpoilerAction() As Boolean
  64.     SpoilerAction = mSpoilerAction
  65. End Property
  66.  
  67.  
  68. Private Property Let SpoilerAction(ByVal vNewValue As Boolean)
  69.     Static Rect1 As RECT, Rect2 As RECT, Rect3 As RECT, Border&
  70.     On Error GoTo errr
  71.     GetWindowRect Parent.hWnd, Rect1
  72.     GetWindowRect hWnd, Rect2
  73.     ResizeAction = True
  74.     If vNewValue Then
  75.         With Rect2
  76.             .Left = Rect1.Left + (.Left - Rect1.Left)
  77.             .Top = Rect1.Top + (.Top - Rect1.Top)
  78.             SetWindowPos hWnd, 0, .Left, .Top, 0, 0, SWP_NOSIZE
  79.             SetParent hWnd, 0
  80.             oldParRect = Rect1
  81.         End With
  82.         Select Case m_Style
  83.         Case [По умолчанию]: Height = sh1.Height
  84.         Case [Кнопка слева]: Width = sh1.Width
  85.         End Select
  86.     Else
  87.         GetClientRect Parent.hWnd, Rect3
  88.         With Rect2
  89.             .Left = (.Left - (Rect1.Right - Rect3.Right))
  90.             .Left = .Left + (mRect.Left - .Left)
  91.             .Top = (.Top - (Rect1.Bottom - Rect3.Bottom))
  92.             .Top = .Top + (mRect.Top - .Top)
  93.             SetParent hWnd, Parent.hWnd
  94.             SetWindowPos hWnd, 0, .Left, .Top, 0, 0, SWP_NOSIZE
  95.         End With
  96.         Select Case m_Style
  97.         Case [По умолчанию]: Height = def_Exp
  98.         Case [Кнопка слева]: Width = def_Exp
  99.         End Select
  100.     End If
  101.     mSpoilerAction = vNewValue
  102. errr:
  103.     ResizeAction = False
  104. End Property
  105.  
  106. Private Sub cm1_Click()
  107.     SpoilerAction = Not SpoilerAction
  108. End Sub
  109.  
  110. Private Sub UserControl_Initialize()
  111.     Set cm1 = Controls.Add("vb.CommandButton", "cm1_" & hWnd)
  112.     Set sh1 = Controls.Add("vb.Shape", "sh1_" & hWnd)
  113.     sh1.Visible = 1: cm1.Visible = 1
  114.     SetWindowLong hWnd, GWL_EXSTYLE, _
  115.     GetWindowLong(hWnd, GWL_EXSTYLE) Or WS_EX_TOOLWINDOW
  116. End Sub
  117.  
  118. Private Sub UserControl_Resize()
  119.     On Error Resume Next
  120.     If ResizeAction Then Exit Sub
  121.     With mRect
  122.         If Not mSpoilerAction Then
  123.             sh1.Move 0, 0, Width, Height
  124.             .Left = Extender.Left \ Screen.TwipsPerPixelX
  125.             .Top = Extender.Top \ Screen.TwipsPerPixelY
  126.         End If
  127.         Select Case m_Style
  128.         Case [По умолчанию]: cm1.Move 0, 0, sh1.Width, def_Exp
  129.         Case [Кнопка слева]: cm1.Move 0, 0, def_Exp, sh1.Height
  130.         End Select
  131.     End With
  132. End Sub
  133.  
  134. Private Sub UserControl_Show()
  135.     Dim o As Object
  136.     If Ambient.UserMode Then
  137.         SpoilerAction = 1
  138.         Hook Extender
  139.     End If
  140. End Sub
  141.  
  142. Private Sub UserControl_Terminate()
  143.      UnHook
  144. End Sub
  145.  
  146. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  147. 'MemberInfo=8,0,0,0
  148. Public Property Get Style() As FlagsSpoilerStyle
  149.     Style = m_Style
  150. End Property
  151.  
  152. Public Property Let Style(ByVal New_Style As FlagsSpoilerStyle)
  153.     m_Style = New_Style
  154.     PropertyChanged "Style"
  155.     UserControl_Resize
  156. End Property
  157.  
  158. 'Initialize Properties for User Control
  159. Private Sub UserControl_InitProperties()
  160.     m_Style = m_def_Style
  161. End Sub
  162.  
  163. 'Load property values from storage
  164. Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  165.     m_Style = PropBag.ReadProperty("Style", m_def_Style)
  166.     UserControl_Resize
  167. End Sub
  168.  
  169. 'Write property values to storage
  170. Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  171.  
  172.     Call PropBag.WriteProperty("Style", m_Style, m_def_Style)
  173. End Sub

ИИ поможет Вам:

  • решить любую задачу по программированию
  • объяснить код
  • расставить комментарии в коде
  • и т.д
Попробуйте бесплатно

Оцени полезность:

8   голосов , оценка 4.375 из 5

Нужна аналогичная работа?

Оформи быстрый заказ и узнай стоимость

Бесплатно
Оформите заказ и авторы начнут откликаться уже через 10 минут
Похожие ответы