home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / CODE_UPLOAD1259312112000.psc / modEffects.bas < prev    next >
Encoding:
BASIC Source File  |  2000-12-11  |  5.4 KB  |  159 lines
  1. Attribute VB_Name = "modEffects"
  2. 'Declarations for ExplodeForm
  3. Type RECT
  4.         Left As Long
  5.         Top As Long
  6.         Right As Long
  7.         Bottom As Long
  8. End Type
  9. Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
  10. Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  11. Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
  12. Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
  13. Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
  14. Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long  'note error in declare
  15. Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
  16.  
  17.  
  18. 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
  19. Public Const conHwndTopmost = -1
  20. Public Const conHwndNoTopmost = -2
  21. Public Const conSwpNoActivate = &H10
  22. Public Const conSwpShowWindow = &H40
  23.  
  24.  
  25. '__________________________________________________
  26. ' Scope  : 
  27. ' Type   : Sub
  28. ' Name   : ExplodeForm
  29. ' Params : 
  30. '          frm As Form
  31. '          Steps As Long
  32. '          Color As VBRUN.ColorConstants
  33. ' Returns: Nothing
  34. ' Desc   : The Sub uses parameters frm As Form, Steps As Long and Color As VBRUN.ColorConstants for ExplodeForm and returns Nothing.
  35. '__________________________________________________
  36. ' History
  37. ' CDK: 20001112: Added Error Trapping & Comments using
  38. '        Auto-Code Commenter
  39. '__________________________________________________
  40. Sub ExplodeForm(frm As Form, Steps As Long, Color As VBRUN.ColorConstants)
  41.     On Error GoTo Proc_Err
  42.     Const csProcName As String = "ExplodeForm"
  43.    Dim ThisRect As RECT, RectWidth As Integer, RectHeight As Integer, ScreenDevice As Long, NewBrush As Long, OldBrush As Long, I As Long, x As Integer, y As Integer, XRect As Integer, YRect As Integer
  44.    If Steps < 20 Then Steps = 20
  45.    'Zooming speed will be different based on machine speed!
  46.    If Color = 0 Then
  47.       Color = frm.BackColor
  48.    End If
  49.    
  50.    
  51.    Steps = Steps * 10
  52.    'Get current form window dimensions
  53.    GetWindowRect frm.hwnd, ThisRect
  54.    RectWidth = (ThisRect.Right - ThisRect.Left)
  55.    RectHeight = ThisRect.Bottom - ThisRect.Top
  56.    'Get a device handle for the screen
  57.    ScreenDevice = GetDC(0)
  58.    'Create a brush for drawing to the screen
  59.    'and save the old brush
  60.    NewBrush = CreateSolidBrush(Color)
  61.    OldBrush = SelectObject(ScreenDevice, NewBrush)
  62.    For I = 1 To Steps
  63.       XRect = RectWidth * (I / Steps)
  64.       YRect = RectHeight * (I / Steps)
  65.       x = ThisRect.Left + (RectWidth - XRect) / 2
  66.       y = ThisRect.Top + (RectHeight - YRect) / 2
  67.       'Incrementally draw rectangle
  68.       Rectangle ScreenDevice, x, y, x + XRect, y + YRect
  69.    Next I
  70.    'Return old brush and delete screen device context handle
  71.    'Then destroy brush that drew rectangles
  72.    Call SelectObject(ScreenDevice, OldBrush)
  73.    Call ReleaseDC(0, ScreenDevice)
  74.    DeleteObject (NewBrush)
  75.  
  76. Proc_Exit:
  77.     GoSub Proc_Cleanup
  78.     Exit Sub
  79.  
  80. Proc_Cleanup:
  81.     On Error Resume Next
  82.     'Place any cleanup of instantiated objects here    
  83.     On Error GoTo 0
  84.     Return
  85.  
  86. Proc_Err:
  87.     Dim lErrNum As String, sErrSource As String, sErrDesc As String
  88.     lErrNum = VBA.Err.Number
  89.     sErrSource = VBA.Err.Source & vbcrlf & "modEffects->"  & csProcName
  90.     sErrDesc = VBA.Err.Description
  91.     Resume Proc_Err_Continue
  92.     
  93. Proc_Err_Continue:
  94.     GoSub Proc_Cleanup
  95.     Err.Raise Number:=lErrNum, Source:=sErrSource, Description:=sErrDesc
  96.     Exit Sub
  97.     
  98. End Sub
  99.  
  100. '__________________________________________________
  101. ' Scope  : Public
  102. ' Type   : Sub
  103. ' Name   : FormAlwaysOnTop
  104. ' Params : 
  105. '          oForm As Form
  106. '          fOnTop As Boolean
  107. ' Returns: Nothing
  108. ' Desc   : The Sub uses parameters oForm As Form and fOnTop As Boolean for FormAlwaysOnTop and returns Nothing.
  109. '__________________________________________________
  110. ' History
  111. ' CDK: 20001112: Added Error Trapping & Comments using
  112. '        Auto-Code Commenter
  113. '__________________________________________________
  114. Public Sub FormAlwaysOnTop(oForm As Form, fOnTop As Boolean)
  115.     On Error GoTo Proc_Err
  116.     Const csProcName As String = "FormAlwaysOnTop"
  117.     
  118.     Dim vTopSwitch As Variant
  119.  
  120.     If fOnTop Then
  121.         vTopSwitch = conHwndTopmost
  122.     Else
  123.         vTopSwitch = conHwndNoTopmost
  124.     End If
  125.     
  126.     SetWindowPos oForm.hwnd, _
  127.                 vTopSwitch, _
  128.                 oForm.Left / Screen.TwipsPerPixelX, _
  129.                 oForm.Top / Screen.TwipsPerPixelY, _
  130.                 oForm.Width / Screen.TwipsPerPixelX, _
  131.                 oForm.Height / Screen.TwipsPerPixelY, _
  132.                 conSwdpNoActivate Or conSwpShowWindow
  133.     
  134.  
  135. Proc_Exit:
  136.     GoSub Proc_Cleanup
  137.     Exit Sub
  138.  
  139. Proc_Cleanup:
  140.     On Error Resume Next
  141.     'Place any cleanup of instantiated objects here    
  142.     On Error GoTo 0
  143.     Return
  144.  
  145. Proc_Err:
  146.     Dim lErrNum As String, sErrSource As String, sErrDesc As String
  147.     lErrNum = VBA.Err.Number
  148.     sErrSource = VBA.Err.Source & vbcrlf & "modEffects->"  & csProcName
  149.     sErrDesc = VBA.Err.Description
  150.     Resume Proc_Err_Continue
  151.     
  152. Proc_Err_Continue:
  153.     GoSub Proc_Cleanup
  154.     Err.Raise Number:=lErrNum, Source:=sErrSource, Description:=sErrDesc
  155.     Exit Sub
  156.     
  157. End Sub
  158.  
  159.