frmtjjydc.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 FrmTJJYDC 
   BackColor       =   &H80000018&
   BorderStyle     =   1  'Fixed Single
   Caption         =   "体检建议导出"
   ClientHeight    =   4785
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   6960
   Icon            =   "FrmTJJYDC.frx":0000
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   4785
   ScaleWidth      =   6960
   StartUpPosition =   2  'CenterScreen
   Begin VB.Frame Frame1 
      BackColor       =   &H80000018&
      Caption         =   "选择路径"
      Height          =   3945
      Left            =   60
      TabIndex        =   0
      Top             =   90
      Width           =   6855
      Begin VB.DriveListBox Drive1 
         BeginProperty Font 
            Name            =   "MS Sans Serif"
            Size            =   9.75
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   360
         Left            =   240
         TabIndex        =   3
         Top             =   360
         Width           =   2655
      End
      Begin VB.DirListBox Dir1 
         BeginProperty Font 
            Name            =   "MS Sans Serif"
            Size            =   9.75
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   2790
         Left            =   240
         TabIndex        =   2
         Top             =   1020
         Width           =   2655
      End
      Begin VB.FileListBox File1 
         BeginProperty Font 
            Name            =   "MS Sans Serif"
            Size            =   9.75
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   3450
         Left            =   3000
         TabIndex        =   1
         Top             =   360
         Width           =   3615
      End
   End
   Begin XPControls.XPCommandButton cmdCancel 
      Cancel          =   -1  'True
      Height          =   435
      Left            =   4200
      TabIndex        =   4
      Top             =   4230
      Width           =   1305
      _ExtentX        =   2302
      _ExtentY        =   767
      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          =   435
      Left            =   1410
      TabIndex        =   5
      Top             =   4230
      Width           =   1305
      _ExtentX        =   2302
      _ExtentY        =   767
      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            =   120
      Top             =   4050
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
End
Attribute VB_Name = "FrmTJJYDC"
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 strXMMC As String
    Dim strPath As String
    
    Dim rsJY As ADODB.Recordset
    Dim rsTemp As ADODB.Recordset
    Dim rsKS 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
    
    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") & " 体检建议导出结果 *********"
            Set rsTemp = New ADODB.Recordset
            rsTemp.Open "select * from DM_ZJJY where KSID='" & rsKS("KSID") & "'", GCon, adOpenStatic, adLockReadOnly
            If rsTemp.RecordCount > 0 Then
                rsTemp.MoveFirst
                Do While Not rsTemp.EOF
                    TxtStream.WriteLine rsTemp("DMValue") & "："
                    TxtStream.WriteLine rsTemp("JYNR") & ""
                    TxtStream.WriteLine
                    rsTemp.MoveNext
                Loop
            End If
            rsKS.MoveNext
            TxtStream.WriteLine
            TxtStream.WriteLine
        Loop
    End If
    

    TxtStream.Close
    Set TxtStream = Nothing
    Set fsoOut = Nothing
    MsgBox "已保存完毕", , "成功"
         
    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