📄 mainpage.frm

📁 OA编程源代码
💻 FRM
📖 第 1 页 / 共 2 页
字号:
上一页 12
         Visible         =   0   'False
         Width           =   1650
      End
      Begin VB.Label LabColor 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "颜色"
         Height          =   180
         Left            =   6120
         TabIndex        =   22
         Top             =   480
         Width           =   360
      End
      Begin VB.Label LabFont 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "字体"
         Height          =   180
         Left            =   4320
         TabIndex        =   21
         Top             =   480
         Width           =   360
      End
      Begin VB.Label LabTitle 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "标题"
         Height          =   180
         Left            =   120
         TabIndex        =   15
         Top             =   465
         Width           =   360
      End
      Begin VB.Label LabTopFile 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "上图形"
         Height          =   180
         Left            =   3120
         TabIndex        =   13
         Top             =   960
         Width           =   540
      End
      Begin VB.Label LabLeftFile 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "左图形"
         Height          =   180
         Left            =   5880
         TabIndex        =   12
         Top             =   960
         Width           =   540
      End
      Begin VB.Label LabRightFile 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "右图形"
         Height          =   180
         Left            =   8640
         TabIndex        =   11
         Top             =   960
         Width           =   540
      End
   End
   Begin VB.PictureBox PicTop 
      Appearance      =   0  'Flat
      AutoRedraw      =   -1  'True
      BackColor       =   &H00FFFFFF&
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   975
      Left            =   1425
      ScaleHeight     =   975
      ScaleWidth      =   10110
      TabIndex        =   7
      TabStop         =   0   'False
      Top             =   1440
      Width           =   10110
      Begin VB.Label LabPreTitle 
         Alignment       =   2  'Center
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "Label1"
         Height          =   180
         Left            =   5520
         TabIndex        =   23
         Top             =   0
         Width           =   555
      End
   End
End
Attribute VB_Name = "FrmMainPage"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Private Sub CmdLeftFile_Click()
    On Error Resume Next
    
    DlgSelectFile.DialogTitle = "选择主页左边图形文件"
    If Len(Trim(TxtLeftFile.Text)) = 0 Then
        DlgSelectFile.InitDir = Trim(SysPath)
        DlgSelectFile.FileName = ""
    Else
        DlgSelectFile.FileName = Trim(SysPath) & Trim(TxtLeftFile.Text)
    End If
    DlgSelectFile.Filter = "图形文件 (*.gif,*.jpg)|*.gif;*.jpg"
        
    DlgSelectFile.ShowOpen
    
    If Len(Trim(DlgSelectFile.FileName)) = 0 Then Exit Sub
    Return_Var = InStr(UCase(Trim(DlgSelectFile.FileName)), UCase(Trim(SysPath)))
    If Return_Var = 0 Then
        MsgBox "主页路径不正确！", vbExclamation, "系统信息"
        Exit Sub
    End If
    
    TxtLeftFile.Text = Mid(Trim(DlgSelectFile.FileName), _
        Len(Trim(SysPath)) + 1, _
        Len(Trim(DlgSelectFile.FileName)) - Len(Trim(SysPath)))
    Set PicLeft.Picture = LoadPicture(Trim(DlgSelectFile.FileName))
End Sub

Private Sub CmdLTopFile_Click()
    On Error Resume Next
    
    DlgSelectFile.DialogTitle = "选择主页左上边图形文件"
    If Len(Trim(TxtLTopFile.Text)) = 0 Then
        DlgSelectFile.InitDir = Trim(SysPath)
        DlgSelectFile.FileName = ""
    Else
        DlgSelectFile.FileName = Trim(SysPath) & Trim(TxtLTopFile.Text)
    End If
    DlgSelectFile.Filter = "图形文件 (*.gif,*.jpg)|*.gif;*.jpg"
        
    DlgSelectFile.ShowOpen
    
    If Len(Trim(DlgSelectFile.FileName)) = 0 Then Exit Sub
    Return_Var = InStr(UCase(Trim(DlgSelectFile.FileName)), UCase(Trim(SysPath)))
    If Return_Var = 0 Then
        MsgBox "主页路径不正确！", vbExclamation, "系统信息"
        Exit Sub
    End If
    
    TxtLTopFile.Text = Mid(Trim(DlgSelectFile.FileName), _
        Len(Trim(SysPath)) + 1, _
        Len(Trim(DlgSelectFile.FileName)) - Len(Trim(SysPath)))
    Set PicLTop.Picture = LoadPicture(Trim(DlgSelectFile.FileName))
