frmmain.frm

一套企业设备管理系统源代码,所有的业务单据和流程都可以自定义,业务报表也可以通过SQL的存储过程来定义.

VERSION 5.00
Object = "{555E8FCC-830E-45CC-AF00-A012D5AE7451}#10.4#0"; "CommandBars.ocx"
Object = "{709F7AE3-E049-11D2-9362-00403332E72F}#1.0#0"; "LEDGER50.OCX"
Object = "{222252FE-2DE8-47DD-B4EF-C8B6CEB885E9}#5.0#0"; "VsTreeview.ocx"
Begin VB.Form frmMain 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Form1"
   ClientHeight    =   5175
   ClientLeft      =   45
   ClientTop       =   450
   ClientWidth     =   7890
   Icon            =   "frmMain.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   5175
   ScaleWidth      =   7890
   StartUpPosition =   2  '屏幕中心
   Begin LEDGER50Lib.Ledger50 frmRpt 
      Height          =   3855
      Left            =   2880
      TabIndex        =   1
      Top             =   360
      Width           =   4095
      _Version        =   65536
      _ExtentX        =   7223
      _ExtentY        =   6800
      _StockProps     =   237
      ForeColor       =   0
      BackColor       =   16777215
   End
   Begin VsTreeviewXP.vsTreeView frmTree 
      Height          =   3855
      Left            =   240
      TabIndex        =   0
      Top             =   360
      Width           =   2055
      _ExtentX        =   3625
      _ExtentY        =   6800
   End
   Begin XtremeCommandBars.ImageManager frmPic 
      Left            =   600
      Top             =   0
      _Version        =   655364
      _ExtentX        =   635
      _ExtentY        =   635
      _StockProps     =   0
      Icons           =   "frmMain.frx":27A2
   End
   Begin XtremeCommandBars.CommandBars frmBar 
      Left            =   1680
      Top             =   0
      _Version        =   655364
      _ExtentX        =   635
      _ExtentY        =   635
      _StockProps     =   0
   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 ResSign As Long
Private ErrInfo As String

Private DaCn As New ADODB.Connection
Private DaRs As New ADODB.Recordset
Private Sql As String

Private ItemSelSign As Boolean
Private DataSelSign As Boolean

Private Sub Form_Load()
 Call InitFormPara
 Call InitActiveX
End Sub

Private Sub InitFormPara()
 DataLibType.FItemID = BaseDllLib.getItemID
 ItemText.FItemID = BaseDllLib.getUserID
 Call DataLibType.getDataTypePara(ResSign, ErrInfo)
 Call ItemText.getItemText(ResSign, ErrInfo)
 With Me
  .Caption = "选择：" & DataLibType.FText
  .Width = Screen.Width * 0.5
  .Height = Screen.Height * 0.5
 End With
 '//打开数据库连接通道
 If DaCn.State = adStateOpen Then DaCn.Close
 DaCn.ConnectionString = BaseDllLib.getConStr
 DaCn.Open
End Sub

