home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / Snake_Game398431262001.psc / frmAboutScreen.frm (.txt) next >
Encoding:
Visual Basic Form  |  2001-12-06  |  7.6 KB  |  190 lines
  1. VERSION 5.00
  2. Begin VB.Form frmAboutScreen 
  3.    BorderStyle     =   1  'Fixed Single
  4.    Caption         =   "About"
  5.    ClientHeight    =   2565
  6.    ClientLeft      =   45
  7.    ClientTop       =   330
  8.    ClientWidth     =   4575
  9.    BeginProperty Font 
  10.       Name            =   "Comic Sans MS"
  11.       Size            =   14.25
  12.       Charset         =   0
  13.       Weight          =   700
  14.       Underline       =   0   'False
  15.       Italic          =   -1  'True
  16.       Strikethrough   =   0   'False
  17.    EndProperty
  18.    Icon            =   "frmAboutScreen.frx":0000
  19.    LinkTopic       =   "Form1"
  20.    MaxButton       =   0   'False
  21.    MinButton       =   0   'False
  22.    ScaleHeight     =   2565
  23.    ScaleWidth      =   4575
  24.    ShowInTaskbar   =   0   'False
  25.    StartUpPosition =   2  'CenterScreen
  26.    Begin VB.Timer timText 
  27.       Interval        =   1
  28.       Left            =   0
  29.       Top             =   480
  30.    End
  31.    Begin VB.CommandButton cmdOk 
  32.       Caption         =   "&Ok"
  33.       Default         =   -1  'True
  34.       BeginProperty Font 
  35.          Name            =   "MS Sans Serif"
  36.          Size            =   8.25
  37.          Charset         =   0
  38.          Weight          =   400
  39.          Underline       =   0   'False
  40.          Italic          =   0   'False
  41.          Strikethrough   =   0   'False
  42.       EndProperty
  43.       Height          =   375
  44.       Left            =   1740
  45.       TabIndex        =   1
  46.       Top             =   2160
  47.       Width           =   1095
  48.    End
  49.    Begin VB.PictureBox picText 
  50.       BackColor       =   &H00000000&
  51.       BorderStyle     =   0  'None
  52.       BeginProperty Font 
  53.          Name            =   "Comic Sans MS"
  54.          Size            =   11.25
  55.          Charset         =   0
  56.          Weight          =   400
  57.          Underline       =   0   'False
  58.          Italic          =   0   'False
  59.          Strikethrough   =   0   'False
  60.       EndProperty
  61.       ForeColor       =   &H0000FFFF&
  62.       Height          =   1935
  63.       Left            =   0
  64.       ScaleHeight     =   1935
  65.       ScaleWidth      =   4575
  66.       TabIndex        =   0
  67.       Top             =   0
  68.       Visible         =   0   'False
  69.       Width           =   4575
  70.    End
  71.    Begin VB.Line lnSpacer 
  72.       X1              =   120
  73.       X2              =   4440
  74.       Y1              =   2040
  75.       Y2              =   2040
  76.    End
  77. Attribute VB_Name = "frmAboutScreen"
  78. Attribute VB_GlobalNameSpace = False
  79. Attribute VB_Creatable = False
  80. Attribute VB_PredeclaredId = True
  81. Attribute VB_Exposed = False
  82. 'This screen was first created on the 17/11/2001 and was intended
  83. 'for use in several future programs. The idea was that I should only
  84. 'have to create this screen once and be able to integrate it into any
  85. 'other project seemlessly. I wanted to do this instead of creating a
  86. 'new about screen for every project where I wanted one.
  87. 'A note on this About Screen :
  88. 'This screen requires the module APIGraphics (APIGraphics.bas) to
  89. 'operate the display.
  90. 'Eric O'Sullivan
  91. 'email DiskJunky@hotmail.com
  92. '============================================================
  93. Dim AllText As String
  94. Dim Start As Boolean
  95. Private Sub cmdOk_Click()
  96. 'exit screen
  97. Unload Me
  98. End Sub
  99. Private Sub Form_Load()
  100. Call SetText
  101. End Sub
  102. Private Sub timText_Timer()
  103. 'This timer will scroll the animated text
  104. Const Wait = 50 'wait 15 ticks before drawing the next frame
  105. Dim Font As FontStruc
  106. Dim Bmp As BitmapStruc
  107. Dim Mask As BitmapStruc
  108. Dim BmpSize As Rect
  109. Dim Result As Integer
  110. Dim TextHeight As Integer
  111. Dim StartingTick As Long
  112. Static Surphase As BitmapStruc
  113. Static Scroll As Integer
  114. 'find out how much time it takes to draw a frame
  115. StartingTick = GetTickCount
  116. 'set the bitmap dimensions and create them
  117. BmpSize.Right = picText.ScaleWidth
  118. BmpSize.Bottom = picText.ScaleHeight
  119. Call RectToPixels(BmpSize)
  120. Mask.Area = BmpSize
  121. Surphase.Area = BmpSize
  122. Bmp.Area = BmpSize
  123. 'set font variables
  124. Font.Alignment = vbCentreAlign
  125. Font.Name = picText.FontName
  126. Font.Bold = picText.FontBold
  127. Font.Colour = vbWhite 'picText.ForeColor
  128. Font.Italic = picText.FontItalic
  129. Font.StrikeThru = picText.FontStrikethru
  130. Font.PointSize = picText.FontSize
  131. Font.Underline = picText.FontUnderline
  132. 'test code - not currently used
  133. 'Call MakeText(picText.hDc, "Hello World!", 0, 0, 40, 180, Font, InPixels)
  134. TextHeight = GetTextHeight(picText.hDc) * LineCount(AllText)
  135. Scroll = Scroll - Screen.TwipsPerPixelY
  136. If (Scroll < -(TextHeight * Screen.TwipsPerPixelY)) Or (Not Start) Then
  137.     Scroll = picText.ScaleHeight '+ (TextHeight * Screen.TwipsPerPixelY)
  138.     Start = True
  139. End If
  140. 'only create the surphase if necessary
  141. If Surphase.hDcMemory = 0 Then
  142.     Call CreateNewBitmap(Surphase.hDcMemory, Surphase.hDcBitmap, Surphase.hDcPointer, Surphase.Area, frmAboutScreen, picText.ForeColor, InPixels)
  143.     'create the surphase
  144.     'text fade in
  145.     Call Gradient(Surphase.hDcMemory, picText.ForeColor, picText.FillColor, 0, (Surphase.Area.Bottom - ((TextHeight / LineCount(AllText)) * 2)), Surphase.Area.Right, (TextHeight / LineCount(AllText) * 2), GradHorizontal, InPixels)
  146.     'text fade out
  147.     Call Gradient(Surphase.hDcMemory, picText.FillColor, picText.ForeColor, 0, 0, Surphase.Area.Right, (TextHeight / LineCount(AllText)) * 2, GradHorizontal, InPixels)
  148. End If
  149. Call CreateNewBitmap(Mask.hDcMemory, Mask.hDcBitmap, Mask.hDcPointer, Mask.Area, frmAboutScreen, vbBlack, InPixels)
  150. Call CreateNewBitmap(Bmp.hDcMemory, Bmp.hDcBitmap, Bmp.hDcPointer, Bmp.Area, frmAboutScreen, vbWhite, InPixels)
  151. 'draw the text onto the mask in black
  152. Call MakeText(Mask.hDcMemory, AllText, (Scroll / Screen.TwipsPerPixelY), 0, TextHeight, Bmp.Area.Right, Font, InPixels)
  153. 'copy the surphase onto the background
  154. Result = BitBlt(Bmp.hDcMemory, 0, 0, Bmp.Area.Right, Bmp.Area.Bottom, Surphase.hDcMemory, 0, 0, SRCCOPY)
  155. 'place the mask onto the background
  156. Result = BitBlt(Bmp.hDcMemory, 0, 0, Bmp.Area.Right, Bmp.Area.Bottom, Mask.hDcMemory, 0, 0, SRCAND)
  157. 'copy the result to the screen
  158. Result = BitBlt(frmAboutScreen.hDc, 0, 0, Bmp.Area.Right, Bmp.Area.Bottom, Bmp.hDcMemory, 0, 0, SRCCOPY)
  159. 'remove the bitmaps created
  160. Call DeleteBitmap(Bmp.hDcMemory, Bmp.hDcBitmap, Bmp.hDcPointer)
  161. Call DeleteBitmap(Mask.hDcMemory, Mask.hDcBitmap, Mask.hDcPointer)
  162. 'wait X ticks minus the time it took to draw the frame
  163. Call Pause(Wait - (GetTickCount - StartingTick))
  164. End Sub
  165. Private Sub SetText()
  166. 'This procedure is used to setting the text displayed in the picture box
  167. '" & vbCrLf & "
  168. 'please note that ProductName can be set by going to
  169. 'Project, Project Properties,Make tab. You should see a list box about
  170. 'half way down on the left side. Scroll down until you come to
  171. 'Product Name and enter some text into the text box on the right
  172. 'side of the list box.
  173. AllText = App.ProductName & vbCrLf & "Version " & App.Major & "." & App.Minor & "." & App.Revision & vbCrLf & "" & vbCrLf & "This program was made by" & vbCrLf & "Eric O'Sullivan." & vbCrLf & "" & vbCrLf & "Copyright 2001" & vbCrLf & "All rights reserved" & vbCrLf & "" & vbCrLf & "For more information, email" & vbCrLf & "DiskJunky@hotmail.com"
  174. End Sub
  175. Public Function LineCount(Text As String) As Integer
  176. 'This function will return the number of lines in the text
  177. Dim Temp As Integer
  178. Dim Counter As Integer
  179. Dim LastPos As Integer
  180. LastPos = 1
  181.     Temp = LastPos
  182.     LastPos = InStr(LastPos + Len(vbCrLf), Text, vbCrLf)
  183.     If Temp <> LastPos Then
  184.         'a line was found
  185.         Counter = Counter + 1
  186.     End If
  187. Loop Until LastPos = 0 'LastPos will =0 when InStr cannot find any more occurances of vbCrlf
  188. LineCount = Counter
  189. End Function
  190.