frmmain.frm

本系统是一个报表分析查询系统

VERSION 5.00
Object = "{4932CEF1-2CAA-11D2-A165-0060081C43D9}#2.0#0"; "Actbar2.OCX"
Object = "{7802D41A-28B0-43C4-95EA-17B7E32337D1}#1.0#0"; "CellCtrl5.ocx"
Object = "{498657BA-CC68-4655-A4F8-D1EF13326F8A}#1.0#0"; "MsSuperMenuXP.ocx"
Begin VB.Form frmMain 
   Caption         =   "Form1"
   ClientHeight    =   7680
   ClientLeft      =   60
   ClientTop       =   465
   ClientWidth     =   10260
   LinkTopic       =   "Form1"
   ScaleHeight     =   7680
   ScaleWidth      =   10260
   StartUpPosition =   2  '屏幕中心
   Begin MaximSuperMenu.SuperMenu frmMenu 
      Left            =   2520
      Top             =   2640
      _ExtentX        =   900
      _ExtentY        =   900
      BmpCount        =   3
      Bmp:1           =   "frmMain.frx":0000
      Mask:1          =   12632256
      Key:1           =   "#InsertRow"
      Bmp:2           =   "frmMain.frx":0352
      Mask:2          =   12632256
      Key:2           =   "#AppendRow"
      Bmp:3           =   "frmMain.frx":06A4
      Mask:3          =   8421504
      Key:3           =   "#DeleteRow"
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      LicensedName    =   "冯孝刚"
      LicensedKey     =   "MSSMLNB471E504D43D53E3"
   End
   Begin CELL50Lib.Cell frmCell 
      Height          =   735
      Left            =   4440
      TabIndex        =   2
      Top             =   3480
      Width           =   1455
      _Version        =   65536
      _ExtentX        =   2566
      _ExtentY        =   1296
      _StockProps     =   0
   End
   Begin ActiveBar2LibraryCtl.ActiveBar2 SBar 
      Height          =   495
      Left            =   840
      TabIndex        =   1
      Top             =   6360
      Width           =   6015
      _LayoutVersion  =   1
      _ExtentX        =   10610
      _ExtentY        =   873
      _DataPath       =   ""
      Bands           =   "frmMain.frx":09F6
   End
   Begin ActiveBar2LibraryCtl.ActiveBar2 TBar 
      Height          =   375
      Left            =   600
      TabIndex        =   0
      Top             =   240
      Width           =   6735
      _LayoutVersion  =   1
      _ExtentX        =   11880
      _ExtentY        =   661
      _DataPath       =   ""
      Bands           =   "frmMain.frx":0BBE
   End
   Begin VB.Menu RowPer 
      Caption         =   "行操作"
      Visible         =   0   'False
      Begin VB.Menu InsertRow 
         Caption         =   "插入行"
      End
      Begin VB.Menu AppendRow 
         Caption         =   "追加行"
      End
      Begin VB.Menu DeleteRow 
         Caption         =   "删除行"
      End
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private ImgPath As String

'//初始化窗体
Private Sub Loadfrm()
 ImgPath = App.Path & "\ResLib\"
 With Me
  .Width = Screen.Width
  .Height = Screen.Height * 0.9
  .Caption = "编辑数据表"
  Set .Icon = LoadPicture(ImgPath & "Title.Ico")
 End With
End Sub

'//布局窗体控件
Private Sub LoadActiveX()
 '//
 With TBar
  .Left = 0
  .Top = 0
  .Width = Me.ScaleWidth
  .Height = 720
 End With
 '//
 With SBar
  .Left = 0
  .Width = Me.ScaleWidth
  .Height = 350
  .Top = Me.ScaleHeight - .Height
  .Picture = LoadPicture(ImgPath & "SBarBack.Gif")
 End With
 '//
 With frmCell
  .Left = 0
  .Top = TBar.Top + TBar.Height
  .Width = Me.ScaleWidth
  .Height = SBar.Top - .Top
 End With
End Sub

'//装载工具栏
Private Sub LoadTBar()
 TBar.UserDefinedCustomization = True
 '//
 Dim Tool As ActiveBar2LibraryCtl.Tool
 Dim Band As ActiveBar2LibraryCtl.Band
 '//
 With TBar
  .Picture = LoadPicture(ImgPath & "TBarBk.jpg")
 End With
 '//
 Set Band = TBar.Bands.Add("TTBar")
 With Band
  .Caption = "TTBar"
  .Type = ddBTNormal
  .DockingArea = ddDATop
  .GrabHandleStyle = ddGSIE
  .MouseTracking = ddTSColor
 End With
 '//
 Set Tool = Band.Tools.Add(1, "TSave")
 With Tool
  .Caption = "保存"
  .Category = "TTBar"
  .ControlType = ddTTButton
  .Style = ddSIconText
  .CaptionPosition = ddCPBelow
  .SetPicture 0, LoadPicture(ImgPath & "Save.Ico"), &HC0C0C0
  .ToolTipText = "保存数据表"
  .Visible = CmdState.Save_Cmd
 End With
 '//
 Set Tool = Band.Tools.Add(2, "TFind")
 With Tool
  .Caption = "搜索"
  .Category = "TTBar"
  .ControlType = ddTTButton
  .Style = ddSIconText
  .CaptionPosition = ddCPBelow
  .SetPicture 0, LoadPicture(ImgPath & "Find.Ico"), &HC0C0C0
  .ToolTipText = "搜索数据表"
  .Visible = CmdState.Find_Cmd
 End With
 '//
 Set Tool = Band.Tools.Add(3, "TPrint")
 With Tool
  .Caption = "打印"
  .Category = "TTBar"
  .ControlType = ddTTButton
  .Style = ddSIconText
  .CaptionPosition = ddCPBelow
  .SetPicture 0, LoadPicture(ImgPath & "Print.Ico"), &HC0C0C0
  .ToolTipText = "打印数据表"
  .Visible = CmdState.Prnt_Cmd
 End With
 '//
 Set Tool = Band.Tools.Add(4, "SplitTwo")
 With Tool
  .ControlType = ddTTSeparator
 End With
 '//
 Set Tool = Band.Tools.Add(5, "TExit")
 With Tool
  .Caption = "退出"
  .Category = "TTBar"
  .ControlType = ddTTButton
  .Style = ddSIconText
  .CaptionPosition = ddCPBelow
  .SetPicture 0, LoadPicture(ImgPath & "Exit.Ico"), &HC0C0C0
  .ToolTipText = "退出"
 End With
 TBar.RecalcLayout
 TBar.Refresh
End Sub

Private Sub LoadSBar()
 Dim Tool As ActiveBar2LibraryCtl.Tool
 Dim Band As ActiveBar2LibraryCtl.Band
 '//添加用户图标
 Set Tool = SBar.Tools.Add(1, "UserImg")
 With Tool
  .Height = SBar.Height
  .Alignment = ddACenterTop
  .ControlType = ddTTButton
  .SetPicture ddITNormal, LoadPicture(ImgPath & "User.Ico")
  .Style = ddSIcon
 End With
 '//添加用户名称
 Set Tool = SBar.Tools.Add(2, "UserName")
 With Tool
  .Height = SBar.Height
  .Alignment = ddALeftCenter
  .Caption = meObj.BaseInfo.getItemName(12, meObj.BaseInfo.getUserID)
  .ControlType = ddTTLabel
  .CaptionPosition = ddCPStandard
  .LabelBevel = ddLBInset
  .LabelStyle = ddLSNormal
  .Width = SBar.Width * 0.1
 End With
 '//添加主信息
 Set Tool = SBar.Tools.Add(3, "MainMsg")
 With Tool
  .Height = SBar.Height
  .Alignment = ddACenterCenter
  .Caption = "准备就绪"
  .ControlType = ddTTLabel
  .CaptionPosition = ddCPStandard
  .LabelBevel = ddLBInset
  .LabelStyle = ddLSNormal
  .Width = SBar.Width * 0.5
 End With
 '//添加时间图形
 Set Tool = SBar.Tools.Add(4, "DateImg")
 With Tool
  .Height = SBar.Height
  .Alignment = ddACenterTop
  .ControlType = ddTTButton
  .SetPicture ddITNormal, LoadPicture(ImgPath & "Timer.Ico")
  .Style = ddSIcon
 End With
 '//添加时间值
 Set Tool = SBar.Tools.Add(5, "DateVal")
 With Tool
  .Height = SBar.Height
  .Alignment = ddACenterCenter
  .Caption = meObj.BaseInfo.getServerDate(1)
  .ControlType = ddTTLabel
  .CaptionPosition = ddCPStandard
  .LabelBevel = ddLBInset
  .LabelStyle = ddLSNormal
  .Width = SBar.Width * 0.1
 End With
 '//
 Set Tool = SBar.Tools.Add(6, "Inst")
 With Tool
  .Height = SBar.Height
  .Alignment = ddACenterCenter
  .ControlType = ddTTLabel
  .CaptionPosition = ddCPStandard
  .LabelBevel = ddLBInset
  .LabelStyle = ddLSInsert
 End With
 Set Band = SBar.Bands.Add("TSBar"): Band.Type = ddBTStatusBar
 With Band.Tools
  .Insert .Count, SBar.Tools("UserImg")
  .Insert .Count, SBar.Tools("UserName")
  .Insert .Count, SBar.Tools("MainMsg")
  .Insert .Count, SBar.Tools("DateImg")
  .Insert .Count, SBar.Tools("DateVal")
  .Insert .Count, SBar.Tools("Inst")
 End With
 SBar.RecalcLayout
 SBar.Refresh
End Sub

Private Sub LoadCell()
 On Error GoTo ErrHandle
 Dim iLoop As Integer
 Dim tlMin As Integer
 Dim tlMax As Integer
 
 tlMin = LBound(meCell.ColData)
 tlMax = UBound(meCell.ColData)
 With frmCell
  '//
  .ShowTopLabel 0, 0
  .ShowSideLabel 0, 0
  .ShowSheetLabel 0, 0
  .SetSelectMode 0, 2
  .ShowPageBreak 0
  '//滚动栏信息
'  .ShowHScroll 0, 0
'  .ShowVScroll 0, 0
  .AllowSizeColInGrid = True
  .AllowSizeRowInGrid = True
  '//页面信息
  .PrintSetPaper 9
  .PrintSetOrient 1
  .PrintSetAlign 1, 1
  .PrintSetMargin 10, 0.5, 10, 0.5
  .WndBkColor = RGB(&HFF, &HFF, &HFF)
  '
  .SetCols meCell.MaxCol, 0
  .SetRows meCell.MaxRow, 0
  
  '//初始化标题
  For iLoop = tlMin To tlMax
   .SetColWidth 1, 100, iLoop, 0
   .SetCellAlign iLoop, 1, 0, 4 + 32
   .SetCellInput iLoop, 1, 0, 5
   .SetCellFontStyle iLoop, 1, 0, 2
   .SetCellString iLoop, 1, 0, meCell.ColData(iLoop).Name
  Next
  
  '//初始化表体
  tlMin = LBound(meCell.Text)
  tlMax = UBound(meCell.Text)
  For iLoop = tlMin To tlMax
   Select Case meCell.Text(iLoop).tType
    Case 3, 4, 5, 6, 11, 17, 20, 128, 131, 204 '//数值
     .SetCellAlign meCell.Text(iLoop).tCol, meCell.Text(iLoop).tRow, 0, 2 + 32
     .SetCellNumType meCell.Text(iLoop).tCol, meCell.Text(iLoop).tRow, 0, 1
     .SetCellDigital meCell.Text(iLoop).tCol, meCell.Text(iLoop).tRow, 0, meCell.Text(iLoop).tDigit
     .SetCellInput meCell.Text(iLoop).tCol, meCell.Text(iLoop).tRow, 0, 2
     .SetCellDouble meCell.Text(iLoop).tCol, meCell.Text(iLoop).tRow, 0, Val(meCell.Text(iLoop).tText)
    Case 129, 200, 201, 202, 203 '//字符
     .SetCellAlign meCell.Text(iLoop).tCol, meCell.Text(iLoop).tRow, 0, 1 + 32
     .SetCellNumType meCell.Text(iLoop).tCol, meCell.Text(iLoop).tRow, 0, 7
     .SetCellString meCell.Text(iLoop).tCol, meCell.Text(iLoop).tRow, 0, meCell.Text(iLoop).tText
    Case 135 '//时间
     .SetCellAlign meCell.Text(iLoop).tCol, meCell.Text(iLoop).tRow, 0, 4 + 32
     .SetCellNumType meCell.Text(iLoop).tCol, meCell.Text(iLoop).tRow, 0, 3
     .SetCellDateStyle meCell.Text(iLoop).tCol, meCell.Text(iLoop).tRow, 0, 22
     .SetCellDateTime meCell.Text(iLoop).tCol, meCell.Text(iLoop).tRow, 0, meCell.Text(iLoop).tText
   End Select
  Next
 End With
 SBar.Bands("TSBar").Tools("MainMsg").Caption = "装在原有数据成功"
 SBar.Refresh
 Exit Sub
