?? frmtjrstj.frm
字號:
'檢查日期是否錯誤
If dtpEnd.Value < dtpStart.Value Then
MsgBox "起始日期不能大于終止日期，請重新設置！", vbInformation, "提示"
GoTo ExitLab
Else
'記錄起止日期
dtmStart = dtpStart.Value
dtmEnd = DateValue(dtpEnd.Value & " 23:59")
mdtmStart = dtmStart
mdtmEnd = dtmEnd
End If
'清除之前的查詢結果
lvwRS.ListItems.Clear
cmdPrint.Enabled = False '禁用打印
'查詢方式
If optTTi.Value Then
'******************************************************************************
' 按團體方式查詢
'******************************************************************************
'清除樹型結構
tvwDWei.Nodes.Clear
'首先檢索滿足條件的團體
strSQL = "select YY_TJDJ.YYID,DWMC,Count(GUID) as Number from YY_TJDJ,SET_DW,FZ_FZSJ" _
& " where YY_TJDJ.DWID=SET_DW.DWID" _
& " and YY_TJDJ.TJRQ between '" & dtmStart & "' and '" & dtmEnd & "'" _
& " and YY_TJDJ.YYID=FZ_FZSJ.YYID" _
& " group by YY_TJDJ.YYID,DWMC"
Set rstemp = New ADODB.Recordset
rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
If rstemp.RecordCount <= 0 Then
blnHave = False
Else
blnHave = True
'首先添加根節點
Set nodTemp = tvwDWei.Nodes.Add(, , "T", "團檢") '團檢根節點
nodTemp.Expanded = True
'添加團體
rstemp.MoveFirst
Do
tvwDWei.Nodes.Add "T", tvwChild, "W" & rstemp("YYID"), rstemp("DWMC") & "(" & rstemp("Number") & "人)"
'檢索該團體下的分組
strSQL = "select FZ_FZSY.FZID,FZMC,Count(GUID) as Number from FZ_FZSY,FZ_FZSJ" _
& " where FZ_FZSY.YYID='" & rstemp("YYID") & "'" _
& " and FZ_FZSY.YYID=FZ_FZSJ.YYID" _
& " and FZ_FZSY.FZID=FZ_FZSJ.FZID" _
& " group by FZ_FZSY.FZID,FZMC"
Set rsFZ = New ADODB.Recordset
rsFZ.Open strSQL, GCon, adOpenStatic, adLockOptimistic
If rsFZ.RecordCount > 0 Then
rsFZ.MoveFirst
Do
'添加分組
tvwDWei.Nodes.Add "W" & rstemp("YYID"), tvwChild, _
"W" & rstemp("YYID") & rsFZ("FZID"), rsFZ("FZMC") & "(" & rsFZ("Number") & "人)"
rsFZ.MoveNext
Loop Until rsFZ.EOF
rsFZ.Close
End If
rstemp.MoveNext
Loop Until rstemp.EOF
rstemp.Close
End If
'檢索滿足條件的散檢人員
strSQL = "select Count(*) from SET_GRXX" _
& " where ((YYID is null) or YYID='')" _
& " and TJRQ between '" & dtmStart & "' and '" & dtmEnd & "'"
Set rstemp = New ADODB.Recordset
rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
If rstemp(0) = 0 Then
If blnHave = False Then
If m_blnShowInfo Then
MsgBox "沒有找到匹配記錄，請重新設置查詢條件！", vbInformation, "提示"
End If
GoTo ExitLab
End If
Else
'添加根節點
Set nodTemp = tvwDWei.Nodes.Add(, , "S", "散檢") '散檢根節點
nodTemp.Text = nodTemp.Text & "(" & rstemp(0) & "人)"
End If
Set tvwDWei.SelectedItem = tvwDWei.Nodes(1)
Call tvwDWei_NodeClick(tvwDWei.SelectedItem) '這里會顯示合計
cmdPrint.Enabled = True '啟用打印
Else
'******************************************************************************
' 按項目方式查詢
'******************************************************************************
'是否選擇了節點
If tvwXMu.SelectedItem Is Nothing Then
MsgBox "請選擇要統計的項目！", vbInformation, "提示"
GoTo ExitLab
End If
'記錄項目編號
strXMID = Mid(tvwXMu.SelectedItem.Key, 2)
If Len(strXMID) < 4 Then
MsgBox "請選擇要統計的具體項目！", vbInformation, "提示"
GoTo ExitLab
End If
'記錄當前項目的名稱
lvwRS.Tag = tvwXMu.SelectedItem.Text '防止用戶在查詢完畢后切換到其它節點
'***************************************************
'獲取登記過該項目的團體
'***************************************************
strSQL = "select YY_TJDJ.YYID,DWMC,Count(YY_SJDJDX.GUID) as Number" _
& " from SET_GRXX,YY_TJDJ,SET_DW,YY_SJDJDX" _
& " where SET_GRXX.YYID=YY_TJDJ.YYID" _
& " and YY_TJDJ.TJRQ between '" & dtmStart & "' and '" & dtmEnd & "'" _
& " and YY_TJDJ.DWID=SET_DW.DWID" _
& " and SET_GRXX.GUID=YY_SJDJDX.GUID" _
& " and YY_SJDJDX.DXID='" & strXMID & "'" _
& " group by YY_TJDJ.YYID,DWMC"
Set rstemp = New ADODB.Recordset
rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
If rstemp.RecordCount > 0 Then
rstemp.MoveFirst
Do
'循環處理每個團體
'單位名稱
strDWMC = rstemp("DWMC")
'獲得該團體的總人數
intTTZRS = rstemp("Number")
'向lvwRS中添加
If intTTZRS > 0 Then
Set itemX = lvwRS.ListItems.Add(, , strDWMC) '"W" & rsTemp("YYID")
Call ShowPersonRatio(itemX, rstemp("YYID"), , _
"exists(select YY_SJDJDX.GUID from YY_SJDJDX" _
& " where YY_SJDJDX.GUID=SET_GRXX.GUID" _
& " and YY_SJDJDX.DXID='" & strXMID & "')")
End If
rstemp.MoveNext
Loop Until rstemp.EOF
rstemp.Close
cmdPrint.Enabled = True
End If
'***************************************************
'獲取登記過該項目的個人
'***************************************************
'獲得散檢總人數
Set rstemp = New ADODB.Recordset
strSQL = "select count(*) as 散檢總人數 from SET_GRXX,YY_SJDJDX" _
& " where ((YYID IS Null) or (YYID=''))" _
& " and TJRQ between '" & dtmStart & "' and '" & dtmEnd & "'" _
& " and SET_GRXX.GUID=YY_SJDJDX.GUID" _
& " and YY_SJDJDX.DXID='" & strXMID & "'"
rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
intSJZRS = rstemp("散檢總人數")
rstemp.Close
'檢查是否有散檢人員選擇了該項目
If intSJZRS > 0 Then
cmdPrint.Enabled = True
Set itemX = lvwRS.ListItems.Add(, , "散檢")
Call ShowPersonRatio(itemX, "", , _
"exists(select YY_SJDJDX.GUID from YY_SJDJDX" _
& " where YY_SJDJDX.GUID=SET_GRXX.GUID" _
& " and YY_SJDJDX.DXID='" & strXMID & "')" _
& " and ((YYID IS Null) or (YYID=''))" _
& " and TJRQ between '" & dtmStart & "' and '" & dtmEnd & "'")
End If
Call ShowSumRatio
End If
GoTo ExitLab
ErrMsg:
Status = SetError(Err.Number, Err.Description, Err.Source)
ErrMsg Status
ExitLab:
Me.MousePointer = vbDefault
End Sub
Private Sub dtpEnd_Change()
mblQuery = False
End Sub
Private Sub dtpStart_Change()
mblQuery = False
End Sub
Private Sub Form_Load()
On Error GoTo ErrMsg
Dim Status
Dim strSQL As String
Dim rsKS As ADODB.Recordset
Dim rsZH As ADODB.Recordset
Dim nodTemp As Node
Dim blnSel As Boolean
Screen.MousePointer = vbArrowHourglass
m_blnShowInfo = False '窗體加載時不顯示提示
blnSel = False
'顯示所有項目組合
'首先顯示根節點
Set nodTemp = tvwXMu.Nodes.Add(, , "W", "所有項目組合")
nodTemp.Expanded = True
'添加仔節點
strSQL = "select KSID,KSMC from SET_KSSZ"
Set rsKS = New ADODB.Recordset
rsKS.Open strSQL, GCon, adOpenStatic, adLockOptimistic
If rsKS.RecordCount > 0 Then
rsKS.MoveFirst
Do
'添加科室
tvwXMu.Nodes.Add "W", tvwChild, "W" & rsKS("KSID"), rsKS("KSMC")
strSQL = "select DXID,DXMC from SET_DX" _
& " where KSID='" & rsKS("KSID") & "'" _
& " order by SXH"
Set rsZH = New ADODB.Recordset
rsZH.Open strSQL, GCon, adOpenStatic, adLockOptimistic
If rsZH.RecordCount > 0 Then
rsZH.MoveFirst
Do
Set nodTemp = tvwXMu.Nodes.Add("W" & rsKS("KSID"), tvwChild, _
"W" & rsZH("DXID"), rsZH("DXMC"))
If Not blnSel Then
blnSel = True
Set tvwXMu.SelectedItem = nodTemp
End If
rsZH.MoveNext
Loop Until rsZH.EOF
End If
rsKS.MoveNext
Loop Until rsKS.EOF
rsKS.Close
End If
'初始化變量或控件
mblQuery = False
lblSJRY.Caption = ""
dtpEnd.Value = Date '終止日期設為當前日期
dtpStart.Value = DateAdd("m", -2, Date) '起始日期設為一周前
' optTTi_Click
'加載完畢后可以顯示提示
m_blnShowInfo = True
GoTo ExitLab
ErrMsg:
Status = SetError(Err.Number, Err.Description, Err.Source)
ErrMsg Status
ExitLab:
Screen.MousePointer = vbDefault
End Sub
Private Sub optTTi_Click()
tvwDWei.ZOrder 0
' cmdQuery_Click
End Sub
Private Sub optXMu_Click()
tvwXMu.ZOrder 0
cmdQuery_Click
End Sub
Private Sub tvwDWei_NodeClick(ByVal Node As MSComctlLib.Node)
Dim Status
Dim strYYID As String
Dim intFZID As Integer
Dim strFZMC As String
Me.MousePointer = vbHourglass
'是否有選擇
If tvwDWei.SelectedItem Is Nothing Then GoTo ExitLab
strYYID = Mid(tvwDWei.SelectedItem.Key, 2)
lvwRS.ListItems.Clear
Select Case Len(strYYID)
Case 0 '選擇了根節點
If tvwDWei.SelectedItem.Key = "T" Then
'************************************************************
'選擇了團檢根節點
'************************************************************
Call ShowTJStatistic(True, "", -1, "", mdtmStart, mdtmEnd)
Else
'************************************************************
'選擇了散檢根節點
'************************************************************
Call ShowTJStatistic(False, "", -1, "", mdtmStart, mdtmEnd)
End If
Case 11 '選擇了團體
Call ShowTJStatistic(True, Left(strYYID, 11), -1, "", mdtmStart, mdtmEnd)
Case Else '選擇了分組
?? 快捷鍵說明
復制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -