home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / CODE_UPLOAD89558142000.psc / frmScroller.frm (.txt) next >
Encoding:
Visual Basic Form  |  2000-08-15  |  13.8 KB  |  354 lines
  1. VERSION 5.00
  2. Begin VB.Form frmScroller 
  3.    BorderStyle     =   1  'Fixed Single
  4.    Caption         =   "sinScroller"
  5.    ClientHeight    =   2760
  6.    ClientLeft      =   45
  7.    ClientTop       =   330
  8.    ClientWidth     =   6960
  9.    ControlBox      =   0   'False
  10.    LinkTopic       =   "Form1"
  11.    MaxButton       =   0   'False
  12.    MinButton       =   0   'False
  13.    ScaleHeight     =   184
  14.    ScaleMode       =   3  'Pixel
  15.    ScaleWidth      =   464
  16.    StartUpPosition =   3  'Windows Default
  17.    Begin VB.PictureBox picLogoMask 
  18.       Appearance      =   0  'Flat
  19.       AutoRedraw      =   -1  'True
  20.       AutoSize        =   -1  'True
  21.       BackColor       =   &H80000005&
  22.       BorderStyle     =   0  'None
  23.       ForeColor       =   &H80000008&
  24.       Height          =   960
  25.       Left            =   2400
  26.       Picture         =   "frmScroller.frx":0000
  27.       ScaleHeight     =   64
  28.       ScaleMode       =   3  'Pixel
  29.       ScaleWidth      =   132
  30.       TabIndex        =   7
  31.       Top             =   1410
  32.       Width           =   1980
  33.    End
  34.    Begin VB.PictureBox picSmallScroll 
  35.       Appearance      =   0  'Flat
  36.       AutoRedraw      =   -1  'True
  37.       BackColor       =   &H00000000&
  38.       ForeColor       =   &H80000008&
  39.       Height          =   165
  40.       Left            =   1680
  41.       ScaleHeight     =   135
  42.       ScaleWidth      =   585
  43.       TabIndex        =   5
  44.       Top             =   2400
  45.       Width           =   615
  46.    End
  47.    Begin VB.PictureBox picMask 
  48.       Appearance      =   0  'Flat
  49.       AutoRedraw      =   -1  'True
  50.       AutoSize        =   -1  'True
  51.       BackColor       =   &H80000005&
  52.       BorderStyle     =   0  'None
  53.       ForeColor       =   &H80000008&
  54.       Height          =   5145
  55.       Left            =   3720
  56.       Picture         =   "frmScroller.frx":01B7
  57.       ScaleHeight     =   5145
  58.       ScaleWidth      =   4800
  59.       TabIndex        =   4
  60.       Top             =   2400
  61.       Width           =   4800
  62.    End
  63.    Begin VB.CommandButton Command1 
  64.       Caption         =   "END"
  65.       Height          =   375
  66.       Left            =   5670
  67.       TabIndex        =   2
  68.       Top             =   2340
  69.       Width           =   1215
  70.    End
  71.    Begin VB.PictureBox picFont 
  72.       Appearance      =   0  'Flat
  73.       AutoRedraw      =   -1  'True
  74.       AutoSize        =   -1  'True
  75.       BackColor       =   &H80000005&
  76.       ForeColor       =   &H80000008&
  77.       Height          =   5175
  78.       Left            =   -2580
  79.       Picture         =   "frmScroller.frx":136D
  80.       ScaleHeight     =   343
  81.       ScaleMode       =   3  'Pixel
  82.       ScaleWidth      =   320
  83.       TabIndex        =   1
  84.       Top             =   1710
  85.       Width           =   4830
  86.    End
  87.    Begin VB.PictureBox picScroll 
  88.       Appearance      =   0  'Flat
  89.       AutoRedraw      =   -1  'True
  90.       BackColor       =   &H00000000&
  91.       ForeColor       =   &H80000008&
  92.       Height          =   2265
  93.       Left            =   0
  94.       ScaleHeight     =   149
  95.       ScaleMode       =   3  'Pixel
  96.       ScaleWidth      =   457
  97.       TabIndex        =   0
  98.       Top             =   30
  99.       Width           =   6885
  100.       Begin VB.PictureBox picLogo 
  101.          Appearance      =   0  'Flat
  102.          AutoRedraw      =   -1  'True
  103.          AutoSize        =   -1  'True
  104.          BackColor       =   &H80000005&
  105.          BorderStyle     =   0  'None
  106.          ForeColor       =   &H80000008&
  107.          Height          =   960
  108.          Left            =   450
  109.          Picture         =   "frmScroller.frx":5A85
  110.          ScaleHeight     =   64
  111.          ScaleMode       =   3  'Pixel
  112.          ScaleWidth      =   132
  113.          TabIndex        =   6
  114.          Top             =   270
  115.          Width           =   1980
  116.       End
  117.       Begin VB.PictureBox picSmallFont 
  118.          Appearance      =   0  'Flat
  119.          AutoRedraw      =   -1  'True
  120.          AutoSize        =   -1  'True
  121.          BackColor       =   &H80000005&
  122.          ForeColor       =   &H80000008&
  123.          Height          =   480
  124.          Left            =   3570
  125.          Picture         =   "frmScroller.frx":6111
  126.          ScaleHeight     =   450
  127.          ScaleWidth      =   2400
  128.          TabIndex        =   3
  129.          Top             =   330
  130.          Width           =   2430
  131.       End
  132.    End
  133. Attribute VB_Name = "frmScroller"
  134. Attribute VB_GlobalNameSpace = False
  135. Attribute VB_Creatable = False
  136. Attribute VB_PredeclaredId = True
  137. Attribute VB_Exposed = False
  138. Option Explicit
  139. Private Declare Function BitBlt Lib "gdi32" ( _
  140.    ByVal hdcDest As Long, ByVal XDest As Long, _
  141.    ByVal YDest As Long, ByVal nWidth As Long, _
  142.    ByVal nHeight As Long, ByVal hDCSrc As Long, _
  143.    ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) _
  144.    As Long
  145. Private Type aRefChar
  146.   xPos As Integer
  147.   yPos As Integer
  148. End Type
  149. Private abort As Boolean
  150. Private Const NOTSRCCOPY = &H330008 ' dest = (NOT source)
  151. Private Const NOTSRCERASE = &H1100A6 ' dest = (NOT src) AND (NOT dest)
  152. Private Const BLACKNESS = &H42 ' dest = BLACK
  153. Private Const DSTINVERT = &H550009 ' dest = (NOT dest)
  154. Private Const MERGECOPY = &HC000CA ' dest = (source AND pattern)
  155. Private Const MERGEPAINT = &HBB0226 ' dest = (NOT source) OR dest
  156. Private Const PATCOPY = &HF00021 ' dest = pattern
  157. Private Const PATINVERT = &H5A0049 ' dest = pattern XOR dest
  158. Private Const PATPAINT = &HFB0A09 ' dest = DPSnoo
  159. Private Const SRCAND = &H8800C6 ' dest = source AND dest
  160. Private Const SRCCOPY = &HCC0020 ' dest = source
  161. Private Const SRCERASE = &H440328 ' dest = source AND (NOT dest )
  162. Private Const SRCINVERT = &H660046 ' dest = source XOR dest
  163. Private Const SRCPAINT = &HEE0086 ' dest = source OR dest
  164. Private Const WHITENESS = &HFF0062  ' dest = WHITE
  165. Private scrollTextBig As String
  166. Private scrollTextSmall As String
  167. Private refCharBig(255) As aRefChar
  168. Private refCharSmall(255) As aRefChar
  169. Private refSin(3600) As Integer
  170. Private firstTime As Boolean
  171. Private Sub Command1_Click()
  172.   abort = True
  173. End Sub
  174. Private Sub Form_Load()
  175.   scrollTextBig = "       I'M BACK WITH SOME FINE SCROLL ROUTINES!!    HOW YA LIKE ME NOW!      BACK IN THE OLD DAYS I USED TO WRITE DEMO'S FOR THE ATARI-ST.  I DIDN'T USE ASSEMBLER BUT JUST PLAIN OMIKRON BASIC."
  176.   scrollTextBig = scrollTextBig & " THIS TIME I USED VISUAL BASIC. VB IS NOT SUPPOSED TO BE USED FOR DEMO PROGRAMMING BUT SOME OLD SKOOL EFFECTS DO WORK GREAT.  "
  177.   scrollTextBig = scrollTextBig & " GREETINGS TO ALL FORMER ATARI ST DEMO PROGRAMMERS AND SEE YOU SOON STNICCC .....   WRAP  .....                "
  178.   scrollTextSmall = "THIS SMALL DEMO WAS MADE BY THE ONE AND ONLY FLYGUY OF THE DOUBLE DUTCH CREW!        "
  179.   initChar
  180.   firstTime = True
  181.   picFont.Visible = False
  182.   picSmallFont.Visible = False
  183.   picMask.Visible = False
  184.   picSmallScroll.Visible = False
  185.   picLogo.Visible = False
  186.   picLogoMask.Visible = False
  187. End Sub
  188. Private Sub Form_Resize()
  189.   picScroll.Move 0, 0, Me.ScaleWidth, 150
  190.   picSmallScroll.Width = Me.ScaleWidth
  191.   picSmallScroll.Height = 12
  192.   picSmallScroll.Left = 0
  193.   firstTime = False
  194.   Scroll
  195. End Sub
  196. Private Sub Scroll()
  197.   Dim nofChar As Integer
  198.   Dim bigFontWidth As Long, bigFontHeight As Long
  199.   Dim bigCharX As Long
  200.   Dim ibigScroll As Long, iViewPort As Integer, iSmallScroll As Integer
  201.   Dim smallCharX As Long
  202.   Dim charPerPage As Long
  203.   Dim retVal As Long
  204.   Dim curChar As Byte
  205.   Dim Y As Long, i As Long, Y2 As Long, X As Long
  206.   Dim deg As Long
  207.   Dim change As Integer
  208.   Dim psScaleWidth As Long, psHDC As Long
  209.   Dim pfHDC As Long, pmHDC As Long, pssHDC As Long
  210.   Dim logoDeg As Long
  211.   Dim yLogo As Long
  212.   Dim xLogo As Long
  213.   Dim xLogoMax As Long, yLogoMax As Long
  214.   Dim yLogoSwap As Long, xLogoSwap As Long
  215.   bigFontWidth = 64
  216.   bigFontHeight = 49
  217.   picScroll.ScaleMode = vbPixels
  218.   picFont.ScaleMode = vbPixels
  219.   picSmallFont.ScaleMode = vbPixels
  220.   picSmallScroll.ScaleMode = vbPixels
  221.   psScaleWidth = picScroll.ScaleWidth
  222.   psHDC = picScroll.hDC
  223.   pfHDC = picFont.hDC
  224.   pmHDC = picMask.hDC
  225.   pssHDC = picSmallScroll.hDC
  226.   xLogoMax = psScaleWidth - picLogo.ScaleWidth
  227.   yLogoMax = picScroll.ScaleHeight - picLogo.ScaleHeight
  228.   xLogoSwap = 1
  229.   yLogoSwap = 1
  230.   xLogo = 0
  231.   yLogo = 0
  232.   charPerPage = picScroll.Width \ bigFontWidth + 1
  233.   nofChar = Len(scrollTextBig)
  234.   bigCharX = 0
  235.   ibigScroll = 1
  236.   iSmallScroll = 1
  237.   change = 1
  238.   While True
  239.     ' The small scroller
  240.     ' scroll to the left
  241.     picScroll.ClipControls = False
  242.     curChar = Asc(Mid$(scrollTextSmall, iSmallScroll, 1))
  243.     retVal = BitBlt(pssHDC, 0, 0, picSmallScroll.ScaleWidth, 12, _
  244.                     pssHDC, 1, 0, SRCCOPY)
  245.     ' add new piece of font
  246.     retVal = BitBlt(pssHDC, picSmallScroll.ScaleWidth - 1, 0, 1, 12, _
  247.                     picSmallFont.hDC, refCharSmall(curChar).xPos + smallCharX, refCharSmall(curChar).yPos, SRCCOPY)
  248.     ' copy to the screen
  249.     retVal = BitBlt(psHDC, 0, 0, psScaleWidth, 12, pssHDC, 0, 0, SRCCOPY)
  250.     retVal = BitBlt(psHDC, 0, 10, psScaleWidth, 12, psHDC, 0, 0, SRCCOPY)
  251.     retVal = BitBlt(psHDC, 0, 20, psScaleWidth, 24, psHDC, 0, 0, SRCCOPY)
  252.     retVal = BitBlt(psHDC, 0, 40, psScaleWidth, 48, psHDC, 0, 0, SRCCOPY)
  253.     retVal = BitBlt(psHDC, 0, 80, psScaleWidth, 70, psHDC, 0, 0, SRCCOPY)
  254.     smallCharX = smallCharX + 1
  255.     If smallCharX = 15 Then
  256.       smallCharX = 0
  257.       iSmallScroll = iSmallScroll + 1
  258.       If iSmallScroll > Len(scrollTextSmall) Then iSmallScroll = 1
  259.     End If
  260.     ' Dancing DDC logo
  261.     retVal = BitBlt(psHDC, xLogo, yLogo + i, 132, 64, picLogoMask.hDC, 0, 0, SRCAND)
  262.     retVal = BitBlt(psHDC, xLogo, yLogo + i, 132, 64, picLogo.hDC, 0, 0, SRCPAINT)
  263.     xLogo = xLogo + xLogoSwap
  264.     yLogo = yLogo + yLogoSwap
  265.     If xLogo = 0 Or xLogo = xLogoMax Then xLogoSwap = xLogoSwap * -1
  266.     If yLogo = 0 Or yLogo = yLogoMax Then yLogoSwap = yLogoSwap * -1
  267.     ' The BIG scoller
  268.     deg = deg + 10
  269.     If deg > 3600 Then deg = 0
  270.     change = 1
  271.     For iViewPort = 0 To charPerPage
  272.       Y = deg + (ibigScroll + iViewPort) * 200
  273.       If Y > 3600 Then Y = Y Mod 3600
  274.       Y2 = Y
  275.       'y2 = deg + (ibigScroll + iViewPort) * 250
  276.       'If y2 > 3600 Then y2 = y2 Mod 3600
  277.       X = iViewPort * bigFontWidth - bigCharX
  278.       curChar = Asc(Mid$(scrollTextBig, ibigScroll + iViewPort, 1))
  279.       If (ibigScroll + iViewPort) / 2 = (ibigScroll + iViewPort) \ 2 Then
  280.         retVal = BitBlt(psHDC, X, 50 - refSin(Y), bigFontWidth, bigFontHeight, _
  281.                         pmHDC, refCharBig(curChar).xPos, refCharBig(curChar).yPos, SRCAND)
  282.         retVal = BitBlt(psHDC, X, 50 - refSin(Y), bigFontWidth, bigFontHeight, _
  283.                         pfHDC, refCharBig(curChar).xPos, refCharBig(curChar).yPos, SRCPAINT)
  284.         retVal = BitBlt(psHDC, X, 50 + refSin(Y2), bigFontWidth, bigFontHeight, _
  285.                         pmHDC, refCharBig(curChar).xPos, refCharBig(curChar).yPos, SRCAND)
  286.         retVal = BitBlt(psHDC, X, 50 + refSin(Y2), bigFontWidth, bigFontHeight, _
  287.                         pfHDC, refCharBig(curChar).xPos, refCharBig(curChar).yPos, SRCPAINT)
  288.       Else
  289.         retVal = BitBlt(psHDC, X, 50 + refSin(Y2), bigFontWidth, bigFontHeight, _
  290.                         pmHDC, refCharBig(curChar).xPos, refCharBig(curChar).yPos, SRCAND)
  291.         retVal = BitBlt(psHDC, X, 50 + refSin(Y2), bigFontWidth, bigFontHeight, _
  292.                         pfHDC, refCharBig(curChar).xPos, refCharBig(curChar).yPos, SRCPAINT)
  293.         retVal = BitBlt(psHDC, X, 50 - refSin(Y), bigFontWidth, bigFontHeight, _
  294.                         pmHDC, refCharBig(curChar).xPos, refCharBig(curChar).yPos, SRCAND)
  295.         retVal = BitBlt(psHDC, X, 50 - refSin(Y), bigFontWidth, bigFontHeight, _
  296.                         pfHDC, refCharBig(curChar).xPos, refCharBig(curChar).yPos, SRCPAINT)
  297.       End If
  298.     Next iViewPort
  299.     bigCharX = bigCharX + 2
  300.     If bigCharX >= bigFontWidth Then bigCharX = 0
  301.     If bigCharX = 0 Then
  302.       ibigScroll = ibigScroll + 1
  303.       If ibigScroll > nofChar - charPerPage Then ibigScroll = 1
  304.     End If
  305.     '
  306.     picScroll.ClipControls = True
  307.     picScroll.Refresh
  308.     DoEvents
  309.     If abort Then GoTo theEnd
  310.   Wend
  311. theEnd:
  312.   End
  313. End Sub
  314. Private Sub initChar()
  315.   Dim fontChar As String
  316.   Dim i As Integer
  317.   Dim curChar As Byte
  318.   Dim pi As Double
  319.   Dim j As Double
  320.   fontChar = "ABCDEFGHIJKLMNOPQRSTUVWXYZ,'()!?.- "
  321.   For i = 0 To Len(fontChar) - 1
  322.     curChar = Asc(Mid$(fontChar, i + 1, 1))
  323.     refCharBig(curChar).yPos = Int(i / 5) * 49
  324.     refCharBig(curChar).xPos = (i Mod 5) * 64
  325.   Next i
  326.   fontChar = "ABCDEFGHIJKLMNOPQRSTUVWXYZ .!?"
  327.   For i = 0 To Len(fontChar) - 1
  328.     curChar = Asc(Mid$(fontChar, i + 1, 1))
  329.     refCharSmall(curChar).yPos = Int(i / 10) * 10
  330.     refCharSmall(curChar).xPos = (i Mod 10) * 16
  331.   Next i
  332.   ' use a lookup table in tenth's of degrees
  333.   ' with amplitude already calculated
  334.   For i = 0 To 3600
  335.     refSin(i) = 50 * Sin((i / 3600) * (2 * 3.141592653))
  336.   Next i
  337. End Sub
  338. Private Sub Form_Unload(Cancel As Integer)
  339.   Unload Me
  340.   End
  341. End Sub
  342. Public Sub OK()
  343. #If NEEDED Then
  344.       retVal = BitBlt(picScroll.hDC, iViewPort * bigFontWidth - bigCharX, 50 - refSin(Y), bigFontWidth, bigFontHeight, _
  345.                       picMask.hDC, refCharBig(curChar).xPos, refCharBig(curChar).yPos, SRCAND)
  346.       retVal = BitBlt(picScroll.hDC, iViewPort * bigFontWidth - bigCharX, 50 - refSin(Y), bigFontWidth, bigFontHeight, _
  347.                       picFont.hDC, refCharBig(curChar).xPos, refCharBig(curChar).yPos, SRCPAINT)
  348.       retVal = BitBlt(picScroll.hDC, iViewPort * bigFontWidth - bigCharX, 50 - refSin(Y2), bigFontWidth, bigFontHeight, _
  349.                       picMask.hDC, refCharBig(curChar).xPos, refCharBig(curChar).yPos, SRCAND)
  350.       retVal = BitBlt(picScroll.hDC, iViewPort * bigFontWidth - bigCharX, 50 - refSin(Y2), bigFontWidth, bigFontHeight, _
  351.                       picFont.hDC, refCharBig(curChar).xPos, refCharBig(curChar).yPos, SRCPAINT)
  352. #End If
  353. End Sub
  354.