Planet Source Code Jumbo …e CD Visual Basic 1 to 7/6_2008-2009.ISO/data/zips/Starfield_2147143182009.psc/Form1.frm

Text File | 2009-03-18 | 19KB | 510 lines

VERSION 5.00
Begin VB.Form Form1
   BorderStyle     =   0  'None
   Caption         =   "Form1"
   ClientHeight    =   5790
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   7755
   LinkTopic       =   "Form1"
   ScaleHeight     =   386
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   517
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  'CenterScreen
   WindowState     =   1  'Minimized
   Begin VB.Timer Timer1
      Enabled         =   0   'False
      Interval        =   10
      Left            =   6120
      Top             =   3300
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Type udtStar
    r As Long
    x As Long
    y As Long
    a As Single
    spd As Long
    q As Long
    w As Long
    offScreen As Long
    qi As Long
    wi As Long
End Type


Private 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
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As Long
Private Declare Function FrameRgn Lib "gdi32" (ByVal hDC As Long, ByVal hRgn As Long, ByVal hBrush As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
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
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal iCapabilitiy As Long) As Long
Private Declare Function GetSystemPaletteEntries Lib "gdi32" (ByVal hDC As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
Private Declare Function CreatePalette Lib "gdi32" (lpLogPalette As LOGPALETTE) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
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
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function SelectPalette Lib "gdi32" (ByVal hDC As Long, ByVal HPALETTE As Long, ByVal bForceBackground As Long) As Long
Private Declare Function RealizePalette Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function SetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hDC As Long, ByVal nBkMode As Long) As Long
Private Declare Function StretchDIBits& Lib "gdi32" (ByVal hDC&, ByVal x&, ByVal y&, ByVal dX&, ByVal dy&, ByVal SrcX&, ByVal SrcY&, ByVal Srcdx&, ByVal Srcdy&, Bits As Any, BInf As Any, ByVal Usage&, ByVal Rop&)
Private Declare Function LineTo Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, lpPoint As POINTAPI) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long
Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal nHeight As Long, ByVal nWidth As Long, ByVal nEscapement As Long, ByVal nOrientation As Long, ByVal fnWeight As Long, ByVal fdwItalic As Boolean, ByVal fdwUnderline As Boolean, ByVal fdwStrikeOut As Boolean, ByVal fdwCharSet As Long, ByVal fdwOutputPrecision As Long, ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, ByVal fdwPitchAndFamily As Long, ByVal lpszFace As String) As Long
Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Private Declare Function ShowCursor Lib "user32" (ByVal fShow As Integer) As Integer
Private Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As Long
Private Declare Function OleTranslateColor Lib "olepro32.dll" (ByVal OLE_COLOR As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32.dll" (ByVal crColor As Long) As Long
Private Declare Function AlphaBlend Lib "msimg32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal widthSrc As Long, ByVal heightSrc As Long, ByVal blendFunct As Long) As Boolean
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSrc As Any, ByVal ByteLen As Long)

Private Type BLENDFUNCTION
    BlendOp As Byte
    BlendFlags As Byte
    SourceConstantAlpha As Byte
    AlphaFormat As Byte
End Type
' BlendOp:
Private Const AC_SRC_OVER = &H0
' AlphaFormat:
Private Const AC_SRC_ALPHA = &H1

Private Enum eBrushStyle
    gdiBSDibPattern = 5
    gdiBSDibPatternPt = 6
    gdiBSHatched = 2
    gdiBSNull = 1
    gdiBSPattern = 3
    gdiBSSolid = 0
End Enum
Private Type uSquare
    nSize As Long
    xPos As Long
    yPos As Long
    xSpd As Long
    ySpd As Long
    Angle As Single
    StarSpd As Long
End Type

Private mRows As Long
Private mCols As Long
Private mFixedGrid As Boolean


Private Type PALETTEENTRY
   peRed As Byte
   peGreen As Byte
   peBlue As Byte
   peFlags As Byte
End Type
Private Const SRCCOPY = &HCC0020

Private Type LOGPALETTE
   palVersion As Integer
   palNumEntries As Integer
   palPalEntry(255) As PALETTEENTRY  ' Enough for 256 colors.
End Type

Private Type GUID
   Data1 As Long
   Data2 As Integer
   Data3 As Integer
   Data4(7) As Byte
End Type

Private Const RASTERCAPS As Long = 38
Private Const RC_PALETTE As Long = &H100
Private Const SIZEPALETTE As Long = 104

Private Type RECT
   Left As Long
   Top As Long
   right As Long
   bottom As Long
End Type
Private Type PicBmp
   Size As Long
   Type As Long
   hBmp As Long
   hPal As Long
   Reserved As Long
