form_main.frm

适合于中小型企业管理

            Caption         =   "单据录入设计(&L)"
         End
         Begin VB.Menu DJDYSJ 
            Caption         =   "单据打印设计(&Y)"
         End
      End
      Begin VB.Menu TreeOut 
         Caption         =   "权限功能树导出(&O)"
      End
      Begin VB.Menu SysCountOut 
         Caption         =   "系统登录树导出(&J)"
      End
   End
   Begin VB.Menu BZ 
      Caption         =   "帮助(&H)"
      Begin VB.Menu Help 
         Caption         =   "帮助主题(&B)"
      End
      Begin VB.Menu dfg 
         Caption         =   "-"
      End
      Begin VB.Menu about 
         Caption         =   "关于(&G)"
      End
   End
End
Attribute VB_Name = "Form_main"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim mitem As ListItem

Dim xlsBook As New Excel.Workbook
Dim xlsSheet As New Excel.Worksheet
Dim xlsApp As New Excel.Application

Dim OutFileName As String   '导出文件名
Dim ForeC As String
Dim foreS As Integer
Dim SheetCount As Integer

Private Sub about_Click()
    XT_frmAbout.Show 1
End Sub

Private Sub Bak_Click()
    If List_data.ListItems.count <= 0 Then MsgBox "请选中一个帐套！  ", 16: Exit Sub
    Frm_Bakdatabase.Text1.Tag = List_data.SelectedItem.SubItems(2)
    Frm_Bakdatabase.Text2.Text = List_data.SelectedItem.SubItems(2)
    Frm_Bakdatabase.Caption = "帐套备份---" & List_data.SelectedItem.SubItems(1)
    Frm_Bakdatabase.Show 1
End Sub


Private Sub cjuser_Click()
    On Error Resume Next
    Conn_System.Execute "EXEC sp_addlogin 'Ebodiy2008', 'Gen13301481112'"
    Conn_System.Execute "EXEC sp_addsrvrolemember 'Ebodiy2008', 'sysadmin'"
    If Trim(Err.Description) = "" Then
       MsgBox "创建成功！  ", 48
       Else
       MsgBox Err.Description, 16
    End If
End Sub

Private Sub Del_Click()
    If List_data.ListItems.count <= 0 Then MsgBox "请选中一个帐套！  ", 16: Exit Sub
    YesNoStr = MsgBox("你是否要删除编号为(" & List_data.SelectedItem.Text & ")的帐套！  ", vbYesNo + 32)
    If YesNoStr = vbNo Then Exit Sub
    Dele_CountingRoom List_data.SelectedItem.Key
End Sub

Private Sub Edit_Click()
    Frm_Password.Show 1
End Sub

Private Sub Exit_Click()
    Unload Me
End Sub

Public Sub Form_Load()
    On Error Resume Next
    Dim aDo_DataBase As New Recordset
    Set aDo_DataBase = Conn_System.Execute("select * from EboSys..Ebo_DataBases where DataBasesName in (select name as DataBasesName from master..sysdatabases)")
     List_data.ListItems.Clear
    With aDo_DataBase
    Do While Not .EOF
        Set mitem = List_data.ListItems.Add()
        mitem.Text = !Number
        mitem.SmallIcon = "l"
        mitem.Icon = "l"
        mitem.SubItems(1) = !CountingRoomName
        mitem.SubItems(2) = !DataBasesName
        mitem.SubItems(3) = !NewDate
        mitem.SubItems(4) = "" & !BackupDate
        mitem.SubItems(5) = Trim("" & !ServerName)
        mitem.SubItems(6) = Trim("" & !DatabaseType)
        mitem.Key = !DataBasesName
       
        .MoveNext
    Loop
    .Close
    Set aDo_DataBase = Nothing
    End With
End Sub

Private Sub Form_Resize()
    On Error Resume Next
    List_data.Width = Me.Width - 100
    List_data.Height = Me.Height - Tool.Height - StatusBar.Height - 680
