自用Excel VBA函数整理 part1

用于二维的Dictionary：

CreateOrSet2
Public Sub CreateOrSet2(mainDict As Dictionary, mainKey, subKey, value)
    Dim subDict As Dictionary
    If Not mainDict.Exists(mainKey) Or IsEmpty(mainDict.Item(mainKey)) Then
        Set subDict = New Dictionary
        subDict.Item(subKey) = value
        Set mainDict.Item(mainKey) = subDict
    Else
        Set subDict = mainDict.Item(mainKey)
        subDict.Item(subKey) = value
    End If
End Sub

HasValue2
Public Function HasValue2(mainDict As Dictionary, mainKey, subKey) As Boolean
    If mainDict.Exists(mainKey) And Not IsEmpty(mainDict.Item(mainKey)) Then
        Set subDict = mainDict.Item(mainKey)
        If subDict.Exists(subKey) And Not IsEmpty(subDict.Item(subKey)) Then
            HasValue2 = True
        Else
            HasValue2 = False
        End If
    Else
        HasValue2 = False
    End If
End Function

 

数字-字母格式的列号互转：

ColNumToStr
Public Function ColNumToStr(ByVal num) As String
    base = Asc("A") - 1
    If num <= 0 Then
        ColNumToStr = ""
        Exit Function
    End If
    If num <= 26 Then
        ColNumToStr = Chr(num + base)
        Exit Function
    End If
    t = 0
    Do While num > 26
        num = num - 26
        t = t + 1
    Loop
    ColNumToStr = Chr(t + base) & Chr(num + base)
End Function

ColStrToNum
Public Function ColStrToNum(ByVal str) As Integer
    base = Asc("A") - 1
    str = UCase(str)
    If Len(str) = 1 Then
        ColStrToNum = Asc(str) - base
        Exit Function
    End If
    If Len(str) = 2 Then
        pre = Mid(str, 1, 1)
        suf = Mid(str, 2, 1)
        ColStrToNum = (Asc(pre) - base) * 26 + Asc(suf) - base
        Exit Function
    End If
    ColStrToNum = 0
End Function

 

字符串连接（类似String.Format()用{0}{1}等做占位符，实现得很土）：

StrFormat
Public Function StrFormat(fmt, ParamArray arg()) As String
    l = LBound(arg)
    u = UBound(arg)
    ret = CStr(fmt)
    For i = 0 To (u - l)
        part = "{" & i & "}"
        ret = Replace(ret, part, arg(i))
    Next i
    StrFormat = ret
End Function

StrCat
Public Function StrCat(ParamArray arg()) As String
    l = LBound(arg())
    u = UBound(arg())
    ret = ""
    For i = l To u
        ret = ret & arg(i)
    Next i
    StrCat = ret
End Function

 

在Workbook中保存基本类型值：

SetName, GetName
Public Sub SetName(nam, val, Optional visi = False)
    ThisWorkbook.Names.Add name:=nam, RefersTo:=val, visible:=visi
End Sub

Public Function GetName(nam)
    GetName = Evaluate(ThisWorkbook.Names.Item(nam).RefersTo)
End Function

Public Function DeleteName(nam)
    On Error GoTo End_DeleteName
    ThisWorkbook.Names.Item(nam).Delete
    DeleteName = True
End_DeleteName:
    DeleteName = False
End Function

 

函数指针（用VB->Win API->VB的模拟，参考[1][2]）：

另外Application.Run、CallByName、Eval和Evaluate可能更实用，VB6/VBA杂就没一个像js或py那样的全能eval()函数呢。。。

Fn4及例子
Public Declare Function Fn4 Lib "user32" Alias _
"CallWindowProcA" (ByVal pFn4 As Long, ByVal param1 As Long, ByVal param2 As Long, ByVal param3 As Long, ByVal param4 As Long) As Long

Public Sub Test()
    Call InvokeHello1(AddressOf Hello1)
    Debug.Print
    Call InvokeHello2(AddressOf Hello2)
    Debug.Print
End Sub

Private Sub InvokeHello1(ByVal addrFn4 As Long)
    target = "Ptr to Variable"
    ret = Fn4(addrFn4, VarPtr(target), 0, 0, 0)
    Debug.Print target
End Sub

Private Function Hello1(p1, p2, p3, p4) As Long
    Debug.Print "Hello " & p1
    p1 = "Variable Modified"
    Hello = 0
End Function

Private Sub InvokeHello2(ByVal addrFn4 As Long)
    ret = Fn4(addrFn4, VarPtr("Ptr to Static"), 0, 0, 0)
