自用Excel VBA函数整理 part1

用于二维的Dictionary：

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

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

 

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

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

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}等做占位符，实现得很土）：

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

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中保存基本类型值：

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()函数呢。。。

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（类模块）：

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查询并填充到工作表上：

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