'将属性值写到存储器

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

Call PropBag.WriteProperty("BackColor", picImd.BackColor, &H8000000F)

Call PropBag.WriteProperty("TextColor", picImd.ForeColor, &H80000012)

Call PropBag.WriteProperty("FontSize", picImd.FontSize, 9)

Call PropBag.WriteProperty("FontName", picImd.FontName, "宋体")

Call PropBag.WriteProperty("TextString", m_TextString, m_def_TextString)

Call PropBag.WriteProperty("Speed", Timer.Interval, m_def_Speed)

Call PropBag.WriteProperty("BackPictureName", m_BackPictureName, m_def_BackPictureName)

Call PropBag.WriteProperty("TextOffsetY", m_TextOffsetY, m_def_TextOffsetY)

Call PropBag.WriteProperty("NearSnowNum", m_NearSnowNum, m_def_NearSnowNum)

Call PropBag.WriteProperty("FarSnowNum", m_FarSnowNum, m_def_FarSnowNum)

Call PropBag.WriteProperty("MidSnowNum", m_MidSnowNum, m_def_MidSnowNum)

End Sub

Public Property Get TextColor() As OLE_COLOR

TextColor = picImd.ForeColor

End Property

Public Property Let TextColor(ByVal New_TextColor As OLE_COLOR)

picImd.ForeColor() = New_TextColor

PropertyChanged "TextColor"

End Property

Public Property Get FontSize() As Single

FontSize = picImd.FontSize

End Property

Public Property Let FontSize(ByVal New_FontSize As Single)

picImd.Cls

picImd.FontSize() = New_FontSize

maxOffsetX = -picImd.TextWidth(m_TextString)

PropertyChanged "FontSize"

End Property

Public Property Get FontName() As String

FontName = picImd.FontName

End Property

Public Property Let FontName(ByVal New_FontName As String)

On Error GoTo r1:

picImd.FontName() = New_FontName

r1:

PropertyChanged "FontName"

End Property

Public Property Let BackPictureName(ByVal New_BackPictureName As String)

m_BackPictureName = New_BackPictureName

IsCreate = True  '需要重新建立MEM位图

PropertyChanged "BackPictureName"

End Property

Public Property Get TextString() As String

TextString = m_TextString

End Property

Public Property Let TextString(ByVal New_TextString As String)

Dim i As Integer

picImd.Cls

m_TextString = New_TextString

maxOffsetX = -picImd.TextWidth(m_TextString)

TextLen = Strlen(m_TextString)

PropertyChanged "TextString"

End Property

Public Property Get BackPictureName() As String

    BackPictureName = m_BackPictureName

End Property

Public Property Get TextOffsetY() As Integer

   TextOffsetY = m_TextOffsetY

End Property

Public Property Let TextOffsetY(ByVal New_TextOffsetY As Integer)

m_TextOffsetY = New_TextOffsetY

PropertyChanged "TextOffsetY"

End Property

Public Property Get NearSnowNum() As Integer

NearSnowNum = m_NearSnowNum

End Property

Public Property Let NearSnowNum(ByVal New_NearSnowNum As Integer)

If Not (New_NearSnowNum < 0 Or New_NearSnowNum > 500) Then

m_NearSnowNum = New_NearSnowNum

Else

m_NearSnowNum = m_def_NearSnowNum

End If

PropertyChanged "NearSnowNum"

End Property

Public Property Get FarSnowNum() As Integer

FarSnowNum = m_FarSnowNum

End Property

Public Property Let FarSnowNum(ByVal New_FarSnowNum As Integer)

If Not (New_FarSnowNum < 0 Or New_FarSnowNum > 500) Then

m_FarSnowNum = New_FarSnowNum

Else

m_FarSnowNum = m_def_FarSnowNum

End If

PropertyChanged "FarSnowNum"

End Property

Public Property Get MidSnowNum() As Integer

   MidSnowNum = m_MidSnowNum

End Property

