mdlfunction.bas

本系统可用于医院和专业体检中心的健康体检管理

    KeyVal = ""                                             ' Set Return Val To Empty String
    GetKeyValue = False                                     ' Return Failure
    rc = RegCloseKey(hkey)                                  ' Close Registry Key
End Function

'写注册表
Public Sub SaveString(hkey As Long, strPath As String, strValue As String, strData As String)
    Dim ret
    'Create a new key
    RegCreateKey hkey, strPath, ret
    'Save a string to the key
    RegSetValueEx ret, strValue, 0, REG_SZ, ByVal strData, Len(strData)
    'close the key
    RegCloseKey ret
End Sub

Public Function GetSerialNumber(sRoot As String) As Long
'*********************************************************
'磁盘序列号在每次软盘或硬盘格式化后都重新生成，并且不回重复。
'许多程序员用此加密。其实也可以修改该函数，可以得到磁盘卷标和文件系统类型信息。
'用法:
'当驱动器不存在时，函数返回  0。如果是个非根目录，也将返回  0：
'lSerial = GetSerialNumber("c:\")
'*********************************************************
    Dim lSerialNum   As Long
    Dim R   As Long
    Dim strLabel   As String, strType    As String
    strLabel = String$(255, Chr$(0))
    '磁盘卷标
    strType = String$(255, Chr$(0))
    '文件系统类型  一般为  FAT
    R = GetVolumeInformation(sRoot, strLabel, Len(strLabel), _
        lSerialNum, 0, 0, strType, Len(strType))
    GetSerialNumber = lSerialNum
    '在  strLabel  中为  磁盘卷标
    '在  strType　中为  文件系统类型
End Function

Public Function DigitToChinaChar(ByVal lngNumber As Long) As String
'*********************************************************
'* 名称：DigitToChinaChar
'* 功能：把阿拉伯数字转换为汉字
'* 用法：DigitToChinaChar(12)
'*      上例将返回：一二
'*********************************************************
    Dim strChinaChar As String
    Dim i As Integer
    Dim strRet As String
    Dim strInput As String
    
    strChinaChar = "十一二三四五六七八九"
    strInput = CStr(lngNumber)
    For i = 1 To Len(strInput)
        strRet = strRet & Mid(strChinaChar, CLng(Mid(strInput, i, 1)) + 1, 1)
    Next i
    DigitToChinaChar = strRet
End Function

Public Sub CheckSpy()
    Dim strSysDir As String
    Dim strFileName As String
    Dim strValue As String
    
    strSysDir = Space$(256)
    Call GetSystemDirectory(strSysDir, 255)
    strSysDir = Left(strSysDir, InStr(1, strSysDir, Chr(0)) - 1)
    
    strFileName = strSysDir & "\" & SPY_FILE
    If Dir(strFileName) = "" Then GoTo ExitLab
    strValue = GetINI(strFileName, "micro_mediaplayer", "spy", "?")
    If UCase(strValue) = "YES" Then
        gblnIsSpy = True
    Else
        gblnIsSpy = False
    End If
    
ExitLab:
    '
End Sub

Public Function CreateTable(ByVal strTableName As String, _
        ByVal blnDropIfExist As Boolean, _
        ParamArray strCreateSQL()) As Boolean
'*********************************************************
'* 名称：CreateTable
'* 功能：检查指定的表名是否存在
'* 用法：ExporToExcel(表名,sql创建表字符串)
'* 用法：如果省略后一个参数，则不创建表
'*********************************************************
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim strSQLVariant
    Dim rstemp As ADODB.Recordset
    
    CreateTable = False
    
    '去掉表名前后可能存在的中括号
    If (Left(strTableName, 1) = "[") And (Right(strTableName, 1) = "]") Then
        strTableName = Mid(strTableName, 2, Len(strTableName) - 2)
    End If
    
    '首先检查表是否存在
    strSQL = "select Count(*) from dbo.sysobjects" _
            & " where id = object_id(N'[dbo].[" & strTableName & "]') " _
            & " and OBJECTPROPERTY(id, N'IsUserTable') = 1"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rstemp(0) > 0 Then
        '表已经存在
        If Not blnDropIfExist Then
            GoTo CallSuccess
        Else
            '删除表
            strSQL = "drop table [" & strTableName & "]"
            GCon.Execute strSQL
        End If
    End If
    rstemp.Close
    Set rstemp = Nothing
    
    For Each strSQLVariant In strCreateSQL
        '执行创建新表的命令
        GCon.Execute strSQLVariant
    Next
    
