frmmain.frm

系统主控台 1、功能菜单 文件：设置（数据参数、修改密码、系统参数）、注销、退出 帮助：关于、注册、在线升级 2、功能按钮 执行、注销、退出 3、控制台 设置 参数设置：数据

    Case 21 '//字符变量
     Sql = Sql & " '" & getStrValue(ListSqlCmdParaName.Item(iLoop)) & "',"
    Case 22 '//数值变量
     Sql = Sql & " " & getLngValue(ListSqlCmdParaName.Item(iLoop)) & ","
   End Select
  Next
 End If
 If Right(Sql, 1) = "," Then Sql = Left(Sql, Len(Sql) - 1)
 '//Me.Caption = Sql
 If DaRs.State = adStateOpen Then DaRs.Close
 DaRs.CursorLocation = adUseClient
 DaRs.Open Sql, DaCn, adOpenStatic, adLockReadOnly
 frmRpt.Merge.UnMergeAll
 frmRpt.Face.Rows = DaRs.RecordCount + frmRpt.Face.FixedRows
 frmRpt.Face.ForceRefresh
 Exit Sub
ErrHandle:
 MsgBox "数据查询错误：" & Chr(13) & "    错误编号：" & Err.Number & Chr(13) & "    错误信息：" & Err.Description, vbCritical + vbOKOnly, BaseDllLib.getSysInfo
End Sub

Private Sub Form_Paint()
 Call Form_Resize
End Sub

Private Sub Form_Resize()
 On Error Resume Next
 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
  End With
 With frmRpt
  .Left = frmTree.Left + frmTree.width
  .Top = frmTree.Top
  .width = Me.ScaleWidth - frmTree.width
  .Height = frmTree.Height
 End With
End Sub

Public Sub TreeViewMessage(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long, RetVal As Long, UseRetVal As Boolean)
 'Prevent recursion with this variable
 Static InProc As Boolean
 Dim ps As PAINTSTRUCT
 Dim TVDC As Long, drawDC1 As Long, drawDC2 As Long
 Dim oldBMP1 As Long, drawBMP1 As Long
 Dim oldBMP2 As Long, drawBMP2 As Long
 Dim x As Long, y As Long, w As Long, h As Long
 Dim TVWidth As Long, TVHeight As Long

 If wMsg = WM_PAINT Then
  If InProc = True Then
   Exit Sub
  End If
  InProc = True
  'Prepare some variables we'll use
  TVWidth = frmTree.width \ Screen.TwipsPerPixelX
  TVHeight = frmTree.Height \ Screen.TwipsPerPixelY

  w = ScaleX(Img.Picture.width, vbHimetric, vbPixels)
  h = ScaleY(Img.Picture.Height, vbHimetric, vbPixels)

  'Begin painting. This API must be called in
  'response to the WM_PAINT message or you'll see
  'some odd visual effects :-)
  Call BeginPaint(hWnd, ps)
  TVDC = ps.hDC

  'Create a few canvases in memory to
  'draw on
  drawDC1 = CreateCompatibleDC(TVDC)
  drawBMP1 = CreateCompatibleBitmap(TVDC, TVWidth, TVHeight)
  oldBMP1 = SelectObject(drawDC1, drawBMP1)

  drawDC2 = CreateCompatibleDC(TVDC)
  drawBMP2 = CreateCompatibleBitmap(TVDC, TVWidth, TVHeight)
  oldBMP2 = SelectObject(drawDC2, drawBMP2)

  'This actually causes the TreeView to paint
  'itself onto our memory DC!
  SendMessage hWnd, WM_PAINT, drawDC1, ByVal 0&
  'Tile the bitmap and draw the TreeView
  'over it transparently
  For y = 0 To TVHeight Step h
   For x = 0 To TVWidth Step w
    PaintNormalStdPic drawDC2, x, y, w, h, Img.Picture, 0, 0
    Next
   Next
   PaintTransparentDC drawDC2, 0, 0, TVWidth, TVHeight, drawDC1, 0, 0, TranslateColor(vbWindowBackground)
   'Draw to the target DC
   BitBlt TVDC, 0, 0, TVWidth, TVHeight, drawDC2, 0, 0, vbSrcCopy

   'Cleanup
   SelectObject drawDC1, oldBMP1
   SelectObject drawDC2, oldBMP2
   DeleteObject drawBMP1
   DeleteObject drawBMP2

   EndPaint hWnd, ps

   RetVal = 0
   UseRetVal = True
   InProc = False

  ElseIf wMsg = WM_ERASEBKGND Then
   'Return TRUE
   RetVal = 1
   UseRetVal = True

  ElseIf wMsg = WM_HSCROLL Or wMsg = WM_VSCROLL Or wMsg = WM_MOUSEWHEEL Then
   'Force a repaint to keep the bitmap
   'tiles lined up
   InvalidateRect hWnd, 0, 0
 End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
 Dim frmCloseID As Long
 If ItemSelSign = False Then
  Set SysPara.RetChoice = Nothing
  frmCloseID = MsgBox("关闭选择框？", vbQuestion + vbYesNo + vbDefaultButton2, BaseDllLib.getSysInfo)
  If frmCloseID <> 6 Then
   Cancel = 1
   Exit Sub
  End If
 End If
 '//UnSubclass frmTree
 Dim iLoop As Long
 Dim frmRptWidthStr As String
 For iLoop = SysPara.cMin To SysPara.cMax
  frmRptWidthStr = frmRptWidthStr & frmRpt.Col(iLoop + 1).width & "|"
 Next
 frmRptWidthStr = Left(frmRptWidthStr, Len(frmRptWidthStr) - 1)
 Call UpdateListWidth(frmRptWidthStr, BaseDllLib.getClassID)
