about.frm

这个代码是基于软盘修复

  Y As Long
  Z As Long
  Speed As Long
End Type

Private Stars(0 To MaxStars) As StarRec
Private StopStar As Boolean

'-------------------------------------------------------文字
Private Const MaxText = 7
Private Const DT_CENTER = &H1

Private Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type

Private TextMov As Long
Private TextDelay As Long
Private TextNum As Long

'-----------------------------------------------------事件
Private Sub AboutOK_Click()
  StopStar = True
  Me.Hide
End Sub

Private Sub PicFocus_KeyUp(KeyCode As Integer, Shift As Integer)
  If KeyCode = vbKeyEscape Then
    StopStar = True
    Me.Hide
  End If
End Sub

Private Sub Form_Load()
  Dim wndReg As Long
  Dim wndRet As Long
  Dim i As Long
  
  '不规则窗体
  wndReg = RgnFromMask(PicMask, RGB(255, 255, 255))
  wndRet = SetWindowRgn(Me.hWnd, wndReg, True)
  '坐标初始化init stars
  For i = 0 To MaxStars: Call NewStar(i): Next i
  StopStar = False
  '初始化文字
  TextMov = 0
  TextDelay = 0
  TextNum = 0
  '绘制背景
  BitBlt Me.hDC, 0, 0, 328, 234, PicAbout.hDC, 0, 0, SRCCOPY
  '位置
  PicField.Top = 0: PicField.Left = 0
  PicField.Height = 182: PicField.Width = 328
  AboutOK.Left = 228: AboutOK.Top = 208
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  Dim res As Long
  
  res = ReleaseWinCapture()
  'res = SendWinMessage(Me.hWnd, WM_SYSCOMMAND, WM_MOVE, 0)  'does not work on NT
  res = SendWinMessage(Me.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
  PicFocus.SetFocus
End Sub

Private Sub Form_Resize()
  PicFocus.SetFocus
  Do
    Call DoStars
    Call BitBlt(PicScreen.hDC, 0, 0, 328, 182, PicStar.hDC, 0, 0, SRCCOPY)
    Call DoText
    Call BitBlt(PicScreen.hDC, 0, 0, 328, 182, PicText.hDC, 0, 0, SRCPAINT)
    Call BitBlt(PicScreen.hDC, 0, 0, 328, 182, PicMask2.hDC, 0, 0, SRCAND)
    Call BitBlt(PicScreen.hDC, 0, 0, 328, 182, PicAbout.hDC, 0, 0, SRCPAINT)
    Call BitBlt(PicField.hDC, 0, 0, 328, 182, PicScreen.hDC, 0, 0, SRCCOPY)
    PicField.Refresh
    DoEvents
  Loop Until StopStar = True
End Sub

'---------------------------------------------RegionFromMask
Private Function RgnFromMask(PicMask As PictureBox, Optional lngTransColor As Long = -1) As Long
  Dim wndRgn As Long, wndRgnTmp As Long, wndRgnAux As Long
  Dim pX As Long, pY As Long
  Dim tX As Long, tY As Long
  Dim pixVal As Long
  Dim rX1 As Long, rX2 As Long
  
  If lngTransColor = -1 Then lngTransColor = RGB(255, 255, 255)
  wndRgn = 0
  tY = 90
  tX = PicMask.Width
  '加速
  wndRgn = CreateRectRgn(1, 90, tX + 1, 235)
  '获取掩膜像素
  For pY = 1 To tY
    pX = 1
    Do While pX <= tX
      Do While (GetPixel(PicMask.hDC, pX - 1, pY - 1) = lngTransColor) And (pX <= tX)
        pX = pX + 1
      Loop
      If pX <= tX Then
        rX1 = pX
        Do While (GetPixel(PicMask.hDC, pX - 1, pY - 1) <> lngTransColor) And (pX <= tX)
          pX = pX + 1
        Loop
        rX2 = pX - 1
        wndRgnTmp = CreateRectRgn(rX1, pY, rX2 + 1, pY + 1)
        wndRgnAux = CombineRgn(wndRgn, wndRgn, wndRgnTmp, RGN_OR)
        Call DeleteObject(wndRgnTmp)
      End If
    Loop
  Next pY
  RgnFromMask = wndRgn
End Function

'-----------------------------------------------------Stars
Private Sub NewStar(ByVal num As Long)
 Stars(num).X = Rnd * 100 - 50
 Stars(num).Y = Rnd * 100 - 50
 Stars(num).Z = Rnd * 100 + 200
 Stars(num).Speed = 1
End Sub

Private Function StarColor(ByVal Z As Long) As Long
  Dim Value As Long
  
  Value = 5 + (Z / 150)
  If Value > 100 Then Value = 100
  Value = Value + 150
  StarColor = RGB(Value, Value, Value)
End Function

Private Sub DoStars()
  Dim X As Long, Y As Long
  Dim i As Long
  
  For i = 0 To MaxStars
    '旧星位置 : 关
    X = 164 + Round(Stars(i).X * Stars(i).Z / ZFactor)
    Y = 95 + Round(Stars(i).Y * Stars(i).Z / ZFactor)
    PicStar.PSet (X, Y), 0
    '计算新坐标
    Stars(i).Z = Stars(i).Z + Stars(i).Speed
    If Stars(i).Z > 20000 Then NewStar i
    Stars(i).Speed = (Stars(i).Z / 32) * (5 - (Abs(Stars(i).X * Stars(i).Y) / 500))
    If Stars(i).Speed = 0 Then Stars(i).Speed = 1
    If (X < 0) Or (X > 328) Or (Y < 0) Or (Y > 190) Then NewStar i
    '新星星位置 : 开
    X = 164 + Round(Stars(i).X * (Stars(i).Z + Stars(i).Speed) / ZFactor)
    Y = 95 + Round(Stars(i).Y * (Stars(i).Z + Stars(i).Speed) / ZFactor)
    PicStar.PSet (X, Y), StarColor(Stars(i).Z)
  Next i
End Sub

'------------------------------------------------------文字
Private Sub DoText()
  Select Case TextMov
    Case 0: '改变文字
      TextNum = TextNum + 1
      If TextNum > MaxText Then TextNum = 1
      TextDelay = 0
      PicText.Line (0, 0)-(328, 182), 0, BF
      TextMov = 1
    Case 1: '等候出现
      TextDelay = TextDelay + 1
      If TextDelay = 50 Then
        TextMov = 2
        TextDelay = 0
      End If
    Case 2: '文字界面, 移动光标
      TextDelay = TextDelay + 4
      Call DrawPicText
      If TextDelay = 100 Then
        TextMov = 3
        TextDelay = 0
      End If
    Case 3: '文字 100%, 等候收缩
      TextDelay = TextDelay + 1
      If TextDelay = 50 Then
        TextMov = 4
        TextDelay = 0
      End If
    Case 4: '文字离开
      TextDelay = TextDelay + 1
      Call DrawPicText
      If TextDelay = 50 Then
        TextMov = 0
        TextDelay = 0
      End If
  End Select
End Sub

Private Sub DrawPicText()
  Dim strTXT As String
  Dim R As RECT
  Dim pX As Long, pY As Long
  Dim tX As Long, tY As Long
  
  PicText.Line (0, 0)-(328, 182), 0, BF
  PicScale.Line (0, 0)-(328, 182), 0, BF
  '以正常尺寸绘文字
  Select Case TextNum
    Case 1: strTXT = "设计"
    Case 2: strTXT = "MANUEL AUGUSTO SANTOS"
    Case 3: strTXT = "程序"
    Case 4: strTXT = "MANUEL AUGUSTO SANTOS"
    Case 5: strTXT = "(c) 2000-2003"
    Case 6: strTXT = "http://www.mndsoft.com"
    Case 7: strTXT = "欢迎光临枕善居"
  End Select
  Call SetRect(R, 0, 84, 328, 182)
  Call DrawText(PicScale.hDC, strTXT, LenB(StrConv(strTXT, vbFromUnicode)), R, DT_CENTER)
  PicScale.Refresh
  '收缩
  If TextMov = 2 Then
    tX = (TextDelay * 328) / 200
    tY = (TextDelay * 182) / 200
    Call StretchBlt(PicText.hDC, 164 - tX, 96 - tY, tX * 2, tY * 2, PicScale.hDC, 0, 0, 328, 182, SRCCOPY)
  End If
  '展开
  If TextMov = 4 Then
    Select Case TextNum
      Case 2, 4, 6:
        tX = ((100 + 50 * TextDelay) * 328) / 200
        tY = ((100 + 50 * TextDelay) * 182) / 200
      Case 1, 3, 5:
        tX = ((100 - 2 * TextDelay) * 328) / 200
        tY = ((100 - 2 * TextDelay) * 182) / 200
    End Select
    Call StretchBlt(PicText.hDC, 164 - tX, 96 - tY, tX * 2, tY * 2, PicScale.hDC, 0, 0, 328, 182, SRCCOPY)
  End If
  PicText.Refresh
End Sub