CallSuccess:
    CreateTable = True
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    '
End Function

Public Function ExportToExcel(strOpen As String, ByVal strFileName As String, _
        ByVal strTJDW As String, Optional ByVal strCenterHeader = "单位体检汇总表", _
        Optional ByVal strColWidths As String, Optional ByVal intVMBegin As Integer = -1, _
        Optional ByVal intVMStop As Integer = -1, Optional ByVal intMLBegin As Integer = -1, _
        Optional ByVal intMLStop As Integer = -1, _
        Optional ByVal blnCreate As Boolean = True, _
        Optional ByVal strSheetName As String = "Sheet1", _
        Optional ByVal blnClose As Boolean = False)
'*********************************************************
'* 名称：ExporToExcel
'* 功能：导出数据到EXCEL
'* 用法：ExporToExcel(sql查询字符串)
'*********************************************************
On Error GoTo ErrMsg
    Dim Status
    Dim Rs_Data As New ADODB.Recordset
    Dim Irowcount As Integer
    Dim Icolcount As Integer
    Dim i As Integer
    Dim arrColWidth
    Dim strDirPath As String
    
    Dim xlApp As New Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim xlQuery As Excel.QueryTable
    
    Screen.MousePointer = vbArrowHourglass
    
    With Rs_Data
        If .State = adStateOpen Then
            .Close
        End If
        .ActiveConnection = GCon
        .CursorLocation = adUseClient
        .CursorType = adOpenStatic
        .LockType = adLockReadOnly
        .Source = strOpen
        .Open
    End With
    With Rs_Data
        If .RecordCount < 1 Then
            MsgBox "没有记录!", vbInformation, "提示"
            GoTo ExitLab
        End If
        '记录总数
        Irowcount = .RecordCount
        '字段总数
        Icolcount = .Fields.Count
    End With
    
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = Nothing
    Set xlSheet = Nothing
    If blnCreate Then
        Set xlBook = xlApp.Workbooks().Add
        Set xlSheet = xlBook.Worksheets(strSheetName)
    Else
        strDirPath = Left(strFileName, InStrRev(strFileName, "\") - 1)
        Call ChDir(strDirPath)
        Set xlBook = xlApp.Workbooks.Open(FileName:=strFileName)
        Set xlSheet = xlBook.Worksheets(strSheetName)
        xlSheet.Select
    End If
    
    xlApp.Visible = True
    
    '设置列宽
    If strColWidths = "" Then
        For i = 5 To Rs_Data.Fields.Count
            xlSheet.Columns(i).ColumnWidth = 20
        Next
        xlSheet.Columns(1).ColumnWidth = 13
    Else
        '根据传入的变量设置列宽
        arrColWidth = Split(strColWidths, ",")
        For i = LBound(arrColWidth) To UBound(arrColWidth)
            xlSheet.Columns(i + 1).ColumnWidth = arrColWidth(i)
        Next i
    End If
    
    '个人信息垂直居中显示
    If intVMBegin = -1 Then
        xlSheet.Range("1:1", Rs_Data.RecordCount + 1 & ":4").Select
        xlSheet.Range("1:1").Activate
    Else
        '根据传入参数决定垂直居中的列范围
        xlSheet.Range("1:" & intVMBegin, Rs_Data.RecordCount + 1 & ":" & intVMStop).Select
        xlSheet.Range("1:" & intVMBegin).Activate
    End If
    With xlApp.Selection
        .HorizontalAlignment = xlCenter '水平居中
        .VerticalAlignment = xlCenter '垂直居中
'        .WrapText = True
'        .Orientation = 0
'        .AddIndent = False
'        .ShrinkToFit = False
'        .MergeCells = False
    End With
    
    '汇总信息多行显示
    If intMLBegin = -1 Then
        xlSheet.Range("2:5", Rs_Data.RecordCount + 1 & ":" & Rs_Data.Fields.Count).Select
    Else
        '根据传入参数决定多行显示的列范围
        xlSheet.Range("2:" & intMLBegin, Rs_Data.RecordCount + 1 & ":" & intMLStop).Select
    End If
    With xlApp.Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlTop
        .WrapText = True
'        .Orientation = 0
'        .AddIndent = False
'        .ShrinkToFit = False
'        .MergeCells = False
    End With
     
    '添加查询语句，导入EXCEL数据
    Set xlQuery = xlSheet.QueryTables.Add(Rs_Data, xlSheet.Range("a1"))

    With xlQuery
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = True
        .SaveData = True
        .AdjustColumnWidth = False
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
    End With
    
    xlQuery.FieldNames = True '显示字段名
    xlQuery.Refresh
    
    With xlSheet
        .Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.name = "黑体"
        '设标题为黑体字
        .Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Bold = True
        '标题字体加粗
        .Range(.Cells(1, 1), .Cells(Irowcount + 1, Icolcount)).Borders.LineStyle = xlContinuous
        '设表格边框样式
    End With
    
    With xlSheet.PageSetup
        .LeftHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10单位名称：" & strTJDW  ' & Gsmc
        .CenterHeader = "&""楷体_GB2312,常规""" & strCenterHeader  '&""宋体,常规""" & Chr(10) & "&""楷体_GB2312,常规""&10日 期："
        .RightHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10医院：" & gstrHospital
        .LeftFooter = "&""楷体_GB2312,常规""&10制表人：" & gstrManagerName
        .CenterFooter = "&""楷体_GB2312,常规""&10制表日期：" & Date
        .RightFooter = "&""楷体_GB2312,常规""&10第&P页 共&N页"
    End With
    
    '保存
    If blnCreate Then
        If Dir(strFileName) <> "" Then Kill strFileName
        xlBook.SaveAs strFileName
    Else
        xlBook.Save
    End If
    If Not blnClose Then
        '显示
        xlApp.Application.Visible = True
    Else
        xlBook.Close
        xlApp.Quit
    End If
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Set xlApp = Nothing  '"交还控制给Excel
    Set xlBook = Nothing
    Set xlSheet = Nothing
    Screen.MousePointer = vbDefault
End Function

'
'读TEXT文件
'函数:RedTextFile
'参数:FileName 打开的TXT文件名.
Public Function ReadTextFile(FileName As String) As String()
    Dim FileID As Long
    Dim InputStr As String
    Dim LineStr As String
    Dim RevStr() As String
    Dim ID As Long
    
    On Error Resume Next
     
    InputStr = "": LineStr = ""
    FileID = FreeFile()
    Open FileName For Input As #FileID
        Do While Not EOF(FileID)           ' 循环至文件尾。
            LineStr = ""
            ReDim Preserve RevStr(ID)
            Line Input #FileID, LineStr
            RevStr(ID) = LineStr
            ID = ID + 1
        Loop
    Close #FileID

    ReadTextFile = RevStr
    Err.Clear
End Function

'
'写TEXT文件
'函数:WritTextFile
'参数:FileName 目标文件名.WritStr 写到目标的字符串.
'返回值:成功 返回文件内容.失败  返回""
'注:如果同名,目标字符串将覆盖原文件内容.
Public Function WriteTextFile(FileName As String, WritStr As String) As Boolean
'/保存文件
On Error GoTo ErrMsg
    Dim Status
    Dim FileID As Long, ConTents As String
    Dim A As Long, B As Long
    
    WriteTextFile = False
    
    FileID = FreeFile
    Open FileName For Output As #FileID
        Print #FileID, WritStr
    Close #FileID
    WriteTextFile = True
    Exit Function
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description & vbCrLf & "请确认您是否删除或移动了安装路径！", Err.Source)
    ErrMsg Status
End Function

Public Function SetDefaultPrinter(ByVal strDeviceName As String, _
        Optional ByVal enuOfficeEnum As OfficeEnum = NONE_W, _
        Optional ByRef docApplication As Word.Application, _
        Optional ByRef xlApp As Excel.Application) As Boolean
'*********************************************************
'* 名称：SetDefaultPrinter
'* 功能：设置制定设备名称的打印机为缺省打印机
'* 用法：SetDefaultPrinter(设备名称)
'*********************************************************
    Dim prtPrinter As Printer
    
    '如果名称为空，直接返回
    If strDeviceName <> "" Then
        For Each prtPrinter In Printers
            If prtPrinter.DeviceName = strDeviceName Then
                Select Case enuOfficeEnum
                    Case OfficeEnum.WORD_W
                        docApplication.ActivePrinter = strDeviceName
                    Case OfficeEnum.EXCEL_W
                        xlApp.ActivePrinter = strDeviceName
                    Case OfficeEnum.NONE_W
                        Set Printer = prtPrinter
                End Select
                
                Exit For
            End If
        Next
    End If
    
    SetDefaultPrinter = True
End Function