End Sub

Private Sub frmBar_Execute(ByVal Control As XtremeCommandBars.ICommandBarControl)
 Dim frmObj As Object
 Select Case Control.Id
  Case 1 '//选择
   '//Me.Caption = ThisCls.getQueryStr
'   ItemSelSign = True
'   Call SetRetValue
'   Unload Me
   If SysPara.MulChoice = False Then
    Call frmRpt_DblClick
   Else
    ItemSelSign = True
    Call SetRetMulRowValue
    Unload Me
   End If
  Case 2 '//关闭
   ItemSelSign = False
   Unload Me
  Case 8 '//搜索
   Set frmObj = CreateObject("SearchDiag.BaseLib")
   frmObj.setUserID = BaseDllLib.getUserID
   frmObj.setClassID = BaseDllLib.getClassID
   frmObj.setFormID = BaseDllLib.getFormID
   Call frmObj.mShow(ErrInfo, 1)
   SysPara.QueryStr = frmObj.getQueryStr
   Set frmObj = Nothing
   If Trim(SysPara.QueryStr) <> "" Then ThisCls.setQueryStr = SysPara.QueryStr Else ThisCls.setQueryStr = ""
   Call RefreshLdg
 End Select
End Sub

Private Sub frmRpt_Click()
 SysPara.ChoiceID = frmRpt.Sel.Row
End Sub

Private Sub frmRpt_DblClick()
   ItemSelSign = True
   Call SetRetValue
   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)
 Dim iLoop As Integer
 If lRow = 1 Then
  strRowData = SysPara.Title
  Exit Sub
 End If
 DaRs.AbsolutePosition = lRow - frmRpt.Face.FixedRows
 For iLoop = SysPara.cMin To SysPara.cMax
  strRowData = strRowData & DaRs(iLoop) & "|"
 Next
End Sub

Private Sub frmTree_NodeClick(ByVal Node As MSComctlLib.Node)
 On Error GoTo ErrHandle
 Dim iLoop As Long
 Dim NodeX As Node
 'ThisCls.setParentStr = TreeData.Item(Node.Index).ParentIDStr
 '//Me.Caption = TreeID.Item(Node.Index)
 Dim ItemCls As Object
 Set ItemCls = CreateObject("BaseDllLib.ItemText")
 ItemCls.FItemID = CLng(TreeID.Item(Node.Index))
 SysPara.TreeID = ItemCls.FItemID
 Call ItemCls.getItemText(ResSign, ErrInfo)
 ThisCls.setParentStr = ItemCls.FParentIDStr & ItemCls.FItemID & "|"
 Set ItemCls = Nothing
 '//Me.Caption = ThisCls.getParentStr
 Call RefreshLdg
 If Node.Children > 0 Then Exit Sub
 SysPara.ParentID = TreeID.Item(Node.Index)
 Call getTreeData(SysPara.ParentID)
  If TreeData.Count > 0 Then
   For iLoop = 1 To TreeData.Count
    Set NodeX = frmTree.Nodes.Add("K" & SysPara.ParentID, tvwChild, "K" & TreeData.Item(iLoop).FItemID, TreeData.Item(iLoop).FName, 1, 2)
    NodeX.BackColor = RGB(&HC0, &HDB, &HFF)
    NodeX.ForeColor = RGB(&HFF, &O33, &H0)
    TreeID.Add TreeData.Item(iLoop).FItemID
   Next
  End If
  Exit Sub
ErrHandle:
  MsgBox "数据展开错误：" & Chr(13) & "    错误编号：" & Err.Number & Chr(13) & "    错误信息：" & Err.Description, vbCritical + vbOKOnly, BaseDllLib.getSysInfo
End Sub

'//计算返回集合（单行）
Private Sub SetRetValue()
 '//
 If SysPara.ChoiceID = 0 Then
  MsgBox "请选择：" & SysPara.frmTitle, vbCritical + vbOKOnly, BaseDllLib.getSysInfo
  Exit Sub
 End If
 Dim iLoop As Long
 Dim RetObj As ChoiceItem.RetCls
 '//清空原来的返回值
 If SysPara.RetChoice.Count > 0 Then
  For iLoop = SysPara.RetChoice.Count To 1 Step -1
   SysPara.RetChoice.Remove iLoop
  Next
 End If
 '//填充返回值
 For iLoop = SysPara.cMin To SysPara.cMax
  Set RetObj = New ChoiceItem.RetCls
  With RetObj
   .FValue = frmRpt.Cell(SysPara.ChoiceID, iLoop + 1).Value
   .FTypeID = SysPara.MapType(iLoop)
   .MapCol = SysPara.MapCol(iLoop)
  End With
  SysPara.RetChoice.Add RetObj
  Set RetObj = Nothing
 Next
End Sub


'//计算返回集合（多行）
Private Sub SetRetMulRowValue()
 Dim RetRows() As Long
 Dim RetMin As Long
 Dim RetMax As Long
 Dim iLoop As Long
 Dim jLoop As Long
 Dim kLoop As Long
 Dim RetObj As ChoiceItem.RetCls
 Dim EntryColl As New Collection
 If SysPara.ChoiceID = 0 Then
  MsgBox "请选择：" & SysPara.frmTitle, vbCritical + vbOKOnly, BaseDllLib.getSysInfo
  Exit Sub
 End If
 RetRows = frmRpt.Sel.Rows
 RetMin = LBound(RetRows)
 RetMax = UBound(RetRows)
 If SysPara.RetMulChoice.Count > 0 Then
  For iLoop = SysPara.RetMulChoice.Count To 1 Step -1
   SysPara.RetMulChoice.Remove iLoop
  Next
 End If
 For iLoop = RetMin To RetMax
  If EntryColl.Count > 0 Then
   For kLoop = EntryColl.Count To 1 Step -1
    EntryColl.Remove kLoop
   Next
  End If
  For jLoop = SysPara.cMin To SysPara.cMax
   Set RetObj = New ChoiceItem.RetCls
   With RetObj
   .FValue = frmRpt.Cell(RetRows(iLoop), jLoop + 1).Value
   .FTypeID = SysPara.MapType(jLoop)
   .MapCol = SysPara.MapCol(jLoop)
   End With
   EntryColl.Add RetObj
  Next
  SysPara.RetMulChoice.Add EntryColl
  Set EntryColl = Nothing
 Next
 Set RetObj = Nothing
End Sub