usefuls.bas

Rjindeal加密算法

Attribute VB_Name = "Usefuls"
Option Explicit

'-------------------------------------------
' All code in this module is original, unless otherwise specified (or I can't remember who wrote it...)
' It tends to get copied into any project of a reasonable size that I create.
'   - FireClaw.  [e-mail]
'-------------------------------------------

' Compiler Directives
'#Const Vba6 = False

'-------------------------------------------
' Timing Declares
'-------------------------------------------
Public Type LongLong ' Unsigned 64-bit long
    LowPart As Long
    HighPart As Long
End Type

Declare Function QueryPerformanceCounter Lib "kernel32" _
                (lpPerformanceCount As LongLong) As Long

Declare Function QueryPerformanceFrequency Lib "kernel32" _
                (lpFrequency As LongLong) As Long
Declare Function timeGetTime Lib "winmm.dll" () As Long

'-------------------------------------------
' ODBC stuff
'-------------------------------------------
Declare Function SQLGetStmtOption Lib "odbc32.dll" (ByVal hstmt As Long, ByVal fOption As Integer, ByRef pvParam As Long) As Integer
Global Const SQL_QUERY_TIMEOUT = 0
Global Const SQL_MAX_ROWS = 1
Global Const SQL_NOSCAN = 2
Global Const SQL_MAX_LENGTH = 3
Global Const SQL_ASYNC_ENABLE = 4
Global Const SQL_BIND_TYPE = 5
Global Const SQL_CURSOR_TYPE = 6
Global Const SQL_CONCURRENCY = 7
Global Const SQL_KEYSET_SIZE = 8
Global Const SQL_ROWSET_SIZE = 9
Global Const SQL_SIMULATE_CURSOR = 10
Global Const SQL_RETRIEVE_DATA = 11
Global Const SQL_USE_BOOKMARKS = 12
Global Const SQL_GET_BOOKMARK = 13
Global Const SQL_ROW_NUMBER = 14
Global Const SQL_GET_ROWID = 1048
Global Const SQL_GET_SERIALNO = 1049

'-------------------------------------------
' Windows Messaging Stuff
'-------------------------------------------
Type POINTAPI
        X As Long
        Y As Long
End Type
Type MSG
    hwnd As Long
    message As Long
    wParam As Long
    lParam As Long
    time As Long
    PT As POINTAPI
End Type
Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
Declare Function TranslateMessage Lib "user32" (lpMsg As MSG) As Long
Declare Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As MSG) As Long
Public Const PM_NOREMOVE = &H0
Public Const PM_NOYIELD = &H2
Public Const PM_REMOVE = &H1

'-------------------------------------------
' Windows Graphics API Calls
'-------------------------------------------
Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type
Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Declare Function IntersectRect Lib "user32" (lpDestRect As RECT, lpSrc1Rect As RECT, lpSrc2Rect As RECT) As Long

'-------------------------------------------
' ClipBoard Stuff
'-------------------------------------------
' Memory library calls
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, _
                                                                ByVal dwBytes As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    lpDest As Any, _
    lpSource As Any, _
    ByVal cbCopy As Long)
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
' Clipboard Function calls
Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Declare Function EmptyClipboard Lib "user32" () As Long
Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Declare Function CloseClipboard Lib "user32" () As Long
Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Declare Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
Declare Function GetClipboardOwner Lib "user32" () As Long
Declare Function GetClipboardViewer Lib "user32" () As Long

' Memory constants
Public Const GMEM_SHARE = &H2000
Public Const GMEM_MOVEABLE = &H2
Public Const GMEM_ZEROINIT = &H40
Public Const FOR_CLIPBOARD = GMEM_MOVEABLE Or GMEM_SHARE Or GMEM_ZEROINIT

' Clipboard format types and constants
Public Enum ClipBoardFormats
    CF_ANSIONLY = &H400&
    CF_APPLY = &H200&
    CF_BITMAP = 2
    CF_DIB = 8
    CF_DIF = 5
    CF_DSPBITMAP = &H82
    CF_DSPENHMETAFILE = &H8E
    CF_DSPMETAFILEPICT = &H83
    CF_DSPTEXT = &H81
    CF_EFFECTS = &H100&
    CF_ENABLEHOOK = &H8&
    CF_ENABLETEMPLATE = &H10&
    CF_ENABLETEMPLATEHANDLE = &H20&
    CF_ENHMETAFILE = 14
    CF_FIXEDPITCHONLY = &H4000&
    CF_FORCEFONTEXIST = &H10000
    CF_GDIOBJFIRST = &H300
    CF_GDIOBJLAST = &H3FF
    CF_INITTOLOGFONTSTRUCT = &H40&
    CF_LIMITSIZE = &H2000&
    CF_METAFILEPICT = 3
    CF_NOFACESEL = &H80000
    CF_NOSCRIPTSEL = &H800000
    CF_NOSIMULATIONS = &H1000&
    CF_NOSIZESEL = &H200000
    CF_NOSTYLESEL = &H100000
    CF_NOVECTORFONTS = &H800&
    CF_NOOEMFONTS = CF_NOVECTORFONTS
    CF_NOVERTFONTS = &H1000000
    CF_OEMTEXT = 7
    CF_OWNERDISPLAY = &H80
    CF_PALETTE = 9
    CF_PENDATA = 10
    CF_PRINTERFONTS = &H2
    CF_PRIVATEFIRST = &H200
    CF_PRIVATELAST = &H2FF
    CF_RIFF = 11
    CF_SCALABLEONLY = &H20000
    CF_SCREENFONTS = &H1
    CF_SCRIPTSONLY = CF_ANSIONLY
    CF_SELECTSCRIPT = &H400000
    CF_SHOWHELP = &H4&
    CF_SYLK = 4
    CF_TEXT = 1
    CF_TIFF = 6
    CF_TTONLY = &H40000
    CF_UNICODETEXT = 13
    CF_BOTH = (CF_SCREENFONTS Or CF_PRINTERFONTS)