End Type

Private Type LOGBRUSH
    lbStyle As Long
    lbColor As Long
    lbHatch As Long
End Type

Const Pi As Single = 3.14159265358978
Const LOGPIXELSY = 90
Const COLOR_WINDOW = 5
Const Message = "Hello !"
Const OPAQUE = 2
Const TRANSPARENT = 1
Const FW_DONTCARE = 0
Const FW_THIN = 100
Const FW_EXTRALIGHT = 200
Const FW_LIGHT = 300
Const FW_NORMAL = 400
Const FW_MEDIUM = 500
Const FW_SEMIBOLD = 600
Const FW_BOLD = 700
Const FW_EXTRABOLD = 800
Const FW_HEAVY = 900
Const FW_BLACK = FW_HEAVY
Const FW_DEMIBOLD = FW_SEMIBOLD
Const FW_REGULAR = FW_NORMAL
Const FW_ULTRABOLD = FW_EXTRABOLD
Const FW_ULTRALIGHT = FW_EXTRALIGHT
'used with fdwCharSet
Const ANSI_CHARSET = 0
Const DEFAULT_CHARSET = 1
Const SYMBOL_CHARSET = 2
Const SHIFTJIS_CHARSET = 128
Const HANGEUL_CHARSET = 129
Const CHINESEBIG5_CHARSET = 136
Const OEM_CHARSET = 255
'used with fdwOutputPrecision
Const OUT_CHARACTER_PRECIS = 2
Const OUT_DEFAULT_PRECIS = 0
Const OUT_DEVICE_PRECIS = 5
'used with fdwClipPrecision
Const CLIP_DEFAULT_PRECIS = 0
Const CLIP_CHARACTER_PRECIS = 1
Const CLIP_STROKE_PRECIS = 2
'used with fdwQuality
Const DEFAULT_QUALITY = 0
Const DRAFT_QUALITY = 1
Const PROOF_QUALITY = 2
'used with fdwPitchAndFamily
Const DEFAULT_PITCH = 0
Const FIXED_PITCH = 1
Const VARIABLE_PITCH = 2

Private bStop As Boolean
Private scrL As Long
Private scrT As Long
Private scrW As Long
Private scrH As Long
Private scrR As Long
Private scrB As Long
Private midX As Long
Private midY As Long
Private mBlankDIB As cDIBSection
Private mBufferDIB As cDIBSection

Private bBUILDMODE As Boolean
Private CMM As cMonitors
Private uStars() As udtStar


Private Sub ApplyBlend()
Dim Blend As BLENDFUNCTION
Dim BlendPtr As Long
    Blend.SourceConstantAlpha = 60 '255 no blend - 0 major blurry!!

    CopyMemory BlendPtr, Blend, 4

    AlphaBlend mBufferDIB.hDC, scrL, scrT, scrW, scrH, mBlankDIB.hDC, 0, 0, scrW, scrH, BlendPtr
End Sub

Private Function CreateMyFont(nSize&, sFontFace$, bBold As Boolean, bItalic As Boolean) As Long
Static r&, d&

    DeleteDC r: r = GetDC(0)
    d = GetDeviceCaps(r, LOGPIXELSY)
    CreateMyFont = CreateFont(-MulDiv(nSize, d, 72), 0, 0, 0, _
                              IIf(bBold, FW_BOLD, FW_NORMAL), bItalic, False, False, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, _
                              CLIP_DEFAULT_PRECIS, PROOF_QUALITY, DEFAULT_PITCH, sFontFace) 'gdi 2
End Function
Private Sub SplitRGB(ByVal clr&, r&, g&, b&)
    r = clr And &HFF: g = (clr \ &H100&) And &HFF: b = (clr \ &H10000) And &HFF
End Sub
Private Sub SetFont(DC&, sFace$, nSize&)
Static c&
    ReleaseDC DC, c: DeleteDC c
    c = CreateMyFont(nSize, sFace, False, False)
    DeleteObject SelectObject(DC, c)
End Sub

Private Sub Form_Click()
bStop = True
End Sub

Private Sub Form_DblClick()
bStop = True
End Sub



Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
bStop = True
End Sub

Private Sub Form_Load()

If Mid$(Command(), 2, 1) = "p" Then End
If Mid$(Command(), 2, 1) = "c" Then
    MsgBox "There are no settings for this screen saver." & vbCrLf & vbCrLf & "Michael Toye" & vbCrLf & "[e-mail]", vbInformation, "Dotty Starfield"
    End
End If
Randomize Timer

bBUILDMODE = True

