📄 dlgtjhcdc.frm
字号:
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "Comdlg32.ocx"
Object = "{0B81E4A9-BE4E-4AEF-9272-33AB5B51C6FC}#1.0#0"; "XPControls.ocx"
Begin VB.Form dlgTJHCDC
BackColor = &H80000018&
BorderStyle = 1 'Fixed Single
Caption = "体检耗材设置导出"
ClientHeight = 5040
ClientLeft = 45
ClientTop = 330
ClientWidth = 7125
Icon = "dlgTJHCDC.frx":0000
LinkTopic = "Form1"
LockControls = -1 'True
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 5040
ScaleWidth = 7125
StartUpPosition = 3 '窗口缺省
Begin VB.Frame Frame1
BackColor = &H80000018&
Caption = "选择路径"
Height = 3945
Left = 120
TabIndex = 0
Top = 120
Width = 6855
Begin VB.FileListBox File1
Height = 3330
Left = 3000
TabIndex = 3
Top = 360
Width = 3615
End
Begin VB.DirListBox Dir1
Height = 3015
Left = 240
TabIndex = 2
Top = 750
Width = 2655
End
Begin VB.DriveListBox Drive1
Height = 315
Left = 240
TabIndex = 1
Top = 360
Width = 2655
End
End
Begin XPControls.XPCommandButton cmdCancel
Cancel = -1 'True
Height = 465
Left = 4320
TabIndex = 4
Top = 4380
Width = 1245
_ExtentX = 2196
_ExtentY = 820
Caption = "退 出(&X)"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin XPControls.XPCommandButton cmdBackup
Height = 465
Left = 1530
TabIndex = 5
Top = 4380
Width = 1245
_ExtentX = 2196
_ExtentY = 820
Caption = "导 出(&B)"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin MSComDlg.CommonDialog CommonDialog1
Left = 0
Top = 4140
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
End
Attribute VB_Name = "dlgTJHCDC"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Sub cmdBackup_Click()
On Error GoTo ErrMsg
Dim fsoOut As New Scripting.FileSystemObject
Dim TxtStream As Scripting.TextStream
Dim strOutFileName As String
Dim Status
Dim i, j, K As Integer
Dim strSQL As String
Dim strTempResult As String
Dim strPath As String
Dim strTemp As String
Dim rstemp As ADODB.Recordset
Dim rsKS As ADODB.Recordset
Dim rsXX As ADODB.Recordset
Dim rsDX As ADODB.Recordset
Dim rsXM As ADODB.Recordset
Dim rsHC As ADODB.Recordset
'获取备份到的含斜杠“\”的文件夹
strPath = Dir1.Path
If Right(strPath, 1) <> "\" Then
strPath = strPath & "\"
End If
strOutFileName = strPath & "BTTJ_体检耗材导出文件.txt"
If MsgBox("确实要导出体检耗材到文件“" & strOutFileName & "吗？", _
vbQuestion + vbYesNo + vbDefaultButton2, "询问") = vbNo Then
Exit Sub
End If
Me.MousePointer = vbHourglass
Set TxtStream = fsoOut.CreateTextFile(strOutFileName, True, True)
'执行导出操作
TxtStream.WriteLine Space(30) & "体检耗材导出结果"
TxtStream.WriteLine
Set rsKS = New ADODB.Recordset
rsKS.Open "select * from SET_KSSZ order by KSID", GCon, adOpenStatic, adLockReadOnly
If rsKS.RecordCount > 0 Then
rsKS.MoveFirst
Do While Not rsKS.EOF
TxtStream.WriteLine "********* " & rsKS("KSMC") & " 所用耗材" & "*********"
'得到当前科室所有耗材
strSQL = "select * FROM TJHC_HCXM where left(XMID,2)='" & rsKS("KSID") & "'"
Set rstemp = New ADODB.Recordset
rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
If rstemp.RecordCount > 0 Then
'打印当前工作耗材名称 '
rstemp.MoveFirst
i = 1
Do While Not rstemp.EOF
Set rsHC = New ADODB.Recordset
rsHC.Open "select * from TJHC_Index where HCID=" & rstemp("HCID"), GCon, adOpenStatic, adLockReadOnly
TxtStream.WriteLine i & "." & rsHC("HCMC")
strTemp = "" '记录当前耗材在当前科室中有什么项目用
i = i + 1
strSQL = "select * from TJHC_HCXM where HCID=" & rstemp("HCID") _
& " and left(XMID,2)='" & rsKS("KSID") & "'"
Set rsXM = New ADODB.Recordset
rsXM.Open strSQL, GCon, adOpenStatic, adLockReadOnly
If rsXM.RecordCount > 0 Then
rsXM.MoveFirst
Do While Not rsXM.EOF
Select Case Len(rsXM("XMID"))
Case 2
Case 4
strSQL = "select * from SET_DX where DXID='" & rsXM("XMID") & "'"
Set rsDX = New ADODB.Recordset
rsDX.Open strSQL, GCon, adOpenStatic, adLockReadOnly
strTemp = strTemp & rsDX("DXMC") & "，"
Case 7
strSQL = "select * from SET_XX where XXID='" & rsXM("XMID") & "'"
Set rsXX = New ADODB.Recordset
rsXX.Open strSQL, GCon, adOpenStatic, adLockReadOnly
strTemp = strTemp & rsXX("XXMC") & "，"
End Select
rsXM.MoveNext
Loop
If strTemp <> "" Then
strTemp = Mid(strTemp, 1, Len(strTemp) - 1) '去掉最后一个逗号
End If
strTemp = " " & strTemp
TxtStream.WriteLine strTemp
End If
rstemp.MoveNext
Loop
End If
TxtStream.WriteLine '科室间留2个空行
TxtStream.WriteLine
rsKS.MoveNext
Loop
End If
TxtStream.Close
Set TxtStream = Nothing
Set fsoOut = Nothing
MsgBox "已保存完毕", , "成功"
Me.MousePointer = vbDefault
Exit Sub
ErrMsg:
Status = SetError(Err.Number, Err.Description, Me.Caption & ".cmdBackup_Click")
ErrMsg Status
End Sub
Private Sub cmdCancel_Click()
Unload Me
End Sub
Private Sub Dir1_Change()
File1.Path = Dir1.Path
End Sub
Private Sub Dir1_Click()
Dir1.Path = Dir1.List(Dir1.ListIndex)
End Sub
Private Sub Dir1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
ShowStatus "选择路径"
End Sub
Private Sub Drive1_Change()
On Error Resume Next
Dir1.Path = Drive1.Drive
End Sub
Private Sub File1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
ShowStatus "选择文件"
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
ShowStatus "Ready"
End Sub
Private Sub Form_Unload(Cancel As Integer)
ShowStatus "Ready"
' Me.Hide
' Set frmRestoreAndBackup = Nothing
End Sub
Private Sub Frame1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
ShowStatus "选择路径"
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -