library.bas

来自「很好！ 很实用！ 免费！」· BAS 代码 · 共 295 行

Attribute VB_Name = "Library"
Option Explicit
'*********************************************
'存放一般功能函数
'*********************************************
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
'show form
Sub ShowForm(frmName As Object)
    frmName.Show
    frmName.SetFocus
End Sub

'得到一个新的GUID
Public Function newGUID() As String
Dim objGuidTemp As New IMSKERNELLib.Guid
    newGUID = objGuidTemp.newString(2)
    Set objGuidTemp = Nothing
End Function

'给出服务器当前时间
Public Function getDBDate() As Date
Dim rsDateTemp As ADODB.Recordset
    Set rsDateTemp = New ADODB.Recordset
    rsDateTemp.Open "select DBDate = getDate()", g_cnString
    getDBDate = rsDateTemp(0).value
    rsDateTemp.Close
    Set rsDateTemp = Nothing
End Function
'把字符串中的"'" 转为 "''"，因为数据库中是把''转为'处理,在数据转类型中,必须要求用此转抵.
Public Function CheckString(ByVal sData As String, Optional sEnd As String = "") As String
    CheckString = "'" + Replace(CStr(sData), "'", "''") + "'" + sEnd
End Function


Public Function NTDomainUserName() As String
    Dim strBuffer As String * 255
    Dim lngBufferLength As Long
    Dim lngRet As Long
    Dim strTemp As String
    
    lngBufferLength = 255
    lngRet = GetUserName(strBuffer, lngBufferLength)
    strTemp = UCase(Trim$(strBuffer))
    strTemp = Left$(strTemp, Len(strTemp) - 1)
    NTDomainUserName = Mid(strTemp, 1, InStr(strTemp, Chr(0)) - 1)
End Function

'打印到Excel中
Function ExcelColToString(index As Integer) As String
Dim i As Integer

    i = Int(index / 26)
    Select Case i
        Case 0
           ExcelColToString = Chr(65 + index - 1)
        Case Else
           ExcelColToString = "A" + ExcelColToString(index + 1 - 26 * i)
    End Select
End Function
'当从数据库中取值时用
Public Function nullToString(vData As Variant, iType As Integer) As Variant
    If IsNull(vData) Then
        Select Case iType
            Case 1 'string
                nullToString = ""
            Case 2 'integer
                nullToString = "0"
            Case 3 'datetime
                nullToString = Date
            Case 4 'guid
                nullToString = "0x0"
        End Select
    Else
        nullToString = vData
    End If
End Function
'当更改数据库时用
Public Function stringToNull(vData As Variant, iType As Integer) As String
        Select Case iType
            Case 1 'string
                If CStr(vData) = "" Then
                    stringToNull = "null"
                Else
                    stringToNull = CheckString(vData)
                End If
            Case 2 'integer
                If CStr(vData) = "0" Then
                    stringToNull = "null"
                Else
                    stringToNull = CStr(vData)
                End If
            Case 3 'datetime
                If CStr(vData) = "" Then
                    stringToNull = "null"
                Else
                    stringToNull = "Convert(Datetime," + CheckString(vData) + ")"
                End If
            Case 4 'guid
                If CStr(vData) = "0x0" Then
                    stringToNull = "null"
                Else
                    stringToNull = CheckString(vData)
                End If
        End Select
End Function

'ADO to Excel
Public Function ADOToExcel(rsRecordset As ADODB.Recordset) As Boolean
Dim eclApp As Object
Dim ws As Object
Dim i As Integer
Dim j As Integer
Dim sFileName As String
On Error GoTo Err:
    frmShowDialog.CommonDialog1.Filter = "Excel (*.XLS)|*.XLS|CSV (*.csv)|*.CSV|*.* (*.*)|*.*"
    frmShowDialog.CommonDialog1.ShowSave
    sFileName = frmShowDialog.CommonDialog1.FileName
    If sFileName = "" Then
       ADOToExcel = False
       Exit Function
    End If
    
    Set eclApp = CreateObject("Excel.Application")
    Set ws = CreateObject("Excel.Sheet")
    Set ws = eclApp.Workbooks.Add
    eclApp.Visible = False
    
    'Save
    '取出数据到Excel
    With rsRecordset
        'show field name
        For i = 0 To .Fields.Count - 1
            eclApp.Cells(1, i + 1).Font.Bold = True
            eclApp.Cells(1, i + 1) = .Fields(i).Name
        Next i
            'show data
            If Not .BOF Then
                .MoveFirst
                i = 2
                Do While Not .EOF
                    For j = 0 To .Fields.Count - 1
                         eclApp.Cells(i + 1, j + 1) = .Fields(j).value
                    Next j
                    .MoveNext
                    i = i + 1
                    Loop
            End If
        ws.SaveAs sFileName
    End With
    ADOToExcel = True
    GoTo Dispose:
Err:
    MsgBox "存为EXCEL文件时出错！未能导出数据"
    ADOToExcel = False
    GoTo Dispose:
Dispose:
    '关闭对象
    ws.Saved = True
    ws.Close
    Set ws = Nothing
    eclApp.Quit
    Set eclApp = Nothing
End Function
'Excel to ADO
Public Function ExcelToADO() As ADODB.Recordset
Dim sFileName As String
Dim eclApp As Object
Dim rsTemp As ADODB.Recordset
Dim ws As Object
Dim i As Integer
Dim j As Integer
Dim sTableName As String
On Error GoTo Err:
    frmShowDialog.CommonDialog1.Filter = "Excel (*.XLS)|*.XLS|*.* (*.*)|*.*"
    frmShowDialog.CommonDialog1.ShowOpen
    sFileName = frmShowDialog.CommonDialog1.FileName
    If sFileName = "" Then
       Set ExcelToADO = Nothing
       Exit Function
    End If
    Set eclApp = CreateObject("Excel.Application")
    Set rsTemp = New ADODB.Recordset
    Set ws = CreateObject("Excel.Sheet")
    Set ws = eclApp.Workbooks.Open(sFileName)
    eclApp.Visible = False
    
    sTableName = Trim(ws.Sheets(1).Name)
    '关闭对象
    ws.Saved = True
    ws.Close
    Set ws = Nothing
    eclApp.Quit
    Set eclApp = Nothing
    
    With rsTemp
        .Open "select * from [" + sTableName + "$]", "Provider = Microsoft.Jet.OLEDB.4.0;Data Source=" + sFileName + ";Extended Properties=Excel 8.0;", 1, 1
    End With
    
    Set ExcelToADO = rsTemp
    Exit Function
Err:
    MsgBox "从EXCEL文件时最出数据时出错！未能取出数据"
    Set ExcelToADO = Nothing
End Function
'*********************************************加解密程序
' Encipher the text using the pasword.
Public Function Cipher(ByVal password As String, ByVal from_text As String) As String
Const MIN_ASC = 32  ' Space.
Const MAX_ASC = 126 ' ~.
Const NUM_ASC = MAX_ASC - MIN_ASC + 1

Dim offset As Long
Dim str_len As Integer
Dim i As Integer
Dim ch As Integer
Dim to_text As String

    ' Initialize the random number generator.
    offset = NumericPassword(password)
    Rnd -1
    Randomize offset

    ' Encipher the string.
    str_len = Len(from_text)
    For i = 1 To str_len
        ch = Asc(Mid$(from_text, i, 1))
        If ch >= MIN_ASC And ch <= MAX_ASC Then
            ch = ch - MIN_ASC
            offset = Int((NUM_ASC + 1) * Rnd)
            ch = ((ch + offset) Mod NUM_ASC)
            ch = ch + MIN_ASC
            to_text = to_text & Chr$(ch)
        End If
    Next i
    Cipher = to_text
End Function
' Encipher the text using the pasword.
Public Function Decipher(ByVal password As String, ByVal from_text As String) As String
Const MIN_ASC = 32  ' Space.
Const MAX_ASC = 126 ' ~.
Const NUM_ASC = MAX_ASC - MIN_ASC + 1

Dim offset As Long
Dim str_len As Integer
Dim i As Integer
Dim ch As Integer
Dim to_text As String
    ' Initialize the random number generator.
    offset = NumericPassword(password)
    Rnd -1
    Randomize offset

    ' Encipher the string.
    str_len = Len(from_text)
    For i = 1 To str_len
        ch = Asc(Mid$(from_text, i, 1))
        If ch >= MIN_ASC And ch <= MAX_ASC Then
            ch = ch - MIN_ASC
            offset = Int((NUM_ASC + 1) * Rnd)
            ch = ((ch - offset) Mod NUM_ASC)
            If ch < 0 Then ch = ch + NUM_ASC
            ch = ch + MIN_ASC
            to_text = to_text & Chr$(ch)
        End If
    Next i
    Decipher = to_text
End Function


' Translate a password into an offset value.
Private Function NumericPassword(ByVal password As String) As Long
Dim value As Long
Dim ch As Long
Dim shift1 As Long
Dim shift2 As Long
Dim i As Integer
Dim str_len As Integer

    str_len = Len(password)
    For i = 1 To str_len
        ' Add the next letter.
        ch = Asc(Mid$(password, i, 1))
        value = value Xor (ch * 2 ^ shift1)
        value = value Xor (ch * 2 ^ shift2)

        ' Change the shift offsets.
        shift1 = (shift1 + 7) Mod 19
        shift2 = (shift2 + 13) Mod 23
    Next i
    NumericPassword = value
End Function

'*********************************************加解密程序(完)