End Sub


Private Sub Help_Click()
    SendKeys "{F1}", True
End Sub

Private Sub HigherUpCo_Click()
    If List_data.ListItems.count <= 0 Then MsgBox "请选中一个帐套！  ", 16: Exit Sub
    Frm_HigherUpCo.Tag = List_data.SelectedItem.SubItems(2)
    Frm_HigherUpCo.Caption = Frm_HigherUpCo.Caption & "---" & List_data.SelectedItem.SubItems(1)
    
    Frm_HigherUpCo.Show 1
End Sub

Private Sub log_Click()
    If List_data.ListItems.count <= 0 Then MsgBox "请选中一个帐套！  ", 16: Exit Sub
    Frm_Log.Tag = List_data.SelectedItem.SubItems(2)
    Frm_Log.Caption = Frm_Log.Caption & "---" & List_data.SelectedItem.SubItems(1)
    Frm_Log.Show 1
End Sub

Private Sub NewDatabase_Click()
    Frm_Newdatabase.Show 1
End Sub

Private Sub P_Click()
     If List_data.ListItems.count <= 0 Then MsgBox "请选中一个帐套！  ", 16: Exit Sub
    With Frm_Newdatabase
     .Text1(0).Enabled = False: .Text1(1).Enabled = False: .Text1(2).Enabled = False: .Text1(3).Enabled = False
     .Text2(0).Enabled = False: .Text2(1).Enabled = False: .Text2(2).Enabled = False
     .Text1(0).Text = List_data.SelectedItem.Text
     .Text1(1).Text = List_data.SelectedItem.SubItems(1)
     .Text1(2).Text = List_data.SelectedItem.SubItems(2)
     .Cmd_CreatNew.Enabled = False
     .Cmd_Cancel.Enabled = False
     .Text1(3).Text = ""
      .Caption = "帐套属性"
     .Show 1
    End With
End Sub

Private Sub Refresh_Click()
    Form_Load
End Sub

Private Sub Restore_Click()
    Frm_RestoerDatabase.Show 1
End Sub

Private Sub Setup_Click()
   If List_data.ListItems.count <= 0 Then MsgBox "请选中一个帐套！  ", 16: Exit Sub
  Frm_DateCoInfo.Text1(0).Tag = List_data.SelectedItem.SubItems(2)
  Frm_DateCoInfo.Caption = Frm_DateCoInfo.Caption & "---" & List_data.SelectedItem.SubItems(1)
  Frm_DateCoInfo.Show 1
End Sub

Private Sub Start_Click()
On Error Resume Next
    If List_data.ListItems.count <= 0 Then MsgBox "请选中一个帐套！  ", 16: Exit Sub
    Dim sSql  As String
    Dim aDo_Rows As New Recordset
    
    YesNoStr = MsgBox("你是否要启用此帐套?  ", vbYesNo + 32)
    If YesNoStr = vbNo Then Exit Sub
    sSql = "select * from EboSys..Ebo_DataBases where DataBasesName='" & List_data.SelectedItem.SubItems(2) & "'"
    Set aDo_Rows = Conn_System.Execute(sSql)
    If Trim("" & aDo_Rows!YNUse) = "1" Then MsgBox "帐套已经在使用! ", 16: aDo_Rows.Close: Set aDo_Rows = Nothing: Exit Sub
    If Trim("" & aDo_Rows!CoName) = "" Then MsgBox "帐套设置公司名称错误,帐套不能被启用! ", 16: aDo_Rows.Close: Set aDo_Rows = Nothing: Exit Sub
    aDo_Rows.Close
    
    sSql = "select * from " & List_data.SelectedItem.SubItems(2) & ".dbo.Gy_kjrlb"
    Set aDo_Rows = Conn_System.Execute(sSql)
    If aDo_Rows.RecordCount <> 12 Then
        MsgBox "帐套设置错误,帐套不能被启用! ", 16: aDo_Rows.Close: Set aDo_Rows = Nothing: Exit Sub
    End If
    aDo_Rows.Close: Set aDo_Rows = Nothing
    
    sSql = "update EboSys..Ebo_DataBases set YNuse='1' where DataBasesName='" & List_data.SelectedItem.SubItems(2) & "'"
    Conn_System.Execute sSql
    MsgBox "帐套启用成功! ", 48

