mdlreg.bas

朋友给的

    
    'Note: Once "Set Printer = " is executed, anywhere in the code, after that point
    '      changes made with SetPrinter will ONLY affect the system-wide printer  --
    '      -- the changes will NOT affect the VB printer object.
    '      Therefore, it may be necessary to reset the printer object's parameters to
    '      those chosen in the devmode.
    Dim p As Printer
    For Each p In Printers
        If p.DeviceName = PrinterName Then
            Set Printer = p
            Exit For
        End If
    Next p
    'Printer.Duplex = MyDevMode.dmDuplex
End Sub
Public Function GetKeyValue(KeyRoot As Long, KeyName As String, SubKeyRef As String, Optional DefaultKeyVal As String) As String
'==============
'取注册表内键值
'==============
    Dim i As Long                                           ' 循环计数器
    Dim rc As Long                                          ' 返回代码
    Dim hKey As Long                                        ' 打开的注册表关键字句柄
    Dim hDepth As Long                                      '
    Dim KeyValType As Long                                  ' 注册表关键字数据类型
    Dim tmpVal As String                                    ' 注册表关键字值的临时存储器
    Dim KeyValSize As Long                                  ' 注册表关键自变量的尺寸
    Dim KeyVal As String
    '------------------------------------------------------------
    ' 打开 {HKEY_LOCAL_MACHINE...} 下的 RegKey
    '------------------------------------------------------------
    rc = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey) ' 打开注册表关键字
    
    If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError          ' 处理错误...
    
    tmpVal = String$(1024, 0)                             ' 分配变量空间
    KeyValSize = 1024                                       ' 标记变量尺寸
    
    '------------------------------------------------------------
    ' 检索注册表关键字的值...
    '------------------------------------------------------------
    rc = RegQueryValueEx(hKey, SubKeyRef, 0, _
                         KeyValType, tmpVal, KeyValSize)     ' 获得/创建关键字值
                        
    If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError          ' 处理错误
    
    If KeyValSize = 1 Then
        tmpVal = ""
    Else
        If (Asc(RealMid(tmpVal, KeyValSize, 1)) = 0) Then           ' Win95 外接程序空终结字符串...
            tmpVal = RealMid(tmpVal, 1, KeyValSize - 1)              ' Null 被找到,从字符串中分离出来
        Else                                                    ' WinNT 没有空终结字符串...
            tmpVal = RealMid(tmpVal, 1, KeyValSize)                  ' Null 没有被找到, 分离字符串
        End If
    End If
    '------------------------------------------------------------
    ' 决定转换的关键字的值类型...
    '------------------------------------------------------------
    Select Case KeyValType                                  ' 搜索数据类型...
    Case REG_SZ                                             ' 字符串注册关键字数据类型
        KeyVal = tmpVal                                     ' 复制字符串的值
    Case REG_DWORD                                          ' 四字节的注册表关键字数据类型
        For i = Len(tmpVal) To 1 Step -1                    ' 将每位进行转换
            KeyVal = KeyVal + Hex(Asc(Mid(tmpVal, i, 1)))   ' 生成值字符。 By Char。
        Next
        KeyVal = Format$("&h" + KeyVal)                     ' 转换四字节的字符为字符串
    End Select
    GetKeyValue = KeyVal                                    ' 返回成功
    rc = RegCloseKey(hKey)                                  ' 关闭注册表关键字
    Exit Function                                           ' 退出
    
GetKeyError:      ' 错误发生后将其清除...                                    ' 设置返回值到空字符串
    GetKeyValue = DefaultKeyVal
    If hKey <> 0 Then
        rc = RegCloseKey(hKey)                                  ' 关闭注册表关键字
    End If
End Function

Public Function SetKeyValue(KeyRoot As Long, KeyName As String, SubKeyRef As String, KeyVal As String) As Boolean
'==============
'写注册表内键值
'==============
Dim i As Long
Dim lResult As Long
Dim hKey As Long
Dim hSubKey As Long
Dim security As SECURITY_ATTRIBUTES
Dim lpdwDisposition As Long
    lResult = RegOpenKeyEx(KeyRoot, "", 0, KEY_ALL_ACCESS, hKey) '打开根目录
    If lResult <> ERROR_SUCCESS Then GoTo SetKeyError
    security.nLength = Len(security)
    '打开主键
    lResult = RegCreateKeyEx(hKey, KeyName, 0, vbNullString, 0, KEY_ALL_ACCESS, security, hSubKey, lpdwDisposition)
    If lResult <> ERROR_SUCCESS Then GoTo SetKeyError

    lResult = RegSetValueEx(hSubKey, SubKeyRef, 0, REG_SZ, KeyVal & Chr(0), RealLength(KeyVal) + 1)
    lResult = RegCloseKey(hSubKey)
    lResult = RegCloseKey(hKey)
    SetKeyValue = True
    Exit Function