End Enum

'-------------------------------------------
' My own constants and Enums
'-------------------------------------------
Private Const CntrlToken = "#"  ' For Load/Save Form

' Enum for length unit conversions
Public Enum LengthUnits
    ' Metric
    Micrometres = 1 ' 0.001mm
    Milimetres = 2
    Centimetres = 3 ' 10mm
    Metres = 4 ' 100cm
    Kilometres = 5 ' 1000m
    ' Common Imperial
    Inches = 6 ' 25.4 milimetres
    Feet = 7 ' 12 inches
    Yards = 8 ' 3 Feet
    Miles = 9 ' 1760 yards
    ' Nautical and Horse racing
    NauticalMiles = 10 ' 6080 yards
    CableLengths = 11 ' 600 feet
    Chains = 12 ' Gunters Chain: 66 feet
    Fathoms = 13 ' 6 feet
    Furlongs = 14 ' 660 feet or 10 chains
    Hands = 15 ' 4 inches
    Degrees = 16 ' 1/360th of earth circumference
    Minutes = 17 ' 1/60th of a degree, or one nautical mile
    Seconds = 18 ' 1/60th of a minute, or 1/60th of a nautical mile
    ' Computer
    Dots = 19 ' 1/300th of an inch (printing)
    Points = 20 ' 1/72nd of an inch (fonts)
    RadixDots = 21 ' 1/4 of a dot (bitmap font design)
    Twips = 22 ' 1/1440th of an inch (screen measure)
    PlotterUnits = 23 ' 1/1016th of an inch (printing)
    ' Scientific
'   Angstroms = 24 ' Tiny tiny unit.  Commented because unsure about actual value
    LightYears = 25 ' 9.4 * 10^15 metres
    ' Old and Biblical
    Cubits = 26 ' 18 inches
    RoyalEgyptianCubits = 27 ' 21 inches
    Ells = 28 ' 45 inches
    Palms = 29 ' 127mm
    Reeds = 30 ' 1520mm
    Span = 31 ' 9 inches
End Enum

'-------------------------------------------
' Modular Variables
'-------------------------------------------

' For split string purposes
Private mSplitLine As String ' These three vars are used to
Private mDelimiter As String ' split a delimiter seperated line up
Private mCurrentPos As Long

'-------------------------------------------
' String handling functions
'-------------------------------------------
Public Sub SplitStringIntoParts(pLine As String, pDelimiter)
    mSplitLine = pLine
    mDelimiter = pDelimiter
    mCurrentPos = 1
End Sub

Public Function GetNextPartOfSplitString() As String
Dim lCurrentPos As Long
    If mCurrentPos > Len(mSplitLine) Then
        GetNextPartOfSplitString = ""
    Else
        lCurrentPos = InStr(mCurrentPos, mSplitLine, mDelimiter)
        If lCurrentPos = 0 Then
            ' Get rest of line
            GetNextPartOfSplitString = Mid(mSplitLine, mCurrentPos, (Len(mSplitLine) - mCurrentPos) + 1)
            mCurrentPos = Len(mSplitLine) + 1
        Else
            GetNextPartOfSplitString = Mid(mSplitLine, mCurrentPos, (lCurrentPos - mCurrentPos))
            mCurrentPos = lCurrentPos + Len(mDelimiter)
        End If
    End If
End Function

Public Function RightJustifyCurrencyToString(Value As Currency, Optional Padding As Long = 10, Optional FailureString As String = "") As String
Dim tmpStr As String
Dim i As Long
    tmpStr = Format(Value, "0.00")
    If Padding - Len(tmpStr) < 0 Then
        If Len(FailureString) = 0 Then
            RightJustifyCurrencyToString = ""
            For i = 1 To Padding
                RightJustifyCurrencyToString = RightJustifyCurrencyToString & "#"
            Next
        Else
            RightJustifyCurrencyToString = FailureString
        End If
    Else
        RightJustifyCurrencyToString = Space(Padding - Len(tmpStr)) & tmpStr
    End If
End Function

' Translates into "Database field friendly" format
Public Function QuoteX2(pString As String) As String
Dim lPos As Long
Dim lNewString As String

    ' if it contains a quote, we need to substitute this with ""
    Trim (pString)
    If Len(pString) = 0 Then
        QuoteX2 = ""
        Exit Function
    End If
    If Len(pString) = 1 Then
        If pString = Chr(34) Then
            QuoteX2 = Chr(34) & Chr(34) & Chr(34) & Chr(34)
            Exit Function
        End If
    End If
    lNewString = Chr(34)
    For lPos = 1 To Len(pString)
        If Mid(pString, lPos, 1) = Chr(34) Then
            lNewString = lNewString & Chr(34)
        End If
        lNewString = lNewString & Mid(pString, lPos, 1)
    Next
    lNewString = lNewString & Chr(34)
    QuoteX2 = Trim(lNewString)
End Function

Private Function ConvertStringToValidCSVFormat(ByVal pString As String) As String