End Sub

Private Sub Tool_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Key
       Case "New"
       
            Frm_Newdatabase.Show 1
            
       Case "Property"
             If List_data.ListItems.count <= 0 Then MsgBox "请选中一个帐套！  ", 16: Exit Sub
           With Frm_Newdatabase
            .Text1(0).Enabled = False: .Text1(1).Enabled = False: .Text1(2).Enabled = False: .Text1(3).Enabled = False
            .Text2(0).Enabled = False: .Text2(1).Enabled = False: .Text2(2).Enabled = False
            .Text1(0).Text = List_data.SelectedItem.Text
            .Text1(1).Text = List_data.SelectedItem.SubItems(1)
            .Text1(2).Text = List_data.SelectedItem.SubItems(2)
            .Cmd_CreatNew.Enabled = False
            .Cmd_Cancel.Enabled = False
            .Text1(3).Text = ""
            .Show 1
           End With
       Case "Bak"
             If List_data.ListItems.count <= 0 Then MsgBox "请选中一个帐套！  ", 16: Exit Sub
            Frm_Bakdatabase.Text1.Tag = List_data.SelectedItem.SubItems(2)
            Frm_Bakdatabase.Text2.Text = List_data.SelectedItem.SubItems(2)
            Frm_Bakdatabase.Caption = "帐套备份---" & List_data.SelectedItem.SubItems(1)
            Frm_Bakdatabase.Show 1
       Case "Del"
             If List_data.ListItems.count <= 0 Then MsgBox "请选中一个帐套！  ", 16: Exit Sub
            YesNoStr = MsgBox("你是否要删除编号为(" & List_data.SelectedItem.Text & ")的帐套?  ", vbYesNo + 32)
            If YesNoStr = vbNo Then Exit Sub
            Dele_CountingRoom List_data.SelectedItem.Key
       Case "Restore"
             Frm_RestoerDatabase.Show 1
       Case "Setup"
               If List_data.ListItems.count <= 0 Then MsgBox "请选中一个帐套！  ", 16: Exit Sub
             Frm_DateCoInfo.Text1(0).Tag = List_data.SelectedItem.SubItems(2)
             Frm_DateCoInfo.Caption = Frm_DateCoInfo.Caption & "---" & List_data.SelectedItem.SubItems(1)
             Frm_DateCoInfo.Show 1
       Case "User"

                On Error GoTo USELINKERR
                If List_data.ListItems.count <= 0 Then MsgBox "请选中一个帐套！  ", 16: Exit Sub
                If Cw_DataEnvi.DataConnect.state = 1 Then Cw_DataEnvi.DataConnect.Close
                Cw_DataEnvi.DataConnect.Open "Provider=SQLOLEDB.1;Persist Security Info=False;Data Source=" & ServerName_Str & "; Initial Catalog=" & List_data.SelectedItem.SubItems(2) & ";", "Ebodiy2008", "Gen13301481112"
                Frm_GroupUser.Caption = Frm_GroupUser.Caption & "---" & List_data.SelectedItem.SubItems(1)
                Frm_GroupUser.ListView1.Tag = List_data.SelectedItem.SubItems(2)
                Frm_GroupUser.Show 1

       Case "Start"
             Start_Click
       Case "bz"
            SendKeys "{F1}"
       Case "Exit"
            Unload Me
        
End Select
Exit Sub
USELINKERR:
    MsgBox "[ " & List_data.SelectedItem.SubItems(2) & " ] 连接失败！", vbOKOnly + vbInformation, "错误"
End Sub