Public Property Let MidSnowNum(ByVal New_MidSnowNum As Integer)

If Not (New_MidSnowNum < 0 Or New_MidSnowNum > 500) Then

m_MidSnowNum = New_MidSnowNum

Else

m_MidSnowNum = m_def_MidSnowNum

End If

PropertyChanged "MidSnowNum"

End Property

Public Sub AboutBox()

MsgBox "AddSnowCtrol V1.0 by DragonJiang " & Chr(13) & "Date:02/29/2000", vbInformation, "About AddSnowCtrol"

End Sub

确认无误后，可以修改工程属性，然后选中文件中”生成AddSnow.Ocx...”,生成AddSnow.Ocx

三、测试你的AddSnow.Ocx

新建的一个标准的.EXE,将您设计的AddSnow.Ocx选入工具中。然后设计窗体，加入一些相关的控件：

笔者的测试窗体如下：

加入相关以下代码:

Private Sub AboutButton_Click()   CtrlSnow.AboutBoxEnd SubPrivate Sub OpenButton_Click()On Error GoTo exitOpenDlg.Filter = "所有的图形文件|(*.bmp;*.jpg;*.wfm;*.emf;*.ico;*.rle;*.gif;*.cur)|JPEG文件|*.jpg|BMP文件|(*.bmp)|GIF文件|*.gif|光标(*.Ico)和图标(*.Cur)文件|(*.cur,*.ico)|WMF元文件(*.wmf,*.emf)|(*.wmf,*.emf)|RLE行程文件(*.rle)|*.rle"

Dlg.ShowOpen

CtrlSnow.BackPictureName = Dlg.FileName

exitOpen:

End Sub

Private Sub FontButton_Click()

On Error GoTo exitFont

Dlg.Flags = cdlCFBoth

Dlg.ShowFont

CtrlSnow.FontName = Dlg.FontName

CtrlSnow.FontSize = Dlg.FontSize

exitFont:

End Sub

Private Sub Form_Load()

    Dlg.CancelError = True

    UpDown(1).Value = CtrlSnow.NearSnowNum

    UpDown(0).Value = CtrlSnow.TextOffsetY

    UpDown(2).Value = CtrlSnow.MidSnowNum

    UpDown(3).Value = CtrlSnow.FarSnowNum

    UpDown(4).Value = CtrlSnow.Speed

ForeColorFrame.BackColor = CtrlSnow.TextColor

BackColorFrame.BackColor = CtrlSnow.BackColor

    TextString.Text = CtrlSnow.TextString

End Sub

Private Sub ForeColorFrame_Click()

    On Error GoTo exitfColor

    Dlg.ShowColor

    CtrlSnow.TextColor = Dlg.Color

    ForeColorFrame.BackColor = Dlg.Color

exitfColor:

End Sub

Private Sub backColorFrame_Click()

  On Error GoTo exitBkColor

  Dlg.ShowColor

  CtrlSnow.BackColor = Dlg.Color

  BackColorFrame.BackColor = Dlg.Color

  exitBkColor:

End Sub

Private Sub textString_Change()

   CtrlSnow.TextString = TextString.Text

End Sub

Private Sub UpDown_Change(I As Integer)

  Dim n As Integer

  TextVal(I).Text = UpDown(I).Value

  n = UpDown(I).Value

Select Case I

   Case 0

        CtrlSnow.TextOffsetY = n

   Case 1

       CtrlSnow.NearSnowNum = n

   Case 2

      CtrlSnow.MidSnowNum = n

   Case 3

      CtrlSnow.FarSnowNum = n

   Case 4

      CtrlSnow.Speed = n

End Select

End Sub

按下Play,打开一个背景文件，^_^，雪花真的飘下来（若选择一个有雪的背景效果会更好）。

想在您的网页中也加入这种效果吗，快启动FrontPage,添加一个新页面，插入OCX，选中你的AddSnow。怎么样，自已亲手做的加下雪效果，Cool吧！