home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 5_2007-2008.ISO / data / Zips / Righello207379732007.psc / EdgeStuff.bas < prev    next >
BASIC Source File  |  2006-11-13  |  8KB  |  229 lines
  1. Attribute VB_Name = "EdgeStuff"
  2. Option Explicit
  3.  
  4. Private Enum sedBorderWidth
  5.     sbwNone
  6.     sbwSingle
  7.     sbwDouble
  8. End Enum
  9.  
  10. Private Const SED_OLDPROC = "SED_OLDPROC"
  11. Private Const SED_OLDGWLSTYLE = "SED_OLDGWLSTYLE"
  12. Private Const SED_OLDGWLEXSTYLE = "SED_OLDGWLEXSTYLE"
  13. Private Const SED_BORDERS = "SED_BORDERS"
  14.  
  15. Private Const WM_NCPAINT = &H85
  16.  
  17. Private Const SWP_FRAMECHANGED = &H20
  18. Private Const SWP_NOACTIVATE = &H10
  19. Private Const SWP_NOMOVE = &H2
  20. Private Const SWP_NOOWNERZORDER = &H200
  21. Private Const SWP_NOREDRAW = &H8
  22. Private Const SWP_NOSIZE = &H1
  23. Private Const SWP_NOZORDER = &H4
  24. Private Const SWP_SHOWWINDOW = &H40
  25.  
  26. Private Const BDR_INNER = &HC
  27. Private Const BDR_OUTER = &H3
  28. Private Const BDR_RAISED = &H5
  29. Private Const BDR_RAISEDINNER = &H4
  30. Private Const BDR_RAISEDOUTER = &H1
  31. Private Const BDR_SUNKEN = &HA
  32. Private Const BDR_SUNKENINNER = &H8
  33. Private Const BDR_SUNKENOUTER = &H2
  34.  
  35. Private Const BF_LEFT = &H1
  36. Private Const BF_RIGHT = &H4
  37. Private Const BF_TOP = &H2
  38. Private Const BF_BOTTOM = &H8
  39. Private Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)
  40.  
  41. Private Const GWL_WNDPROC = (-4)
  42. Private Const GWL_STYLE = (-16)
  43. Private Const GWL_EXSTYLE = (-20)
  44.  
  45. Private Const WS_THICKFRAME = &H40000
  46. Private Const WS_BORDER = &H800000
  47. Private Const WS_EX_WINDOWEDGE = &H100&
  48. Private Const WS_EX_CLIENTEDGE = &H200&
  49. Private Const WS_EX_STATICEDGE = &H20000
  50.  
  51. Private Type RECT
  52.         Left As Long
  53.         Top As Long
  54.         Right As Long
  55.         Bottom As Long
  56. End Type
  57.  
  58. Private Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long
  59. Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
  60. Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
  61. Private Declare Function DrawEdge Lib "user32" (ByVal hDC As Long, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long
  62.  
  63. Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
  64. Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  65. Private Declare Function 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) As Long
  66. Private 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
  67.  
  68. Public Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
  69. Public Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
  70. Public Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
  71.  
  72. Private Function pWindowProc( _
  73.     ByVal hWnd As Long, _
  74.     ByVal uMsg As Long, _
  75.     ByVal wParam As Long, _
  76.     ByVal lParam As Long) As Long
  77.     
  78.     Select Case uMsg
  79.     
  80.         Case WM_NCPAINT
  81.             
  82.             pDrawBorder hWnd, wParam, GetProp(hWnd, SED_BORDERS)
  83.         
  84.         Case Else
  85.             pWindowProc = CallWindowProc(GetProp(hWnd, SED_OLDPROC), hWnd, uMsg, wParam, lParam)
  86.             
  87.     End Select
  88. End Function
  89.  
  90. Private Sub pDrawBorder(ByVal hWnd As Long, ByVal wParam As Long, ByVal lBorderType As rlrBorderStyle)
  91. Dim lRet As Long
  92. Dim lMode As Long
  93. Dim hDC As Long
  94. Dim Rec As RECT
  95.     If lBorderType = rlrNoBorder Then Exit Sub
  96.     
  97.     hDC = GetWindowDC(hWnd)
  98.     
  99.     lRet = GetWindowRect(hWnd, Rec)
  100.     
  101.     Rec.Right = Rec.Right - Rec.Left
  102.     Rec.Bottom = Rec.Bottom - Rec.Top
  103.     Rec.Left = 0
  104.     Rec.Top = 0
  105.  
  106.     lMode = 0
  107.     Select Case lBorderType
  108.         Case rlrRaised
  109.             lMode = BDR_RAISED
  110.         Case rlrRaisedInner
  111.             lMode = BDR_RAISEDINNER
  112.         Case rlrSunken
  113.             lMode = BDR_SUNKEN
  114.         Case rlrSunkenOuter
  115.             lMode = BDR_SUNKENOUTER
  116.         Case rlrEtched
  117.             lMode = BDR_SUNKENOUTER Or BDR_RAISEDINNER
  118.         Case rlrBump
  119.             lMode = BDR_SUNKENINNER Or BDR_RAISEDOUTER
  120.     End Select
  121.     
  122.     lRet = DrawEdge(hDC, Rec, lMode, BF_RECT)
  123.     lRet = ReleaseDC(hWnd, hDC)
  124. End Sub
  125.  
  126. Public Function EdgeSubClass(ByVal hWnd As Long, ByVal eBorderStyle As rlrBorderStyle) As Boolean
  127. Dim lRet As Long
  128.     lRet = GetProp(hWnd, SED_OLDPROC)
  129.  
  130.     If lRet <> 0 Then
  131.         SetWindowLong hWnd, GWL_WNDPROC, lRet
  132.     Else
  133.         SetProp hWnd, SED_OLDGWLSTYLE, GetWindowLong(hWnd, GWL_STYLE)
  134.         SetProp hWnd, SED_OLDGWLEXSTYLE, GetWindowLong(hWnd, GWL_EXSTYLE)
  135.     End If
  136.     
  137.     pSetBorder hWnd, eBorderStyle
  138.     
  139.     lRet = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf pWindowProc)
  140.  
  141.     SetProp hWnd, SED_OLDPROC, lRet
  142.     SetProp hWnd, SED_BORDERS, CLng(eBorderStyle)
  143.  
  144.     SetWindowPos hWnd, 0, 0, 0, 0, 0, _
  145.         SWP_NOMOVE Or _
  146.         SWP_NOSIZE Or _
  147.         SWP_NOOWNERZORDER Or _
  148.         SWP_NOZORDER Or _
  149.         SWP_FRAMECHANGED
  150.  
  151.     EdgeSubClass = (lRet <> 0)
  152. End Function
  153.  
  154. Public Function EdgeUnSubClass(ByVal hWnd As Long) As Boolean
  155. Dim lRet As Long
  156.     lRet = GetProp(hWnd, SED_OLDPROC)
  157.     
  158.     If lRet <> 0 Then
  159.         lRet = SetWindowLong(hWnd, GWL_WNDPROC, lRet)
  160.         
  161.         SetWindowLong hWnd, GWL_STYLE, GetProp(hWnd, SED_OLDGWLSTYLE)
  162.         SetWindowLong hWnd, GWL_EXSTYLE, GetProp(hWnd, SED_OLDGWLEXSTYLE)
  163.         
  164.         SetWindowPos hWnd, 0, 0, 0, 0, 0, _
  165.             SWP_NOMOVE Or _
  166.             SWP_NOSIZE Or _
  167.             SWP_NOOWNERZORDER Or _
  168.             SWP_NOZORDER Or _
  169.             SWP_FRAMECHANGED
  170.         
  171.         RemoveProp hWnd, SED_OLDPROC
  172.         RemoveProp hWnd, SED_OLDGWLSTYLE
  173.         RemoveProp hWnd, SED_OLDGWLEXSTYLE
  174.         RemoveProp hWnd, SED_BORDERS
  175.     End If
  176.     
  177.     EdgeUnSubClass = (lRet <> 0)
  178. End Function
  179.  
  180. Private Sub pSetBorder(ByVal hWnd As Long, ByVal eBorderStyle As rlrBorderStyle)
  181. Dim pWidth As sedBorderWidth
  182.     
  183.     Select Case eBorderStyle
  184.         Case rlrNoBorder
  185.             pWidth = sbwNone
  186.         Case rlrRaised
  187.             pWidth = sbwDouble
  188.         Case rlrRaisedInner
  189.             pWidth = sbwSingle
  190.         Case rlrSunken
  191.             pWidth = sbwDouble
  192.         Case rlrSunkenOuter
  193.             pWidth = sbwSingle
  194.         Case rlrEtched
  195.             pWidth = sbwDouble
  196.         Case rlrBump
  197.             pWidth = sbwDouble
  198.     End Select
  199.     
  200.     Select Case pWidth
  201.         Case sbwNone
  202.             pWinStyleNeg hWnd, GWL_STYLE, WS_BORDER Or WS_THICKFRAME
  203.             pWinStyleNeg hWnd, GWL_EXSTYLE, WS_EX_STATICEDGE Or WS_EX_CLIENTEDGE Or WS_EX_WINDOWEDGE
  204.         Case sbwSingle
  205.             pWinStyleNeg hWnd, GWL_STYLE, WS_BORDER Or WS_THICKFRAME
  206.             pWinStyleNeg hWnd, GWL_EXSTYLE, WS_EX_CLIENTEDGE Or WS_EX_WINDOWEDGE
  207.             pWinStyleAdd hWnd, GWL_EXSTYLE, WS_EX_STATICEDGE
  208.         Case sbwDouble
  209.             pWinStyleNeg hWnd, GWL_STYLE, WS_BORDER Or WS_THICKFRAME
  210.             pWinStyleNeg hWnd, GWL_EXSTYLE, WS_EX_STATICEDGE Or WS_EX_WINDOWEDGE
  211.             pWinStyleAdd hWnd, GWL_EXSTYLE, WS_EX_CLIENTEDGE
  212.     End Select
  213.     
  214.     SetWindowPos hWnd, 0, 0, 0, 0, 0, _
  215.         SWP_NOMOVE Or _
  216.         SWP_NOSIZE Or _
  217.         SWP_NOOWNERZORDER Or _
  218.         SWP_NOZORDER Or _
  219.         SWP_FRAMECHANGED
  220. End Sub
  221.  
  222. Private Sub pWinStyleAdd(ByVal hWnd As Long, ByVal lStyle As Long, ByVal lFlags As Long)
  223.     SetWindowLong hWnd, lStyle, GetWindowLong(hWnd, lStyle) Or lFlags
  224. End Sub
  225.  
  226. Private Sub pWinStyleNeg(ByVal hWnd As Long, ByVal lStyle As Long, ByVal lFlags As Long)
  227.     SetWindowLong hWnd, lStyle, GetWindowLong(hWnd, lStyle) And Not lFlags
  228. End Sub
  229.