ErrHandle:
 meCell.MaxRow = meCell.MaxRow + 1
 frmCell.SetRows meCell.MaxRow, 0
 tlMin = LBound(meCell.ColData)
 tlMax = UBound(meCell.ColData)
 For iLoop = tlMin To tlMax
  Select Case meCell.ColData(iLoop).Type
    Case 3, 4, 5, 6, 11, 17, 20, 128, 131, 204 '//数值
     frmCell.SetCellAlign iLoop, 2, 0, 2 + 32
     frmCell.SetCellNumType iLoop, 2, 0, 1
     frmCell.SetCellDigital iLoop, 2, 0, meCell.ColData(iLoop).Digit
     frmCell.SetCellInput iLoop, 2, 0, 2
    Case 129, 200, 201, 202, 203 '//字符
     frmCell.SetCellAlign iLoop, 2, 0, 1 + 32
     frmCell.SetCellInput iLoop, 2, 0, 0
     frmCell.SetCellNumType iLoop, 2, 0, 7
    Case 135 '//时间
     frmCell.SetCellAlign iLoop, 2, 0, 4 + 32
     frmCell.SetCellInput iLoop, 2, 0, 0
     frmCell.SetCellNumType iLoop, 2, 0, 3
     frmCell.SetCellDateStyle iLoop, 2, 0, 22
  End Select
 Next
 SBar.Bands("TSBar").Tools("MainMsg").Caption = "错误：" & Err.Description & "::可能数据表中没有原始数据"
 SBar.Refresh
End Sub

Private Sub AppendRow_Click()
 frmCell.InsertRow meCell.MaxRow, 1, 0
 meCell.MaxRow = meCell.MaxRow + 1
End Sub

Private Sub DeleteRow_Click()
 If meCell.CurRow = 1 Then Exit Sub
 Dim RetVal As Long
 RetVal = MsgBox("删除选择的行？", vbQuestion + vbYesNo + vbDefaultButton2, meObj.BaseInfo.getMsgInfo)
 If RetVal <> 6 Then
  Exit Sub
 End If
 frmCell.DeleteRow meCell.CurRow, 1, 0
 meCell.CurRow = meCell.CurRow - 1
 meCell.MaxRow = meCell.MaxRow - 1
End Sub

Private Sub Form_Load()
 Call InitRith
 Call Loadfrm
 Call LoadActiveX
 Call LoadTBar
 Call LoadSBar
 Call LoadCell
End Sub

Private Sub Form_Resize()
 Call LoadActiveX
