module.bas

可以换肤的窗体 简单分析

Attribute VB_Name = "modules"
'存储背景图片的变量
Global BackPicture As String

'设置背景图片的子过程
Sub ShowBackGround(Frm As Form)
    
    '将Pic定义为StdPicture对象（StdPicture对象是包含各种图元的对象）
    Dim Pic As StdPicture
    
    '如果选择图片时，按下“取消”按钮（也就是没有选中文件）
    If BackPicture = "" Then Exit Sub
    
    '先清空窗体上原有图片背景
    Frm.Cls
    
    '如果出现异常错误，转向错误处理语句
    On Error GoTo ErrorPic
    
    '将选中的图片文件加载到Pic中
    Set Pic = LoadPicture(BackPicture)
    
    '下面将图片排满整个窗体
    W = 0
    H1 = Pic.Height / 27
    W1 = Pic.Width / 27
    While W < Frm.ScaleWidth
        H = 0
        While H < Frm.ScaleHeight
            Frm.PaintPicture Pic, W, H
            H = H + H1
        Wend
        W = W + W1
    Wend
    'ShowBorder Frm
    Exit Sub

'如果出现异常错误，则恢复默认的背景图片
ErrorPic:
    If Err.Number = 481 Then
        MsgBox " Picture File Error!"
    End If
    If BackPicture <> App.Path + "\default.JPG" Then
        BackPicture = App.Path + "\default.JPG"
        Set Pic = LoadPicture(BackPicture)
        Resume Next
    Else
        'ShowBorder Frm
    End If
End Sub


'---------------------------------------------
'如果我们不想使用默认的标题栏和边框，而自己制作更漂
'亮的标题栏，可把窗体Frmmain的Border属性设为0-None
'利用下面的ShowBorder来重新画出窗体的Border，别忘
'了把上面中的ShowBackGround子过程的ShowBorder Frm
'写上。
'---------------------------------------------
'Sub ShowBorder(Frm As Form)
'    Frm.DrawWidth = 1
'    Frm.Line (Frm.ScaleWidth - 1, 1)-(Frm.ScaleWidth - 1, Frm.ScaleHeight - 1), QBColor(1)
'    Frm.Line (Frm.ScaleWidth - 2, 2)-(Frm.ScaleWidth - 2, Frm.ScaleHeight - 2), QBColor(8)
'    Frm.Line (Frm.ScaleWidth - 3, 3)-(Frm.ScaleWidth - 3, Frm.ScaleHeight - 3), QBColor(7)
'    Frm.Line (1, Frm.ScaleHeight - 1)-(Frm.ScaleWidth - 1, Frm.ScaleHeight - 1), QBColor(1)
'    Frm.Line (2, Frm.ScaleHeight - 2)-(Frm.ScaleWidth - 2, Frm.ScaleHeight - 2), QBColor(8)
'    Frm.Line (3, Frm.ScaleHeight - 3)-(Frm.ScaleWidth - 3, Frm.ScaleHeight - 3), QBColor(7)
'    Frm.Line (0, 0)-(Frm.ScaleWidth, 0), QBColor(7)
'    Frm.Line (1, 1)-(Frm.ScaleWidth - 1, 1), QBColor(15)
'    Frm.Line (2, 2)-(Frm.ScaleWidth - 2, 2), QBColor(7)
'    Frm.Line (0, 0)-(0, Frm.ScaleHeight), QBColor(7)
'    Frm.Line (1, 1)-(1, Frm.ScaleHeight - 1), QBColor(15)
'    Frm.Line (2, 2)-(2, Frm.ScaleHeight - 2), QBColor(7)
'End Sub
'----------------------------------------------
'怎么拖动不带标题栏的窗体呢？你可参考源码讲解的例子
'----------------------------------------------