End Sub

Private Sub CmdRightFile_Click()
    On Error Resume Next
    
    DlgSelectFile.DialogTitle = "选择主页右边图形文件"
    If Len(Trim(TxtRightFile.Text)) = 0 Then
        DlgSelectFile.InitDir = Trim(SysPath)
        DlgSelectFile.FileName = ""
    Else
        DlgSelectFile.FileName = Trim(SysPath) & Trim(TxtRightFile.Text)
    End If
    DlgSelectFile.Filter = "图形文件 (*.gif,*.jpg)|*.gif;*.jpg"
        
    DlgSelectFile.ShowOpen
    
    If Len(Trim(DlgSelectFile.FileName)) = 0 Then Exit Sub
    Return_Var = InStr(UCase(Trim(DlgSelectFile.FileName)), UCase(Trim(SysPath)))
    If Return_Var = 0 Then
        MsgBox "主页路径不正确！", vbExclamation, "系统信息"
        Exit Sub
    End If
    
    TxtRightFile.Text = Mid(Trim(DlgSelectFile.FileName), _
        Len(Trim(SysPath)) + 1, _
        Len(Trim(DlgSelectFile.FileName)) - Len(Trim(SysPath)))
    Set PicRight.Picture = LoadPicture(Trim(DlgSelectFile.FileName))
End Sub

Private Sub CmdSelectSColor_Click()
    On Error GoTo CancelClick
    
    DlgSelectColor.DialogTitle = "选择颜色"
    If Len(TxtColor.Text) = 0 Then
        DlgSelectColor.Color = Val("&H00FFFFFF&")
    Else
        DlgSelectColor.Color = Val(Trim(TxtColor.Text))
    End If
    DlgSelectColor.Flags = cdlCCPreventFullOpen + cdlCCRGBInit
    
    DlgSelectColor.ShowColor
    
    TxtColor.Text = TenToSix(DlgSelectColor.Color)
    TxtColor.ForeColor = DlgSelectColor.Color
    
    LabPreTitle.ForeColor = Val(Trim(TxtColor.Text))
    
    Exit Sub
CancelClick:
End Sub

Private Sub CmdSetFont_Click()
    On Error GoTo CancelClick
    
    DlgSetFont.DialogTitle = "设置字体及字体大小"
    If Len(TxtFont.Text) = 0 Then
        DlgSetFont.FontName = "宋体"
    Else
        DlgSetFont.FontName = Trim(TxtFont.Text)
    End If
    If Val(Trim(TxtFontSize.Text)) = 0 Then
        DlgSetFont.FontSize = 8
    Else
        DlgSetFont.FontSize = Val(Trim(TxtFontSize.Text))
    End If
    DlgSetFont.Flags = cdlCFBoth
    
    DlgSetFont.ShowFont
    
    TxtFont.Text = DlgSetFont.FontName
    TxtFontSize.Text = DlgSetFont.FontSize
    
    LabPreTitle.Font = Trim(TxtFont.Text)
    LabPreTitle.FontSize = Val(Trim(TxtFontSize.Text))
    LabPreTitle.Top = (PicTop.Height - LabPreTitle.Height) / 2
    LabPreTitle.Left = (PicTop.Width - LabPreTitle.Width) / 2
    
    Exit Sub
CancelClick:
End Sub

Private Sub CmdTopFile_Click()
    On Error Resume Next
    
    DlgSelectFile.DialogTitle = "选择主页上边图形文件"
    If Len(Trim(TxtTopFile.Text)) = 0 Then
        DlgSelectFile.InitDir = Trim(SysPath)
        DlgSelectFile.FileName = ""
    Else
        DlgSelectFile.FileName = Trim(SysPath) & Trim(TxtTopFile.Text)
    End If
    DlgSelectFile.Filter = "图形文件 (*.gif,*.jpg)|*.gif;*.jpg"
        
    DlgSelectFile.ShowOpen
    
    If Len(Trim(DlgSelectFile.FileName)) = 0 Then Exit Sub
    Return_Var = InStr(UCase(Trim(DlgSelectFile.FileName)), UCase(Trim(SysPath)))
    If Return_Var = 0 Then
        MsgBox "主页路径不正确！", vbExclamation, "系统信息"
        Exit Sub
    End If
    
    TxtTopFile.Text = Mid(Trim(DlgSelectFile.FileName), _
        Len(Trim(SysPath)) + 1, _
        Len(Trim(DlgSelectFile.FileName)) - Len(Trim(SysPath)))
    Set PicTop.Picture = LoadPicture(Trim(DlgSelectFile.FileName))
End Sub

Private Sub Form_Load()
    Dim StyleId As Integer
    Dim ButtonStyle As Integer
    
    On Error GoTo DatabaseError
    
    FrmMainPage.ScaleHeight = FrmMainPage.Height
    FrmMainPage.ScaleWidth = FrmMainPage.Width
    FrmMainPage.Top = (Screen.Height - FrmMainPage.Height - TitleHeight) / 2
    FrmMainPage.Left = (Screen.Width - FrmMainPage.Width) / 2
    
    sql = "SELECT * FROM mainpagestyle"
    Set rst = gclsDatabase.RDOSelect(sql)
    
    On Error Resume Next
    
    If rst.RowCount > 0 Then
        TxtLTopFile.Text = Trim(rst!leftbanner)
        TxtTopFile.Text = Trim(rst!banner)
        TxtLeftFile.Text = Trim(rst!content)
        TxtRightFile.Text = Trim(rst!RightStyle)
    
        Set PicLTop.Picture = LoadPicture(Trim(SysPath) & Trim(rst!leftbanner))
        Set PicTop.Picture = LoadPicture(Trim(SysPath) & Trim(rst!banner))
        Set PicLeft.Picture = LoadPicture(Trim(SysPath) & Trim(rst!content))
        Set PicRight.Picture = LoadPicture(Trim(SysPath) & Trim(rst!RightStyle))
    
        TxtTitle.Text = Trim(rst!Title)
        TxtFont.Text = Trim(rst!Font)
        TxtFontSize.Text = Trim(str(rst!FontSize))
        TxtColor.Text = Trim(rst!Color)
        
        LabPreTitle.Caption = Trim(TxtTitle.Text)
        LabPreTitle.Font = Trim(TxtFont.Text)
        LabPreTitle.FontSize = Val(Trim(TxtFontSize.Text))
        LabPreTitle.ForeColor = Val(Trim(TxtColor.Text))
        LabPreTitle.Top = (PicTop.Height - LabPreTitle.Height) / 2
        LabPreTitle.Left = (PicTop.Width - LabPreTitle.Width) / 2
    Else
        TxtLTopFile.Text = ""
        TxtTopFile.Text = ""
        TxtLeftFile.Text = ""
        TxtRightFile.Text = ""
    
        Set PicLTop.Picture = LoadPicture("")
        Set PicTop.Picture = LoadPicture("")
        Set PicLeft.Picture = LoadPicture("")
        Set PicRight.Picture = LoadPicture("")
    
        TxtTitle.Text = "主页标题"
        TxtFont.Text = "楷体"
        TxtFontSize.Text = "36"
        TxtColor.Text = "&H00000000&"
        
        LabPreTitle.Caption = Trim(TxtTitle.Text)
        LabPreTitle.Font = Trim(TxtFont.Text)
        LabPreTitle.FontSize = Val(Trim(TxtFontSize.Text))
        LabPreTitle.ForeColor = Val(Trim(TxtColor.Text))
        LabPreTitle.Top = (PicTop.Height - LabPreTitle.Height) / 2
        LabPreTitle.Left = (PicTop.Width - LabPreTitle.Width) / 2
    End If
    
    rst.Close
    
    sql = "SELECT * FROM ParaTable where ParaName='StyleId'"
    Set rst = gclsDatabase.RDOSelect(sql)
    If rst.RowCount > 0 Then
        StyleId = rst!ParaValue
        rst.Close
        sql = "SELECT * FROM ParaTable where ParaName='ButtonStyle'"
        Set rst = gclsDatabase.RDOSelect(sql)
        If rst.RowCount > 0 Then
            ButtonStyle = rst!ParaValue
        End If
        
    End If
    If rst.Status = 0 Then
        rst.Close
    End If
    
    If StyleId = 1 Then
        PicRight1(5).Picture = PicRight1(0).Picture
    ElseIf StyleId = 2 Then
        If ButtonStyle = 1 Then
            PicRight1(5).Picture = PicRight1(1).Picture

        ElseIf ButtonStyle = 2 Then
            PicRight1(5).Picture = PicRight1(2).Picture

        ElseIf ButtonStyle = 3 Then
            PicRight1(5).Picture = PicRight1(3).Picture

        ElseIf ButtonStyle = 4 Then
            PicRight1(5).Picture = PicRight1(4).Picture
        End If
    End If
    '换皮肤
    Call LoadSkin(Me)
    Exit Sub
DatabaseError:
    Call ManageQuit
End Sub

Private Sub CmdSetMainPage_Click()
    On Error GoTo DatabaseError

    sql = "DELETE FROM mainpagestyle"
    Return_Var = gclsDatabase.RDODelete(sql)
    
    sql = "INSERT INTO mainpagestyle VALUES("
    sql = sql & "'" & Trim(TxtLTopFile.Text) & "',"
    sql = sql & "'" & Trim(TxtTopFile.Text) & "',"
    sql = sql & "'" & Trim(TxtLeftFile.Text) & "',"
    sql = sql & "'" & Trim(TxtRightFile.Text) & "',"
    sql = sql & "'" & Trim(TxtTitle.Text) & "',"
    sql = sql & "'" & Trim(TxtFont.Text) & "',"
    sql = sql & Trim(TxtFontSize.Text) & ","
    sql = sql & "'" & Trim(TxtColor.Text) & "')"
    Return_Var = gclsDatabase.RDOInsert(sql)
    If Return_Var = 0 Then GoTo DatabaseError

    'MsgBox "主页风格设置成功！", vbInformation, "系统信息"
    LabRight.Visible = True
    TimeInfo.Enabled = True
    
    Exit Sub
DatabaseError:
    Call ManageQuit
End Sub

Private Sub PicRight1_Click(Index As Integer)
'    If Index = 5 Then
'        FrmRightStyle.Show 1
'    End If
End Sub

Private Sub TimeInfo_Timer()
    LabRight.Visible = False
    TimeInfo.Enabled = False
End Sub

Private Sub TxtTitle_Change()
    LabPreTitle.Caption = Trim(TxtTitle.Text)
    LabPreTitle.Top = (PicTop.Height - LabPreTitle.Height) / 2
    LabPreTitle.Left = (PicTop.Width - LabPreTitle.Width) / 2
End Sub
上一页 12
⌨️ 快捷键说明

复制代码 Ctrl + C
搜索代码 Ctrl + F
全屏模式 F11
切换主题 Ctrl + Shift + D
显示快捷键 ?
增大字号 Ctrl + =
减小字号 Ctrl + -