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 / modScrollingSplashScreen.bas < prev    next >
Encoding:
BASIC Source File  |  2000-12-11  |  7.4 KB  |  190 lines
  1. Attribute VB_Name = "modScrollingSplashScreen"
  2. Option Explicit
  3.  
  4.  
  5. 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
  6.  
  7. Private Const SRCCOPY = &HCC0020
  8.  
  9. '__________________________________________________
  10. ' Scope  : Public
  11. ' Type   : Function
  12. ' Name   : g_funScrollText
  13. ' Params : 
  14. '          ByRef v_strTextArray() As String
  15. '          ByRef r_ctlBackgroundBuffer As Control
  16. '          ByRef r_ctlTempBuffer As Control
  17. '          ByRef r_ctlDestinationBuffer As Control
  18. '          ByVal v_lngRGBStartColor As Long
  19. '          ByVal v_lngRGBEndColor As Long
  20. '          ByVal v_lngCurrentY As Long
  21. '          ByVal v_lngLeftMargine As Long
  22. '          ByVal v_enuAlignment As VBRUN.AlignmentConstants
  23. ' Returns: Boolean
  24. ' Desc   : The Function uses parameters ByRef v_strTextArray() As String, ByRef r_ctlBackgroundBuffer As Control, ByRef r_ctlTempBuffer As Control, ByRef r_ctlDestinationBuffer As Control, ByVal v_lngRGBStartColor As Long, ByVal v_lngRGBEndColor As Long, ByVal v_lngCurrentY As Long, ByVal v_lngLeftMargine As Long and ByVal v_enuAlignment As VBRUN.AlignmentConstants for g_funScrollText and returns Boolean.
  25. '__________________________________________________
  26. ' History
  27. ' CDK: 20001112: Added Error Trapping & Comments using
  28. '        Auto-Code Commenter
  29. '__________________________________________________
  30. Public Function g_funScrollText(ByRef v_strTextArray() As String, ByRef r_ctlBackgroundBuffer As Control, ByRef r_ctlTempBuffer As Control, ByRef r_ctlDestinationBuffer As Control, ByVal v_lngRGBStartColor As Long, ByVal v_lngRGBEndColor As Long, ByVal v_lngCurrentY As Long, ByVal v_lngLeftMargine As Long, ByVal v_enuAlignment As VBRUN.AlignmentConstants) As Boolean
  31.     On Error GoTo Proc_Err
  32.     Const csProcName As String = "g_funScrollText"
  33.    
  34.    Dim l_lngStartRed   As Long
  35.    Dim l_lngStartGreen As Long
  36.    Dim l_lngStartBlue  As Long
  37.    
  38.    Dim l_lngEndRed     As Long
  39.    Dim l_lngEndGreen   As Long
  40.    Dim l_lngEndBlue    As Long
  41.  
  42.    Dim l_lngCurrentRed   As Long
  43.    Dim l_lngCurrentGreen As Long
  44.    Dim l_lngCurrentBlue  As Long
  45.  
  46.    Dim l_sngRedOffset    As Single
  47.    Dim l_sngGreenOffset  As Single
  48.    Dim l_sngBlueOffset   As Single
  49.    
  50.    Dim l_sngTextHeight  As Single
  51.    Dim l_lngScaleHeight As Single
  52.    Dim l_lngScaleWidth  As Single
  53.  
  54.    Dim l_lngLineNumber     As Long
  55.    Dim l_lngNumberOfLines  As Long
  56.  
  57.  
  58.    g_funScrollText = True
  59.    
  60.    l_lngNumberOfLines = UBound(v_strTextArray)
  61.                            
  62.    l_sngTextHeight = r_ctlTempBuffer.TextHeight("ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  63.    l_lngScaleHeight = r_ctlTempBuffer.ScaleHeight
  64.    l_lngScaleWidth = r_ctlTempBuffer.ScaleWidth
  65.                            
  66.    If (v_lngRGBStartColor <> v_lngRGBEndColor) Then
  67.       Call g_subGetRGBColors(v_lngRGBStartColor, l_lngStartRed, l_lngStartGreen, l_lngStartBlue)
  68.       Call g_subGetRGBColors(v_lngRGBEndColor, l_lngEndRed, l_lngEndGreen, l_lngEndBlue)
  69.       
  70.       l_sngRedOffset = (CSng(l_lngEndRed - l_lngStartRed) / (l_lngScaleHeight - l_sngTextHeight))
  71.       l_sngGreenOffset = (CSng(l_lngEndGreen - l_lngStartGreen) / (l_lngScaleHeight - l_sngTextHeight))
  72.       l_sngBlueOffset = (CSng(l_lngEndBlue - l_lngStartBlue) / (l_lngScaleHeight - l_sngTextHeight))
  73.    Else
  74.       Call g_subGetRGBColors(v_lngRGBStartColor, l_lngCurrentRed, l_lngCurrentGreen, l_lngCurrentBlue)
  75.    End If
  76.    
  77.    BitBlt r_ctlTempBuffer.hdc, 0, r_ctlTempBuffer.ScaleTop, l_lngScaleWidth, l_lngScaleHeight, _
  78.           r_ctlBackgroundBuffer.hdc, 0, 0, SRCCOPY
  79.           
  80.    With r_ctlTempBuffer
  81.       For l_lngLineNumber = 0 To l_lngNumberOfLines
  82.          .CurrentY = v_lngCurrentY + (l_lngLineNumber * .FontSize + (6 * l_lngLineNumber))
  83.          If (v_enuAlignment = vbCenter) Then
  84.             .CurrentX = (l_lngScaleWidth - .TextWidth(v_strTextArray(l_lngLineNumber))) / 2
  85.          ElseIf (v_enuAlignment = vbLeftJustify) Then
  86.             .CurrentX = 0
  87.          ElseIf (v_enuAlignment = vbRightJustify) Then
  88.             .CurrentX = l_lngScaleWidth - .TextWidth(v_strTextArray(l_lngLineNumber))
  89.          End If
  90.  
  91.          .CurrentX = .CurrentX + v_lngLeftMargine
  92.          
  93.          If Not (.CurrentY > l_lngScaleHeight) And _
  94.             Not (.CurrentY < -l_sngTextHeight) Then
  95.             If (v_lngRGBStartColor <> v_lngRGBEndColor) Then
  96.                l_lngCurrentRed = Abs(l_lngEndRed - (l_sngRedOffset * .CurrentY))
  97.                l_lngCurrentGreen = Abs(l_lngEndGreen - (l_sngGreenOffset * .CurrentY))
  98.                l_lngCurrentBlue = Abs(l_lngEndBlue - (l_sngBlueOffset * .CurrentY))
  99.             End If
  100.             
  101.             .ForeColor = RGB(l_lngCurrentRed, l_lngCurrentGreen, l_lngCurrentBlue)
  102.  
  103.             r_ctlTempBuffer.Print v_strTextArray(l_lngLineNumber)
  104.          End If
  105.  
  106.          If (l_lngLineNumber = l_lngNumberOfLines) And (.CurrentY <= -l_sngTextHeight) Then
  107.             g_funScrollText = False
  108.          End If
  109.       Next
  110.    End With
  111.  
  112.    BitBlt r_ctlDestinationBuffer.hdc, 0, r_ctlDestinationBuffer.ScaleTop, r_ctlDestinationBuffer.ScaleWidth, r_ctlDestinationBuffer.ScaleHeight, _
  113.           r_ctlTempBuffer.hdc, 0, 0, SRCCOPY
  114.  
  115.    r_ctlDestinationBuffer.Refresh
  116.  
  117.  
  118. Proc_Exit:
  119.     GoSub Proc_Cleanup
  120.     Exit Function
  121.  
  122. Proc_Cleanup:
  123.     On Error Resume Next
  124.     'Place any cleanup of instantiated objects here    
  125.     On Error GoTo 0
  126.     Return
  127.  
  128. Proc_Err:
  129.     Dim lErrNum As String, sErrSource As String, sErrDesc As String
  130.     lErrNum = VBA.Err.Number
  131.     sErrSource = VBA.Err.Source & vbcrlf & "modScrollingSplashScreen->"  & csProcName
  132.     sErrDesc = VBA.Err.Description
  133.     Resume Proc_Err_Continue
  134.     
  135. Proc_Err_Continue:
  136.     GoSub Proc_Cleanup
  137.     Err.Raise Number:=lErrNum, Source:=sErrSource, Description:=sErrDesc
  138.     Exit Function
  139.     
  140. End Function
  141. '__________________________________________________
  142. ' Scope  : Public
  143. ' Type   : Sub
  144. ' Name   : g_subGetRGBColors
  145. ' Params : 
  146. ' Returns: _
  147. ' Desc   : The Sub uses parameters  for g_subGetRGBColors and returns _.
  148. '__________________________________________________
  149. ' History
  150. ' CDK: 20001112: Added Error Trapping & Comments using
  151. '        Auto-Code Commenter
  152. '__________________________________________________
  153. Public Sub g_subGetRGBColors(ByVal v_lngRGBColor As Long, _
  154.                              ByRef r_lngRedColor As Long, _
  155.                              ByRef r_lngGreenColor As Long, _
  156.                              ByRef r_lngBlueColor As Long)
  157.     On Error GoTo Proc_Err
  158.     Const csProcName As String = "g_subGetRGBColors"
  159.         
  160.     r_lngRedColor = v_lngRGBColor Mod 256
  161.     r_lngGreenColor = (v_lngRGBColor \ &H100) Mod 256
  162.     r_lngBlueColor = (v_lngRGBColor \ &H10000) Mod 256
  163.     
  164.  
  165. Proc_Exit:
  166.     GoSub Proc_Cleanup
  167.     Exit Sub
  168.  
  169. Proc_Cleanup:
  170.     On Error Resume Next
  171.     'Place any cleanup of instantiated objects here    
  172.     On Error GoTo 0
  173.     Return
  174.  
  175. Proc_Err:
  176.     Dim lErrNum As String, sErrSource As String, sErrDesc As String
  177.     lErrNum = VBA.Err.Number
  178.     sErrSource = VBA.Err.Source & vbcrlf & "modScrollingSplashScreen->"  & csProcName
  179.     sErrDesc = VBA.Err.Description
  180.     Resume Proc_Err_Continue
  181.     
  182. Proc_Err_Continue:
  183.     GoSub Proc_Cleanup
  184.     Err.Raise Number:=lErrNum, Source:=sErrSource, Description:=sErrDesc
  185.     Exit Sub
  186.     
  187. End Sub
  188.  
  189.  
  190.