End Sub

Private Sub frmCell_MenuStart(ByVal col As Long, ByVal row As Long, ByVal Section As Long)
 PopupMenu RowPer
End Sub

Private Sub frmCell_MouseLClick(ByVal col As Long, ByVal row As Long, ByVal updn As Long)
 meCell.CurCol = col
 meCell.CurRow = row
End Sub


Private Sub InsertRow_Click()
 frmCell.InsertRow meCell.CurRow, 1, 0
 meCell.MaxRow = meCell.MaxRow + 1
End Sub

'//保存数据
Private Function SaveTable(ByVal TableName As String, ByRef MsgInfo As String) As Boolean
 On Error GoTo ErrHandle
 Dim iLoop As Integer
 Dim jLoop As Integer
 Dim DataType As Long
 Dim tlMin As Integer
 Dim tlMax As Integer
 Dim tLoop As Integer
 Dim Sql As String
 Dim tSql() As String
 Dim cRec As Integer
 Dim tRec As Integer
 Dim DaCn As New ADODB.Connection
 '//
 tLoop = 0
 tLoop = tLoop + 1
 ReDim Preserve tSql(1 To tLoop)
 tSql(tLoop) = "delete from " & TableName
 
 For iLoop = 2 To meCell.MaxRow - 1
  Sql = "insert into " & TableName & " values("
  For jLoop = 1 To meCell.MaxCol - 1
   DataType = frmCell.GetCellNumType(jLoop, iLoop, 0)
   Select Case DataType
    Case 1, 2, 5, 6 '//数值
     Sql = Sql & frmCell.GetCellDouble2(jLoop, iLoop, 0) & ","
    Case 0, 3, 4, 7, 8 '//字符
     Sql = Sql & "'" & frmCell.GetCellString2(jLoop, iLoop, 0) & "',"
   End Select
  Next
  Sql = Left(Sql, Len(Sql) - 1) & ")"
  
  tLoop = tLoop + 1
  ReDim Preserve tSql(1 To tLoop)
  tSql(tLoop) = Sql
 Next
 
 tlMin = LBound(tSql)
 tlMax = UBound(tSql)
 tRec = tlMax - tlMin + 1
 DaCn.ConnectionString = meObj.BaseInfo.getConStr
 DaCn.Open
 DaCn.BeginTrans
 For iLoop = tlMin To tlMax
  'MsgBox tSql(iLoop)
  DaCn.Execute tSql(iLoop)
  SBar.Bands("TSBar").Tools("MainMsg").Caption = "执行完成 " & Format((iLoop / tRec) * 100, "0.00") & "％"
  SBar.Refresh
 Next
 DaCn.CommitTrans
 DaCn.Close
 Set DaCn = Nothing
 SBar.Bands("TSBar").Tools("MainMsg").Caption = "保存数据完成"
 SBar.Refresh
 MsgInfo = "保存数据成功"
 SaveTable = True
 Exit Function
ErrHandle:
 MsgInfo = "保存数据错误：" & Err.Description
 SBar.Bands("TSBar").Tools("MainMsg").Caption = MsgInfo
 SBar.Refresh
 SaveTable = False
End Function

'//搜索数据
Private Sub FndTable()
 Unload Me
 Call meObj.mShow(1)
End Sub

Private Sub TBar_ToolClick(ByVal Tool As ActiveBar2LibraryCtl.Tool)
 Dim MsgInfo As String
 Select Case Tool.Caption
  Case "保存"
   If SaveTable(selTableName, MsgInfo) = False Then
    MsgBox MsgInfo, vbCritical + vbOKOnly, meObj.BaseInfo.getMsgInfo
   Else
    MsgBox MsgInfo, vbInformation + vbOKOnly, meObj.BaseInfo.getMsgInfo
   End If
  Case "搜索"
   Call FndTable
  Case "打印"
   frmCell.PrintPreview 100, 0
  Case "退出"
   Unload Me
 End Select
End Sub