Private Sub InitActiveX()
 '//定义工具栏参数
 Dim TBar As CommandBar
 Dim TBarBnt As CommandBarControl
 '//定义状态栏参数
 Dim SBar As XtremeCommandBars.StatusBar
 Dim Pane As StatusBarPane
 '//初始化工具条
 frmPic.Icons.LoadIcon SysPara.ResLibIco & "SelText.Ico", 1, xtpImageNormal
 frmPic.Icons.LoadIcon SysPara.ResLibIco & "Exit.Ico", 2, xtpImageNormal
 frmPic.Icons.LoadIcon SysPara.ResLibIco & "User.Ico", 3, xtpImageNormal
 frmPic.Icons.LoadIcon SysPara.ResLibIco & "Timer.ico", 4, xtpImageNormal
 '//添加工具栏
 Set TBar = frmBar.Add("TBar", xtpBarTop)
 Set TBarBnt = TBar.Controls.Add(xtpControlButton, 1, "选择", -1, False)
 TBarBnt.ToolTipText = "选择数据"
 TBarBnt.DescriptionText = "选择数据"
 '//
 Set TBarBnt = TBar.Controls.Add(xtpControlButton, 2, "关闭", -1, False)
 TBarBnt.BeginGroup = True
 TBarBnt.ToolTipText = "关闭选择框"
 TBarBnt.DescriptionText = "关闭选择框"
 '//
 TBar.DefaultButtonStyle = xtpButtonIconAndCaption
 TBar.ShowExpandButton = False
 '//状态参数设置
 Set SBar = frmBar.StatusBar
 SBar.IdleText = "准备就绪"
 '/
 Set Pane = SBar.AddPane(1)
 Pane.Style = SBPS_NOBORDERS
 Pane.Text = ItemText.FName
 Pane.IconIndex = 3
 Pane.Width = 50
 '/
 Set Pane = SBar.AddPane(0)
 Pane.Style = SBPS_NOBORDERS
 Pane.TextColor = RGB(&H0, &H0, &HFF)
 Pane.Alignment = xtpAlignmentCenter
 Pane.Font.Bold = True
 Pane.Text = "准备就绪"
 Pane.Width = 350
 '/
 Set Pane = SBar.AddPane(2)
 Pane.Style = SBPS_NOBORDERS
 Pane.Text = BaseDllLib.GetServerDate(1)
 Pane.IconIndex = 4
 Pane.Width = 80
 '//
 SBar.Visible = True
 '//设置工具条参数
 frmBar.ActiveMenuBar.Visible = False
 frmBar.Icons = frmPic.Icons
 frmBar.VisualTheme = xtpThemeRibbon
 '//区域计算
 Call frmBar.GetClientRect(RecInfo.Left, RecInfo.Top, RecInfo.Right, RecInfo.Bottom)
 '//初始化属性结构
 With frmTree
  .Left = 0
  .Top = RecInfo.Top
  .Width = Me.ScaleWidth * 0.35
  .Height = RecInfo.Bottom - .Top
  Call .Initialize
  Call .InitializeImageList
  Call .EndLabelEdit(False)
  .BackColor = RGB(&HBA, &HD8, &HFF)
  .BorderStyle = bsNone
  .AddIcon LoadPicture(SysPara.ResLibIco & "TreeNode.Ico").Handle
  .AddNode , rFirst, , DataLibType.FText, 0, 0
 End With
 '//初始化列表
 With frmRpt
  .Left = frmTree.Left + frmTree.Width
  .Top = frmTree.Top
  .Width = Me.ScaleWidth - frmTree.Width
  .Height = frmTree.Height
  '//
  .Face.Rows = 2
  .Face.Cols = 2
  .Face.FixedRows = 1
  .Col(1).Switch(E_LDG_ColFlag_Hide) = True
  .Col(2).Width = 4800
  .Col(2).Align = E_LDG_AlignLeft
  '//
  Sql = "Exec " & DataLibType.FValue
  DaRs.CursorLocation = adUseClient
  DaRs.Open Sql, DaCn, adOpenStatic, adLockReadOnly
  .Face.Rows = DaRs.RecordCount + .Face.FixedRows
 End With
End Sub

Private Sub Form_Unload(Cancel As Integer)
 Dim frmCloseID As Long
 If ItemSelSign = False Then
  SysPara.FItemID = 0
  SysPara.FName = ""
  frmCloseID = MsgBox("关闭选择框？", vbQuestion + vbYesNo + vbDefaultButton2, BaseDllLib.getSysInfo)
  If frmCloseID <> 6 Then
   Cancel = 1
   Exit Sub
  End If
 End If
End Sub

Private Sub frmBar_Execute(ByVal Control As XtremeCommandBars.ICommandBarControl)
 Select Case Control.Id
  Case 1
   If DataSelSign = False Then
    MsgBox "选择：" & DataLibType.FText, vbCritical + vbOKOnly, BaseDllLib.getSysInfo
    Exit Sub
   End If
   Call frmRpt_DblClick
  Case 2
   DataSelSign = False
   Unload Me
 End Select
End Sub

Private Sub frmRpt_Click()
 SysPara.FItemID = Val(frmRpt.Cell(frmRpt.Sel.Row, 1).Text)
 SysPara.FName = Trim(frmRpt.Cell(frmRpt.Sel.Row, 2).Text)
 DataSelSign = True
End Sub

Private Sub frmRpt_DblClick()
 ItemSelSign = True
 Unload Me
End Sub

Private Sub frmRpt_FillRow(ByVal lRow As Long, strRowData As String, clrBack As stdole.OLE_COLOR, clrFore As stdole.OLE_COLOR)
 If lRow = 1 Then
  strRowData = "内码|标志名称|"
  Exit Sub
 End If
 DaRs.AbsolutePosition = lRow - frmRpt.Face.FixedRows
 strRowData = DaRs(0) & "|" & DaRs(1) & "|"
End Sub