Prosty przykład VBA (bez klas)

Jako, że nazywasz siebie TheNotSoGuru , wypróbuj następujące względne proste podejście: zamiast API jak definicja alias, będziesz musiał napisać definicje aliasów w jednej funkcji zdefiniowanej przez użytkownika alias () .

Wywołanie procedury testowej

To pokazuje, jak wywoływać aliasy za pomocą jednej zdefiniowanej przez użytkownika alias funkcji; pierwszym argumentem jest nazwa aliasu jako string, inne argumenty definiują możliwe argumenty oryginalnych funkcji:

Option Explicit     ' declaration head of your code module

Sub Test()
Debug.Print "0) Original Function", myFunction
Debug.Print "1) alias(""(myFunc1"")", alias("myFunc1")
Debug.Print "2) alias(""(myFunc2"")", alias("myFunc2")      ' too less arguments
Debug.Print "2) alias(""(myFunc2"",false)", alias("myFunc2", False)
End Sub

Przykładowe funkcje

pierwszy przykład nie wymaga żadnego argumentu ; drugi przykład pokazuje niepoprawne jak i poprawne wywołanie funkcji alias - oryginalna funkcja uczestniczy w wejściu argumentu logicznego (True lub False).

Function myFunction() As Variant
'Some rules
'...
'return result
 myFunction = "Result from myFunction"
End Function

Function myFunctionWithOneArgument(Optional ByVal b As Boolean = True) As String
'Some rules
If b Then
   myFunctionWithOneArgument = "result from myFunctionWithOneArgument " & "okay"
Else
   myFunctionWithOneArgument = "result from myFunctionWithOneArgument " & "without comment"
End If
End Function

=============== przykład funkcji Alias ()

Ty są odpowiedzialni za wstawianie definicji aliasów do funkcji alias. Pozwala nawet wymusić wprowadzenie poprawnej liczby argumentów, podnosząc błąd 450 " błędna liczba argumentów ..."poprzez obsługę błędów. Jeśli wystąpi błąd, messagebox wyświetli komunikat o błędzie.

Function alias(ByVal sFunc, Optional arg1, Optional arg2, Optional arg3)
On Error GoTo oops           ' error handler
Select Case sFunc & ""       ' check your own aliases as string values 
  Case "myFunc1", "1"        ' your alias Definition(s)
       alias = myFunction    ' return original function myFunction
  Case "myFunc2", "One"      ' see above
       ' defines if one argument is needed here:
       If IsMissing(arg1) Then Err.Raise (450)   ' too less arguments if arg1 is missing
       alias = myFunctionWithOneArgument(arg1)
  Case Else
       alias = "Unknown function alias " & sFunc
End Select
EverythingOkay:     Exit Function

oops:
MsgBox "Function: " & sFunc & vbNewLine & vbNewLine & _
       "Error No: " & Err.Number & vbNewLine & _
       Err.Description, vbExclamation, "Error - Wrong number of arguments"
Err.Clear
End Function

Wyszukiwanie aliasów za pomocą podobieństwa

A) Intro

Twój komentarz od 1/22: " problem nie polega na tym, że koniecznie chcę celowo wywołać alias, jest to problem zapominania o tym, co mogłem nazwać Funkcją na początek (tj. verifyRange vs verifyRng). Gdybym wiedział, że nazywam pseudonim od początku, nie musiałbym nazywać pseudonimu. Ale twoje rozwiązanie działa i było bardzo dobrze przemyślane Wynocha."

Ze względu na twój przykład w cytowanym powyżej komentarzu: ponieważ nieznacznie zmodyfikowałeś swoje początkowe pytanie , pomyślałem o alternatywnym rozwiązaniu i dodałem je jako niezależną nową odpowiedź :

► można skorzystać z tzw. SoundEx wyszukiwanie do grupy nazw procedur na podstawie algorytmu fonetycznego.

Metoda: a Kod Soundex identyfikuje zbiór podobnie brzmiące terminy, nazwy lub ... ► nazwy procedur . Jeśli połączysz to z pętlą poprzez vbide listę wszystkich istniejących procedur / funkcji (nie zapomnij ustawić referencji ), będziesz w stanie uzyskać najbardziej prawdopodobny alias (- y) na liście.