SetKeyError:
    SetKeyValue = False
    lResult = RegCloseKey(hSubKey)
    lResult = RegCloseKey(hKey)
End Function

Public Function RealMid(ByVal str As String, Start As Long, Optional Length As Long) As String
'==============
'按字节截取字符
'==============
    On Error GoTo Err_Handle
    If Length = 0 Then
        RealMid = StrConv(MidB(StrConv(str, vbFromUnicode), Start), vbUnicode)
    Else
        RealMid = StrConv(MidB(StrConv(str, vbFromUnicode), Start, Length), vbUnicode)
    End If
    Exit Function
Err_Handle:
    
End Function
Function RealLength(ByVal str As String) As Long
'============
'字串的字节数
'============
On Error GoTo Err_Handle
    RealLength = VBA.LenB(VBA.StrConv(str, vbFromUnicode))
    Exit Function
Err_Handle:
    
End Function

Public Function GetAppPath(ByVal strPath As String) As String
'=========================
'得到带“\”的应用程序路径
'=========================
On Error GoTo Err_Handle
'    Dim strPath As String
'    strPath = RTrim(App.Path)
    If VBA.Right(Trim(strPath), 1) = "\" Then
        GetAppPath = strPath
    Else
        GetAppPath = strPath & "\"
    End If
    Exit Function
Err_Handle:
    MsgBox Err.Description, vbInformation, "系统提示"
End Function

Public Function GetFileName(ByVal strPath As String) As String
' 取得路径中文件名称
Dim i As Long
Dim strFileName As String
On Error GoTo Err_Handle
    strFileName = strPath
    If strPath <> "" Then
        For i = 1 To Len(strPath)
            If Right(strPath, 1) = "\" Then
                GetFileName = Right(strFileName, i - 1)
                Exit For
            Else
                strPath = Left(strPath, Len(strPath) - 1)
                
            End If
        Next
    End If
    Exit Function
Err_Handle:
    MsgBox Err.Description, vbInformation, "系统提示"
End Function
'=========================
Public Function GetFileNamePath(ByVal strPath As String) As String
' 取得路径中文件路径
Dim i As Long
On Error GoTo Err_Handle
    If strPath <> "" Then
        For i = 1 To Len(strPath)
            
            If Right(strPath, 1) = "\" Then
                GetFileNamePath = strPath
                Exit For
            Else
                strPath = Left(strPath, Len(strPath) - 1)
                
            End If
        Next
    End If
    Exit Function
Err_Handle:
    MsgBox Err.Description, vbInformation, "系统提示"
End Function




Public Function SavePictureToDatabase(ByVal pSource As String, fDest As ADODB.Recordset, ByVal sDes As String) As Long
'朝数据库字段存图片.
    On Error GoTo Err_Handle
    Dim strTempFile As String
    Dim lFileHandle As Long
    Dim bPicture() As Byte

    lFileHandle = FreeFile()

    Open pSource For Binary As #lFileHandle
    ReDim bPicture(LOF(lFileHandle)) As Byte
    Get #lFileHandle, , bPicture
    Close #lFileHandle
    fDest(sDes).AppendChunk bPicture
    fDest.Update
    Exit Function
Err_Handle:
    SavePictureToDatabase = Err.Number
    Close #lFileHandle
End Function

Public Function ShowPictureFromDatabase(ByVal fSource As ADODB.Field) As String
    On Error GoTo Err_Handle
    '取得数据库中的图片
    Dim strTempFile As String
    Dim lFileHandle As Long
    Dim bPicture() As Byte
    ReDim bPicture(fSource.ActualSize - 1) As Byte
    strTempFile = IIf(Right(App.Path, 1) = "\", App.Path, App.Path & "\") & "tmpLoadPicture.tmp"
    bPicture = fSource.GetChunk(fSource.ActualSize)
    lFileHandle = FreeFile()
    Open strTempFile For Binary As #lFileHandle
    Put #lFileHandle, , bPicture
    Close #lFileHandle
    ShowPictureFromDatabase = strTempFile

    Exit Function
Err_Handle:
    ShowPictureFromDatabase = ""
    Close #lFileHandle
End Function