If Not bBUILDMODE Then
    Set CMM = New cMonitors
    scrL = CMM.VirtualScreenLeft
    scrT = CMM.VirtualScreenTop
    scrW = CMM.VirtualScreenWidth
    scrH = CMM.VirtualScreenHeight
Else
    scrL = 0
    scrT = 0
    scrW = Me.Width \ Screen.TwipsPerPixelX
    scrH = Me.Height \ Screen.TwipsPerPixelY
End If
scrR = scrW - scrL
scrB = scrH - scrT
midX = scrL + (scrW / 2)
midY = scrT + (scrH / 2)

CreateDIB mBlankDIB, scrW, scrH
CreateDIB mBufferDIB, scrW, scrH

SetupStars

Timer1.Enabled = True
End Sub

Sub SetTopmostWindow(ByVal hwnd As Long, Optional topmost As Boolean = True)
    Const HWND_NOTOPMOST = -2
    Const HWND_TOPMOST = -1
    Const SWP_NOMOVE = &H2
    Const SWP_NOSIZE = &H1
    SetWindowPos hwnd, IIf(topmost, HWND_TOPMOST, HWND_NOTOPMOST), 0, 0, 0, 0, SWP_NOMOVE + SWP_NOSIZE
End Sub

Function GimmeX(ByVal aIn As Single, lIn As Long) As Long
'(pi/180)
    GimmeX = sIN(aIn * 0.01745329251994) * lIn

End Function
Function GimmeY(ByVal aIn As Single, lIn As Long) As Long
'(pi/180)
    GimmeY = Cos(aIn * 0.01745329251994) * lIn
End Function
Function Sine(Degrees_Arg)
'Atn(1) / 45
Sine = sIN(Degrees_Arg * 0.01745329251994)
End Function

Function Cosine(Degrees_Arg)
'Atn(1) / 45
Cosine = Cos(Degrees_Arg * 0.01745329251994)
End Function
Private Sub Form_KeyPress(KeyAscii As Integer)
    bStop = True
End Sub

Private Sub COUT(sIN$, x&, y&)

    SetTextColor mBufferDIB.hDC, RGB(50, 50, 50)
    TextOut mBufferDIB.hDC, x, y, sIN, Len(sIN)

End Sub
Private Sub CreateDIB(ByRef tDIB As cDIBSection, scrW&, scrH&)
Set tDIB = New cDIBSection
With tDIB
    .Create scrW, scrH
    SetBkMode .hDC, TRANSPARENT
    SetFont .hDC, "Tahoma", 8
End With
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Static X0 As Integer, Y0 As Integer
    If Not bBUILDMODE Then
        If ((X0 = 0) And (Y0 = 0)) Or _
           ((Abs(X0 - x) < 8) And (Abs(Y0 - y) < 8)) Then ' small mouse movement...
            X0 = x                          ' Save current x coordinate
            Y0 = y                          ' Save current y coordinate
            Exit Sub                        ' Exit
        End If
        bStop = True
    End If

End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set mBlankDIB = Nothing
    Set mBufferDIB = Nothing

    Set CMM = Nothing
    ShowCursor -1
    Screen.MousePointer = vbDefault
End Sub
Sub SetupStars()
Dim n&, st&
    ReDim uStars(20)
    For n = 0 To UBound(uStars)
        With uStars(n)
            .a = Int(Rnd * 360)
            st = Int(Rnd * scrW * 0.2)
            .x = midX + GimmeX(.a, st)
            .y = midY + GimmeY(.a, st)
            .r = 10
            .q = Int(Rnd * 360)
            .w = Int(Rnd * 360)
            .spd = 2 + Int(Rnd * 40)
            .qi = (1 + Int(Rnd * 5)) * IIf((Rnd * 1000) > 600, -1, 1)
            .wi = (1 + Int(Rnd * 5)) * IIf((Rnd * 1000) > 600, -1, 1)
            .offScreen = 0
        End With
    Next
End Sub
Private Sub Timer1_Timer()
    Timer1.Enabled = False
    DoEvents

    If Me.WindowState = 1 Then Me.WindowState = 0

    If Not bBUILDMODE Then
        Me.Move scrL * Screen.TwipsPerPixelX, scrT * Screen.TwipsPerPixelY, scrW * Screen.TwipsPerPixelX, scrH * Screen.TwipsPerPixelY
        SetTopmostWindow Me.hwnd
        ShowCursor 0
    Else
        Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - (Me.Height * 1.2))
    End If



    DisplaySS
End Sub

Private Sub DisplaySS()

Dim n&, s&, st&, t&, f&, fp&, ag!
't = GetTickCount: f = 0 'reinstate for FPS
    Do

        BitBlt mBufferDIB.hDC, scrL, scrT, scrW, scrH, mBlankDIB.hDC, 0, 0, vbSrcCopy
        'ApplyBlend


        'reinstate for FPS  -->
'        f = f + 1
'        If GetTickCount - t >= 1000 Then
'            t = GetTickCount: fp = f: f = 0
'        End If
'        COUT CStr(fp), 3, 3
        '<-- reinstate for FPS

        For n = 0 To UBound(uStars)
            With uStars(n)
                PlotBall mBufferDIB.hDC, .x, .y, .r, .q, .w, .offScreen
            End With
        Next
        BitBlt Me.hDC, scrL, scrT, scrW, scrH, mBufferDIB.hDC, 0, 0, vbSrcCopy

        For n = 0 To UBound(uStars)
            With uStars(n)
                .q = .q + .qi
                If .q > 360 Then .q = .q - 360
                If .q < 0 Then .q = .q + 360
                .w = .w + .wi
                If .w > 360 Then .w = .w - 360
                If .w < 0 Then .w = .w + 360
                ag = .a * 0.01745329251994
                .x = .x + (sIN(ag) * .spd)
                .y = .y + (Cos(ag) * .spd)
                 .r = .r + 1
                If .offScreen = 1 Then
                    .a = Int(Rnd * 360)
                    ag = .a * 0.01745329251994
                                        ' Save current y cooi uStfDfbSEIx3            l2oYra25151994)
r .a = DUnderline As Boolean, ByVCan As Long, ByVal fnWeight.fDfbSEIx3   Cosine = Cos(aecr2 If .w <-= Cos(aecr2 If .2 If IurrenfbSEsi
 y cx3(n2M (n2M (n2M (n2M (n2M (n2M (n22M (n2rW,x)M (n2M LsIM.w + .wi
                       .a = Int(Rnd * 360)
              DFIf((Rnd * 100
              DFIf((Rnd * 100
              DFIf((R
               hen.Width          DFIf((Rnd * 100
           DFIf((R
          e Su
 q59R
       es_Arg * 0.0en.Width          DFIf((Rndliseco" 100
        idth   Of 1  6    t =
                  D
S9R
        es_Arg * 0   4H 4H DFIf((Rnd * o50,(Rndlise ,
Function y50,,Rnd * 100
           DFIf((R
          e Su
 q59R
       es_Arg * 0.0en.WI&ThS    e Su
 q59R
       es     COUT CStr(fp), 3, 3
es     Cr(fp), 3, 32M (n2M (n22M (n2rW,x)M (n2M LsIM.w + .wilv,1   0en. CStr(fp),me2M (n2en. C  WithxH5, 3, 3
es     Cr(fp), 3, 32M (n2M (n22M (n2rW,x)OGHRM (n2rW,x)M (n2M LsIM.w + .wi    4H 4H DF
'th22M (n2rW,xeelX, s (n2r(fp), 3, 3g
E(With uStars(n)
lC, 0
lC, 0
lc 4H 4H DFy (n2M LC, 0
lc 4H 4H DFy (n, 3, 32M (nA1  6    rW,x)M (nr
      o     _Toole e_      NenkDIB.hDC, 0, 0, vb NenkDIB.hDC, 0, 0, vb Nma          ag = .a * 0.0,laO          H2eR = .a *nFag       r .  H2eR = .a *nFag       r .  O
es     End With
        Nexi)0, 0T 122Mc 4H 4H DFyCind With
        NexRO
esscrW)           aT   aT   aT   aT   aT  aT   aT   aT   a   aT   aT  aT   aT   aT   a  0 3,  0 3,i               4H 4H ion y50    22Mcc&  a  0 3, a  0 3,  0 3,i   0hu0Da-tgDoo aT*yCind With
        NpsPerPixelObzayf*.n2M LsIM.w + BerPixOerPixOe .a * 0.0,laO  aT   a   aT   aT  aT   aT   PixOe .a * 0fh
llTnoc Oe .  aT       vate Type GUID
   Data1 Oe
             MriSfIDsSeg
E(WitCos(aST   aRlB(WitCHh
        Nps(rb = (cl
    FoxMppb =  ykiSfID.  O
eLLUID
  B(WitCHh
    e eg  = 0, 0Rriva0fh
llTnoc Oe .  riva    FoxMppb
    e   3eSe(n2en. C  T   Sr HerPixelYz(e'b = (cl
 , 0Rriva0fh
4 q59R
       es     COUT CStr(fp), 3, 3T CStx COUT CStr(fp)iN