Przykładowy wynik

1/1 Project(s): "VBAProject" (D:\Excel\test.xlsm)
**Project name: "VBAProject" ** (Host Project)
++SoundEx("verifyRange")="V616"
--   Found --  Procedure/Function name(s) ---------  ------------------
[Prc: Sub]     verifyRng   in Std Module modTest1    Line#: 2/[Body: 3]
[Prc: Sub]     verifyRange in Std Module modSortDict Line#: 6/[Body: 6]

Uwaga: metoda ta buduje skondensowany kod alfanumeryczny na podstawie sześciu klasyfikacji fonetycznych z ludzi dźwięki mowy (bilabialne, labiodentalne, zębowe, pęcherzykowe, welarne i glottalne) usuwające wokal i niektóre wystąpienia "H", " W " I "Y"; kod składa się z pierwszej dużej litery i trzech kolejnych cyfr (wypełnionych 0, jeśli nie znaleziono więcej spółgłosek) . BTW początki sięgają końca 1800 roku używane do indeksowania amerykańskich spisów powszechnych .

Linki

Znajdź słowo, które najbardziej mi odpowiada sznurek? http://www.creativyst.com/Doc/Articles/SoundEx1/SoundEx1.htm#JavaScriptCode https://en.wikipedia.org/wiki/Soundex

Przykład Soundex

Aby zademonstrować kodowanie soundex, spróbuj wykonać poniższe przykładowe wywołanie z identycznymi wynikami:

Sub testSoundEx()
Dim i As Integer
Dim a()
a = Array("verifyRange", "verifyRng", "vrfRanges")
Debug.Print "Proc name", "SoundEx Code": Debug.Print String(50, "-")
For i = LBound(a) To UBound(a)
    Debug.Print a(i), SoundEx(a(i))
Next i
End Sub

Funkcja SoundEx

Function SoundEx(ByVal s As String) As String
' Site:   https://stackoverflow.com/questions/19237795/find-the-word-which-i-closest-to-the-particular-string/19239560#19239560
' Source: Developed by Richard J. Yanco
' Method: follows the Soundex rules given at http://home.utah-inter.net/kinsearch/Soundex.html
Dim Result As String, c As String * 1
Dim Location As Integer
s = UCase(s)                ' use upper case
' First character must be a letter
If Len(Trim(s)) = 0 Then
   Exit Function
ElseIf Asc(Left(s, 1)) < 65 Or Asc(Left(s, 1)) > 90 Then
    SoundEx = ""
    Exit Function
Else
  ' (1) Convert to Soundex: letters to their appropriate digit,
    '             A,E,I,O,U,Y ("slash letters") to slashes
    '             H,W, and everything else to zero-length string
    Result = Left(s, 1)
    For Location = 2 To Len(s)
        Result = Result & Category(Mid(s, Location, 1))
    Next Location
  ' (2) Remove double letters
    Location = 2
    Do While Location < Len(Result)
        If Mid(Result, Location, 1) = Mid(Result, Location + 1, 1) Then
            Result = Left(Result, Location) & Mid(Result, Location + 2)
        Else
            Location = Location + 1
        End If
    Loop
   ' (3) If category of 1st letter equals 2nd character, remove 2nd character
    If Category(Left(Result, 1)) = Mid(Result, 2, 1) Then
        Result = Left(Result, 1) & Mid(Result, 3)
    End If
   ' (4) Remove slashes
    For Location = 2 To Len(Result)
        If Mid(Result, Location, 1) = "/" Then
            Result = Left(Result, Location - 1) & Mid(Result, Location + 1)
        End If
    Next
   ' (5) Trim or pad with zeroes as necessary
    Select Case Len(Result)
        Case 4
            SoundEx = Result
        Case Is < 4
            SoundEx = Result & String(4 - Len(Result), "0")
        Case Is > 4
            SoundEx = Left(Result, 4)
    End Select
End If
End Function

Funkcja pomocnicza wywoływana przez SoundEx()

Ta funkcja pomocnicza zwraca kod literowy oparty na fonetyce klasyfikacje (patrz UWAGI powyżej):

Private Function Category(c) As String
'   Returns a Soundex code for a letter
Select Case True
    Case c Like "[AEIOUY]"
        Category = "/"
    Case c Like "[BPFV]"
        Category = "1"
    Case c Like "[CSKGJQXZ]"
        Category = "2"
    Case c Like "[DT]"
        Category = "3"
    Case c = "L"
        Category = "4"
    Case c Like "[MN]"
        Category = "5"
    Case c = "R"
        Category = "6"
    Case Else 'This includes H and W, spaces, punctuation, etc.
        Category = ""
End Select
End Function

► rozwiązanie problemu-przykładowe wywołanie, aby uzyskać Funkcje Za pomocą aliasu

B) problem z pamięcią, czyli jak pobiegać pamięcią

Możesz użyć poniższego przykładowego wywołania, aby wyszukać aliasy procedur / funkcji za pomocą składni listProc {function name string}, np. listProc "verifyRange" i uzyskać skondensowaną listę wszystkich znalezionych aliasów w oknie Immediate Window Twojego Edytora Visual Basic "VBE": {]}

Sub Test()
listProc "verifyRange"  ' possibly gets verifyRange AND verifyRng via SoundEx "V616"
'listProc "verify"      ' possibly gets nothing, as SoundEx "V610" has no fourth consonant
'listProc                '[ displays ALL procedures without SoundEx Filter ]
End Sub

Uwaga: należy pamiętać, że kod SoundEx (np. "V616" dla verifyRange) jest ograniczony do czterech znaków alfanumerycznych. Jeśli szukasz tylko "verify" (=3 spółgłoski V + r + f), otrzymasz "V610 "zamiast" verifyRange "lub" verifyRng " (V+R+f+r). W takim przypadku należy wyszukać parę wariantów.

============================= główna procedura listProc =====================

Sub listProc(Optional ByVal sFuncName As String)
' Purpose: display procedures using a SoundEx Filter
' Call:   0 arguments or empty argument - ALL procedures without filter
'         1 argument (not empty)        - procedures found via SoundEx
' Note:   requires reference to Microsoft Visual Basic for Applications Extensibility 5.3
' Declare variables to access the macros in the workbook.
Dim VBAEditor      As VBIDE.VBE         ' VBE
Dim objProject     As VBIDE.VBProject   ' Projekt
Dim objComponent   As VBIDE.VBComponent ' Modul
Dim objCode        As VBIDE.CodeModule  ' Codeblock des Moduls
' Declare other miscellaneous variables.
Dim sProcName      As String
Dim sndx As String, sndx2 As String
Dim pk             As vbext_ProcKind       ' proc kind (Sub, Function, Get, Let)
Dim strPK          As String, sTyp As String
Dim iLine          As Integer, iBodyLine As Integer, iStartLine As Integer
Dim i              As Integer
Dim bShow          As Boolean             ' show procedure name
Dim bSoundEx       As Boolean
If Len(Trim(sFuncName)) > 0 Then bSoundEx = True  ' show alle procedures!
' ========================================
' Get the project details in the workbook.
' ========================================
  Set VBAEditor = Application.VBE

  Set objProject = VBAEditor.ActiveVBProject