End Sub

Private Function Hello2(p1 As String, p2, p3, p4) As Long
    Debug.Print "Hello " & p1
    Hello = 0
    'p1 = "Access Violation"
End Function

'缺陷： 被调函数有且只能有4个参数，返回值类型只能是Long（LRESULT）
'原理： 借用 LRESULT CallWindowProc(WNDPROC lpPrevWndFunc, HWND hWnd, UINT Msg, WPARAM wParam, lParam lParam)

'注意： 被调函数的4个参数是地址，要用VarPtr()等转换。
'       对普通变量参数不要指定类型，见Hello1()的p1；
'       而静态变量必须指定类型，见Hello2()的p1，还要注意不能改变其值。

 

初级版ArrayList（类模块）：

Class ArrayList

Private  arr()  As  Variant
Private  size, capacity  As   Integer

Private   Sub  Class_Initialize()
    size  =   0
    capacity  =   10
     ReDim  arr( 1   To  capacity)
End Sub

Public   Property   Get  Count()  As   Integer
    Count  =  size
End Property

Public   Property   Get  Item(idx)
    Item  =  arr(idx)
End Property

Public   Property   Let  Item(idx, vlu)
    arr(idx)  =  vlu
End Property

Public   Property   Set  Item(idx, obj)
     Set  arr(idx)  =  obj
End Property

Public   Sub  Add(elem)
    EnsureCapacity
    size  =  size  +   1
    
     If   IsObject (elem)  Then
         Set  arr(size)  =  elem
     Else
        arr(size)  =  elem
     End   If
End Sub

Private   Sub  EnsureCapacity()
     If  (size  +   1 )  >  capacity  Then
         ReDim  Preserve arr( 1   To  capacity  *   2 )  ' Preserve!
        capacity  =  capacity  *   2
     End   If
End Sub

Public   Sub  Clear()
    size  =   0
End Sub

Public   Function  IndexOf(elem)  As   Long
    idx &   =   - 1
    elemObj  =   IsObject (elem)
    
     For  i  =   1   To  size
         If  elemObj  Then
             If   IsObject (arr(i))  Then
                 If  ObjPtr(arr(i))  =  ObjPtr(elem)  Then
                    idx  =  i
                     Exit   For
                 End   If
             End   If
         Else
             If   Not   IsObject (arr(i))  Then
                 If  arr(i)  =  elem  Then
                    idx  =  i
                     Exit   For
                 End   If
             End   If
         End   If
     Next  i

    IndexOf  =  idx
End Function

Public   Sub  Delete(elem)
    idx  =  IndexOf(elem)
     If  idx  <>   - 1   Then
        DeleteAt idx
     End   If
End Sub

Public   Sub  DeleteAt(idx)
     For  i  =  idx  To  (size  -   1 )
         If   IsObject (arr(i  +   1 ))  Then
             Set  arr(i)  =  arr(i  +   1 )
         Else
            arr(i)  =  arr(i  +   1 )
         End   If
     Next  i
    size  =  size  -   1
End Sub

Public   Function  GetArray()
     Dim  ret()  As  Variant
     ReDim  ret( 1   To  size)
     For  i  =   1   To  size
        ret(i)  =  arr(i)
     Next  i
    
    GetArray  =  ret
End Function

 

运行一个SQL查询并填充到工作表上：

ExecuteSelect

Public   Sub  ExecuteSelect(connStr, selectTxt, destTopLeft  As  Range)
     On   Error   GoTo  ExecuteSelect_Err
     Set  ws  =  destTopLeft.Worksheet
    
     Set  conn  =   CreateObject ( " ADODB.Connection " )
    conn.Open connStr
     Set  rs  =  conn.Execute(selectTxt)
    
     For  i  =   0   To  rs.Fields.Count  -   1
        destTopLeft.Offset( 0 , i)  =  rs.Fields(i).Name
     Next  i
    destTopLeft.Offset( 1 ,  0 ).CopyFromRecordset rs

ExecuteSelect_Clean:
     If   Not   IsEmpty (rs)  Then
        rs.Close
     End   If
     If   Not   IsEmpty (rs)  Then
        conn.Close
     End   If
     Set  rs  =   Nothing
     Set  conn  =   Nothing
     Exit   Sub
ExecuteSelect_Err:
     MsgBox   " Error  "   &  Err.Number  &   "  ( "   &  Err.Description  &   " ) "
     GoTo  ExecuteSelect_Clean
End Sub

转载于:https://www.cnblogs.com/dxz/archive/2009/11/22/vba-helper-func-collection.html