frmmain.frm

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

 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
  frmCloseID = MsgBox("关闭选择框？", vbQuestion + vbYesNo + vbDefaultButton2, BaseDllLib.getSysInfo)
  If frmCloseID <> 6 Then
   Cancel = 1
   Exit Sub
  End If
 End If
 Dim iLoop As Long
 Dim frmRptWidthStr As String
 For iLoop = SysPara.frmInfo.FInfoTitleMin To SysPara.frmInfo.FInfoTitleMax
  frmRptWidthStr = frmRptWidthStr & frmRpt.col(iLoop + 1).width & "|"
 Next
 frmRptWidthStr = Left(frmRptWidthStr, Len(frmRptWidthStr) - 1)
 '//Call UpdateListWidth(frmRptWidthStr, BaseDllLib.getClassID)
 Set BaseDllLib = Nothing
 Set QueryInfo = Nothing
End Sub

Private Sub frmBar_Execute(ByVal Control As XtremeCommandBars.ICommandBarControl)
 Dim frmObj As Object
 Select Case Control.Id
  Case 1 '//选择
   If SysPara.ChooseMulSign = False Then
    Call frmRpt_DblClick
   Else
    ItemSelSign = True
    Call SetRetMulRowValue
    Unload Me
   End If
  Case 2 '//关闭
   ItemSelSign = False
   Unload Me
  Case 8 '//搜索
   FiltrateFrm.Show vbModal
'   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.frmInfo.FInfoTitleStr & "|"
  Exit Sub
 End If
 DaRs.AbsolutePosition = lRow - frmRpt.Face.FixedRows
 For iLoop = SysPara.frmInfo.FInfoTitleMin To SysPara.frmInfo.FInfoTitleMax
  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
 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
 QueryInfo.Item(3).FLastRlValue = 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 "请选择：" & BaseClass.FName, vbCritical + vbOKOnly, BaseDllLib.getSysInfo
  Exit Sub
 End If
 Dim iLoop As Long
 Dim RetObj As ChoiceInfo.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.frmInfo.FInfoTitleMin + 1 To SysPara.frmInfo.FInfoTitleMax + 1
  Set RetObj = New ChoiceInfo.RetCls
  With RetObj
   .FValue = frmRpt.Cell(SysPara.ChoiceID, iLoop).Value
   .FTypeID = SysPara.frmInfo.FInfoTypeVar(iLoop - 1)
   .MapCol = SysPara.frmInfo.FInfoColsVar(iLoop - 1)
  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 ChoiceInfo.RetCls
 Dim EntryColl As New Collection
 If SysPara.ChoiceID = 0 Then
  MsgBox "请选择：" & BaseClass.FName, 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.frmInfo.FInfoTitleMin + 1 To SysPara.frmInfo.FInfoTitleMax + 1
   Set RetObj = New ChoiceInfo.RetCls
   With RetObj
   .FValue = frmRpt.Cell(RetRows(iLoop), jLoop).Value
   .FTypeID = SysPara.frmInfo.FInfoTypeVar(jLoop - 1)
   .MapCol = SysPara.frmInfo.FInfoColsVar(jLoop - 1)
   End With
   EntryColl.Add RetObj
  Next
  SysPara.RetMulChoice.Add EntryColl
  Set EntryColl = Nothing
 Next
 Set RetObj = Nothing
End Sub