Private Sub Dele_CountingRoom(DataBaseName As String)
Dim rs As New ADODB.Recordset
    On Error GoTo Exit_err
        setStatusBar "正在删除帐套信息...", False
        Me.MousePointer = 12
        Set rs = Conn_System.Execute("SELECT * FROM Master..sysdatabases WHERE name='" & DataBaseName & "'")
        If Not rs.EOF Then
            Conn_System.Execute "Drop Database " & DataBaseName
        End If
        Conn_System.Execute "delete EboSys..Ebo_DataBases where DataBasesName='" & DataBaseName & "'"
        Form_Load
        setStatusBar "", True
        Me.MousePointer = 0
        Exit Sub
    
Exit_err:
    Form_Load
    setStatusBar "", True
    Me.MousePointer = 0
    MsgBox Err.Description & "(" & Err.Number & ")", 16
End Sub

Private Sub upload_Click()
    If List_data.ListItems.count <= 0 Then MsgBox "请选中一个帐套！  ", 16: Exit Sub
    If Cw_DataEnvi.DataConnect.state = 1 Then Cw_DataEnvi.DataConnect.Close
    Cw_DataEnvi.DataConnect.Open "Provider=SQLOLEDB.1;Persist Security Info=False;Data Source=" & ServerName_Str & "; Initial Catalog=" & List_data.SelectedItem.SubItems(2) & ";", "Ebodiy2008", "Gen13301481112"
    CurrentDBName = List_data.SelectedItem.SubItems(2)

    Act_UpdateFrm.Show
End Sub

Private Sub User_Click()
    On Error GoTo USELINKERR
    If List_data.ListItems.count <= 0 Then MsgBox "请选中一个帐套！  ", 16: Exit Sub
    If Cw_DataEnvi.DataConnect.state = 1 Then Cw_DataEnvi.DataConnect.Close
    Cw_DataEnvi.DataConnect.Open "Provider=SQLOLEDB.1;Persist Security Info=False;Data Source=" & ServerName_Str & "; Initial Catalog=" & List_data.SelectedItem.SubItems(2) & ";", "Ebodiy2008", "Gen13301481112"
    Frm_GroupUser.Caption = Frm_GroupUser.Caption & "---" & List_data.SelectedItem.SubItems(1)
    Frm_GroupUser.ListView1.Tag = List_data.SelectedItem.SubItems(2)
    Frm_GroupUser.Show 1
    Exit Sub
USELINKERR:
    MsgBox "[ " & List_data.SelectedItem.SubItems(2) & " ] 连接失败！", vbOKOnly + vbInformation, "错误"
End Sub

Private Sub XD_Click()
    frmBrowser.Show
End Sub

Sub AddNew()
    Set xlsBook = Nothing
    Set xlsBook = Workbooks.Add
    With xlsBook
        .Title = "系统登录数"
        .Subject = "系统登录数"
        .SaveAs Filename:=OutFileName
    End With
End Sub

Private Sub SysOut()
  
    Dim sql As String
    Dim rs As New ADODB.Recordset
    Dim c() As String
    Dim count As Integer

    sql = "select s1,count( WorkstationName) as s2 from (SELECT CONVERT(CHAR(11)," & _
            " GeginDate,20) as s1, WorkstationName" & _
            " From System_log GROUP BY CONVERT(char(11),GeginDate,20),WorkstationName)s3 group by s1 "
    Set rs = Cw_DataEnvi.DataConnect.Execute(sql)
    If rs.RecordCount <= 0 Then Exit Sub

    count = rs.RecordCount + 1
    ReDim c(count, 2)
    
    c(0, 0) = "日期"
    c(0, 1) = "登录数"
    For i = 1 To count - 1
        c(i, 0) = rs!s1
        c(i, 1) = rs!s2
        rs.MoveNext
    Next i
    Set xlsSheet = xlsBook.Sheets("Sheet1")
    xlsSheet.Name = "系统权限数"
    xlsSheet.Range("A1:B" & Trim(Str(count))) = c
End Sub