' Set objProject = VBAEditor.VBProjects("MyProcject")   ' 1-based, project name or item number

 For i = 1 To VBAEditor.VBProjects.Count    ' show name, filename, buildfilename (DLL)
     Debug.Print i & "/" & _
                 VBAEditor.VBProjects.Count & " Project(s): """ & _
                 VBAEditor.VBProjects(i).Name & """ (" & VBAEditor.VBProjects(i).filename & ")"
 Next i
' get SoundEx of Function name
  sndx2 = SoundEx(sFuncName)
' ==================
' ? PROJECT NAME
' ==================
'   objProject.Type ...vbext_pt_HostProject 100 Host-Project
'                   ...vbext_pt_StandAlone  101 Standalone-Project
  Debug.Print "**Project name: """ & objProject.Name & """ ** (" & _
              IIf(objProject.Type = 100, "Host Project", "Standalone") & ")"
  If bSoundEx Then Debug.Print "++SoundEx(""" & sFuncName & """)=""" & sndx2 & """" & _
                               vbNewLine & "--   Found --  Procedure/Function name(s)"

' Iterate through each component (= Module) in the project.
For Each objComponent In objProject.VBComponents        ' alle MODULE
    ' Find the code module for the project (Codeblock in current component/=module).
      Set objCode = objComponent.CodeModule
      ' =============
      ' ? MODULE NAME
      ' =============
      If objCode.CountOfLines > 0 And Not bSoundEx Then
         Debug.Print " *** " & _
             sModType(objComponent.Type) & " ** " & objComponent.Name & " ** "
      End If
  ' Scan through the code module, looking for procedures.
  ' Durch alle Codezeilen des jeweiligen Moduls gehen
    iLine = 1
    Do While iLine < objCode.CountOfLines               ' alle Zeilen durchackern (1/End ...)

      ' =================
      ' Get Procedurename                               ' !! SETZT AUTOMATISCH >> pk << !!
      ' =================
        sProcName = objCode.ProcOfLine(iLine, pk)       ' jede nächste Zeile auf Prozedurbeginn checken

        If sProcName <> "" Then                         ' ohne Declaration head
            ' -----------------
            ' Found a procedure
            ' -----------------
            ' a) Get its details, and ...
              strPK = pk                                 ' 0-Prc|1-Let/2-Set/3-Get Werte abfangen !!!
           '' iStartLine = objCode.ProcStartLine(sProcName, strPK)  ' here = iLine !!
              iBodyLine = objCode.ProcBodyLine(sProcName, strPK)    ' Zeilennr mit Sub/Function/L/S/Get
              sTyp = sPrcType(objCode.Lines(iBodyLine, 1))          ' Sub|Fct|Prp
            ' b) Check Soundex
              If bSoundEx Then
                 sndx = SoundEx(sProcName)
                 If sndx = sndx2 Or UCase(sProcName) = UCase(sFuncName) Then
                    bShow = True
                 Else
                    bShow = False
                 End If
              Else
                 bShow = True
              End If
              ' ==============
              ' c) ? PROC NAME
              ' --------------
              If bShow Then
                 Debug.Print "    " & "[" & sPK(strPK) & ": " & sTyp & "] " & _
                          sProcName & IIf(bSoundEx, " in " & sModType(objComponent.Type) & " " & objComponent.Name, "") & vbTab, _
                          "Line#: " & iLine & "/[Body: " & iBodyLine & "]"
              End If
            ' -------------------------------------------
            ' d) Skip to the end of the procedure !
            '    => Add line count to current line number
            ' -------------------------------------------
              iLine = iLine + objCode.ProcCountLines(sProcName, pk)
        Else
            ' This line has no procedure, so => go to the next line.
            iLine = iLine + 1
        End If
    Loop

Next objComponent

' Clean up and exit.
  Set objCode = Nothing
  Set objComponent = Nothing
  Set objProject = Nothing


End Sub

3 Pomocnik Funkcje do głównej procedury listProc

te funkcje pomocnicze zwracają dodatkowe informacje do procedur i modułu:

Function sPK(ByVal prockind As Long) As String
' Purpose: returns short description of procedure kind (cf ProcOfLine arguments)
Dim a(): a = Array("Prc", "Let", "Set", "Get")
sPK = a(prockind)
End Function

Function sPrcType(ByVal sLine As String) As String
' Purpose: returns procedure type abbreviation
If InStr(sLine, "Sub ") > 0 Then
   sPrcType = "Sub"     ' sub
ElseIf InStr(sLine, "Function ") > 0 Then
   sPrcType = "Fct"     ' function
Else
    sPrcType = "Prp"    ' property (Let/Set/Get)
End If
End Function

Function sModType(ByVal moduletype As Integer) As String
' Purpose: returns abbreviated module type description
Select Case moduletype
   Case 100
     sModType = "Tab Module"
   Case 1
     sModType = "Std Module"
   Case 2
     sModType = "CLS Module"
   Case 3
     sModType = "Frm Module"
   Case Else
     sModType = "?"
 End Select
End Function