seluser.frm

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

VERSION 5.00
Object = "{4932CEF1-2CAA-11D2-A165-0060081C43D9}#2.0#0"; "Actbar2.OCX"
Object = "{709F7AE3-E049-11D2-9362-00403332E72F}#1.0#0"; "LEDGER50.OCX"
Begin VB.Form SelUser 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Form1"
   ClientHeight    =   3075
   ClientLeft      =   45
   ClientTop       =   450
   ClientWidth     =   4680
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3075
   ScaleWidth      =   4680
   StartUpPosition =   2  '屏幕中心
   Begin LEDGER50Lib.Ledger50 frmRpt 
      Height          =   1335
      Left            =   720
      TabIndex        =   2
      Top             =   840
      Width           =   3015
      _Version        =   65536
      _ExtentX        =   5318
      _ExtentY        =   2355
      _StockProps     =   237
      ForeColor       =   0
      BackColor       =   16777215
   End
   Begin ActiveBar2LibraryCtl.ActiveBar2 SBar 
      Height          =   375
      Left            =   240
      TabIndex        =   1
      Top             =   2520
      Width           =   3615
      _LayoutVersion  =   1
      _ExtentX        =   6376
      _ExtentY        =   661
      _DataPath       =   ""
      Bands           =   "SelUser.frx":0000
   End
   Begin ActiveBar2LibraryCtl.ActiveBar2 TBar 
      Height          =   375
      Left            =   360
      TabIndex        =   0
      Top             =   0
      Width           =   4095
      _LayoutVersion  =   1
      _ExtentX        =   7223
      _ExtentY        =   661
      _DataPath       =   ""
      Bands           =   "SelUser.frx":01C8
   End
End
Attribute VB_Name = "SelUser"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private ImgPath As String
Private ImgStd As StdPicture
Private daCn As New ADODB.Connection
Private daRs As New ADODB.Recordset
Private lSql As String
Private SelSign As Boolean

'//窗体初始化
Private Sub formInit()
 '//参数初始化
 ImgPath = App.Path & "\ResLib\"
 Set ImgStd = LoadPicture(ImgPath & "Title.Ico")
 With Me
  .Caption = TitleText & "[本方案中的用户列表]"
  Set .Icon = ImgStd
  .Width = Screen.Width * 0.5
  .Height = Screen.Height * 0.7
 End With
 '//
 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 frmRpt
  .Left = 0
  .Top = TBar.Top + TBar.Height
  .Width = Me.ScaleWidth
  .Height = SBar.Top - .Top
 End With
 '//
 daCn.ConnectionString = meObj.BaseInfo.getConStr
 daCn.Open
End Sub

'//初始化工具栏
Private Sub LoadTBar()
 TBar.UserDefinedCustomization = True
 '//
 Dim Tool As ActiveBar2LibraryCtl.Tool
 Dim Band As ActiveBar2LibraryCtl.Band
 '//
 Set ImgStd = LoadPicture(ImgPath & "TBarBk.jpg")
 With TBar
  .Picture = ImgStd
 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, "TSel")
 With Tool
  .Caption = "选择"
  .Category = "TTBar"
  .ControlType = ddTTButton
  .Style = ddSIconText
  .CaptionPosition = ddCPBelow
  .SetPicture 0, LoadPicture(ImgPath & "Check.Ico"), &HC0C0C0
  .ToolTipText = "选择[用户]"
 End With
 '//
 Set Tool = Band.Tools.Add(2, "SplitOne")
 With Tool
  .ControlType = ddTTSeparator
 End With
 '//
 Set Tool = Band.Tools.Add(3, "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 LoadRpt()
 Dim iLoop As Integer
 With frmRpt
  '//
  .Face.Rows = 2
  .Face.FixedRows = 1
  .Face.Cols = 3
  .Face.Switch(E_LDG_LdgFlag_MultiSel) = True
  .col(1).Width = 0
  .col(1).Switch(E_LDG_ColFlag_Hide) = True
  
  .col(2).Width = 3000
  .col(2).Align = E_LDG_AlignLeft
  
  .col(3).Width = 2000
  .col(3).Align = E_LDG_AlignLeft
 End With
End Sub

Private Sub RefreshLdg()
 On Error GoTo Errhandler
 lSql = "select js_userid,js_username,js_state=case js_usesign when 0 then '禁止' when 1 then '启用' end from js_user order by js_username asc"
 If daRs.State = adStateOpen Then daRs.Close
 daRs.CursorLocation = adUseClient
 daRs.Open lSql, daCn, adOpenStatic, adLockReadOnly
 frmRpt.Merge.UnMergeAll
 frmRpt.Face.Rows = daRs.RecordCount + frmRpt.Face.FixedRows
 frmRpt.Face.ForceRefresh
 Exit Sub
Errhandler:
 Msgbox "错误，编号：" & Err.Number & "-->信息：" & Err.Description, vbCritical + vbOKOnly, meObj.BaseInfo.getMsgInfo
End Sub

'//选择用户
Private Function getSelUserList() As String
 Dim SelUserIDs() As Long
 Dim iLoop As Integer
 Dim RetValue As String
 SelUserIDs = frmRpt.Sel.Rows
 For iLoop = LBound(SelUserIDs) To UBound(SelUserIDs)
  RetValue = RetValue & Val(frmRpt.Cell(SelUserIDs(iLoop), 1).Text) & "^"
  SelUserNameList = SelUserNameList & Trim(frmRpt.Cell(SelUserIDs(iLoop), 2).Text) & "]["
 Next
 If Trim(RetValue) <> "" Then
  RetValue = "^" & RetValue
  SelUserNameList = "[" & Left(SelUserNameList, Len(SelUserNameList) - 1)
 End If
 getSelUserList = RetValue
End Function


Private Sub Form_Load()
 Call formInit
 Call LoadTBar
 Call LoadSBar
 Call LoadRpt
 Call RefreshLdg
End Sub

Private Sub Form_Unload(Cancel As Integer)
 If daRs.State = adStateOpen Then daRs.Close
 If daCn.State = adStateOpen Then daCn.Close
 Set daRs = Nothing
 Set daCn = Nothing
 Set ImgStd = Nothing
 '//
 If SelSign = False Then SelUserIDList = ""
End Sub

Private Sub frmRpt_FillRow(ByVal lRow As Long, strRowData As String, clrBack As stdole.OLE_COLOR, clrFore As stdole.OLE_COLOR)
 Dim iLoop As Integer
 If lRow = 1 Then
  strRowData = "用户内码|用户名称|用户状态|"
  Exit Sub
 End If
 daRs.AbsolutePosition = lRow - frmRpt.Face.FixedRows
 strRowData = daRs(0) & "|" & daRs(1) & "|" & daRs(2) & "|"
End Sub

Private Sub TBar_ToolClick(ByVal Tool As ActiveBar2LibraryCtl.Tool)
 Select Case Tool.Name
  Case "TSel"
   SelUserIDList = getSelUserList
   SelSign = True
   Unload Me
  Case "TExit"
   SelSign = False
   SelUserIDList = ""
   Unload Me
 End Select
End Sub