Xây dựng RPC Server cho Excel / Access bằng Delphi – Tận dụng lại DLL và bảo mật mã nguồn (3 người xem)

Excel / Access (VBA)
        │
        │ RPCExecute()
        ▼
RPC Server (Delphi)
        │
        │ Load DLL Plugin
        ▼
Business Logic DLL

RPCExecute("127.0.0.1",9000,"MathPlugin.dll","Add","[5,7]")

Sub Test()

    Debug.Print RPCExecute("127.0.0.1", 9000, "MathPlugin.dll", "Add", "[5,7]")

End Sub

12

function Add(A, B: Integer): Integer;
begin
  Result := A + B;
end;

Math.dll
Finance.dll
AI.dll

RPCLoadDLL('MathPlugin.dll');

Alt + F11

Excel / Access
    ↓
chỉ gọi hàm

Replace DLL

Option Explicit
'====================================================
' RPC DLL API
'====================================================
Public Declare PtrSafe Sub RPCServerStartAPI Lib "RPCServerCore.dll" (ByVal IP As String, ByVal Port As Long)

Declare PtrSafe Function RPC_RestartServer Lib "RPCServerCore.dll" () As Long

Public Declare PtrSafe Sub RPCServerStopAPI Lib "RPCServerCore.dll" ()

Public Declare PtrSafe Sub RPCLoadFolderAPI Lib "RPCServerCore.dll" (ByVal Folder As Variant)

Public Declare PtrSafe Function RPC_GetRecentLogsV Lib "RPCServerCore.dll" () As Variant

'===== SERVER STATS =====
Public Declare PtrSafe Function RPC_GetClientCount Lib "RPCServerCore.dll" () As Long

Public Declare PtrSafe Function RPC_GetThreadCount Lib "RPCServerCore.dll" () As Long
Public Declare PtrSafe Function RPC_GetThreadPoolMax Lib "RPCServerCore.dll" () As Long

Public Declare PtrSafe Function RPC_GetRequestCount Lib "RPCServerCore.dll" () As LongLong

'====================================================
' INTERNAL STATE
'====================================================

Private NextLogTime As Date
Private LogRunning As Boolean
Private LastLog As String


'====================================================
' START SERVER
'====================================================

Public Sub RPC_StartServer()
    Dim PluginPath As String
   
    PluginPath = ThisWorkbook.Path & "\Plugins\"
   
    RPCServerStartAPI "127.0.0.1", 9000
   
    RPCLoadFolderAPI PluginPath
   
    Debug.Print "RPC Server Started"
   
    RPC_StartLogMonitor
End Sub

Sub RestartRPC()
    If RPC_RestartServer = 1 Then
        MsgBox "Server restarted"
    Else
        MsgBox "Restart failed"
    End If
End Sub

'====================================================
' STOP SERVER
'====================================================
Public Sub RPC_StopServer()
    RPC_StopLogMonitor
    RPCServerStopAPI
   
    Debug.Print "RPC Server Stopped"
End Sub


'====================================================
' START LOG MONITOR
'====================================================

Public Sub RPC_StartLogMonitor()
    If LogRunning Then Exit Sub
    LogRunning = True
    RPC_PollLogs
End Sub


'====================================================
' STOP LOG MONITOR
'====================================================

Public Sub RPC_StopLogMonitor()
    On Error Resume Next
    LogRunning = False
    Application.OnTime NextLogTime, "RPC_PollLogs", , False
End Sub


'====================================================
' POLL SERVER LOGS
'====================================================

Public Sub RPC_PollLogs()
    Dim s As String
    If Not LogRunning Then Exit Sub
    On Error Resume Next
    s = RPC_GetRecentLogsV
    If s <> "" And s <> LastLog Then
        Debug.Print s
        LastLog = s
    End If
   
    NextLogTime = Now + TimeValue("00:00:02")
    Application.OnTime NextLogTime, "RPC_PollLogs"
End Sub


'====================================================
' SERVER STATS
'====================================================

Public Sub RPC_ServerStats()
    Dim Clients As Long
    Dim Threads As Long
    Dim PoolMax As Long
    Dim Requests As LongLong
   
    Clients = RPC_GetClientCount
    Threads = RPC_GetThreadCount
    PoolMax = RPC_GetThreadPoolMax
    Requests = RPC_GetRequestCount
   
    Debug.Print "------ RPC SERVER STATS ------"
    Debug.Print "Clients  : "; Clients
    Debug.Print "Threads  : "; Threads
    Debug.Print "PoolMax  : "; PoolMax
    Debug.Print "Requests : "; Requests
    Debug.Print "------------------------------"
End Sub


'====================================================
' QUICK COMMANDS
'====================================================

Public Sub RPC_Run()
    RPC_StartServer
End Sub

Public Sub RPC_Stop()
    RPC_StopServer
End Sub

Public Sub RPC_Stats()
    RPC_ServerStats
End Sub

RPCServerCore.dll

Client
|
| RPC Call
|
RPC Server (RPCServerCore.dll)
|
| Load Plugin
|
Plugin DLL

Excel VBA
|
CallRPC("Unique",[1,2,3])
|
RPC Server
|
MathPlugin.dll
|
Unique()

function PluginName(const P: array of Variant): Variant; stdcall;

function AveragePlugin(const P: array of Variant): Variant; stdcall;
var
I: Integer;
S: Double;
begin
for I := 0 to High(P) do
S := S + VarAsType(P[I], varDouble);

Result := S / Length(P);
end;

exports
AveragePlugin name 'Average';

function UniquePlugin(const P: array of Variant): Variant; stdcall;
var
Dict: TDictionary<Variant, Byte>;
List: TList<Variant>;
I: Integer;
OutArr: Variant;
begin

Dict := TDictionary<Variant, Byte>.Create;
List := TList<Variant>.Create;

try
for I := 0 to High(P) do
if not Dict.ContainsKey(P[I]) then
begin
Dict.Add(P[I],0);
List.Add(P[I]);
end;

OutArr := VarArrayCreate([1, List.Count, 1, 1], varVariant);

for I := 0 to List.Count - 1 do
  OutArr[I + 1,1] := List[I];

Result := OutArr;

finally
Dict.Free;
List.Free;
end;

end;

Sub TestUnique()

Dim V As Variant

V = CallRPC("Unique", "[1,2,3,3,5,5,7,8,8]")

If VarType(V) = vbString Then
Debug.Print V
Exit Sub
End If

If IsArray(V) Then
Sheet1.Range("A1").Resize(UBound(V, 1), 1).Value = V
End If

End Sub

1
2
3
5
7
8

Private Function RangeToRPCArray(r As Range) As String

Dim V As Variant
Dim rr As Long, c As Long
Dim S As String

V = r.Value

S = "["

For rr = 1 To UBound(V, 1)

For c = 1 To UBound(V, 2)

    If Len(V(rr, c)) > 0 Then
        S = S & V(rr, c) & ","
    End If

Next c

Next rr

If Right$(S, 1) = "," Then
S = Left$(S, Len(S) - 1)
End If

S = S & "]"

RangeToRPCArray = S

End Function

CallRPC("GetRsFromServer","SELECT * FROM Customers")

RPCServer.exe

Windows Service

RPCServerService.exe

RPCServer.exe
hoặc
Windows Service

procedure RPC_SetLogCallback(LogProc: TRPCLogProc); stdcall;

procedure RPC_EnableLogLevel(Level: Integer; Enabled: BOOL); stdcall;

function RPC_GetRecentLogs: PWideChar; stdcall;

function RPC_GetRecentLogsV: OleVariant; stdcall;

procedure RPC_ClearLogs; stdcall;

Option Explicit
'=========================================================
' RPC Excel Client Module
'
' Author  : Kieu Manh
' Country : Vietnam
'
' Description
' High Performance RPC Client for Excel
'
' Features
' - RPC Query
' - Recordset ? Array
' - Excel Write Engine
' - Query Cache
' - Dashboard Refresh
'
'=========================================================
'---------------------------------------------------------
' RPC SERVER CONFIG
'---------------------------------------------------------
Public Const RPC_IP As String = "127.0.0.1"
Public Const RPC_PORT As Long = 9000
Public Const RPC_DLL As String = "AccessPlugin.dll"
Public Const RPC_FUNC As String = "GETRS"
Public Const RPC_DB As String = "C:\Database_Server\QLBHPN.accdb"
'---------------------------------------------------------
' CACHE ENGINE
'---------------------------------------------------------
Private RPCCache As Object

Private Sub RPCInitCache()
    If RPCCache Is Nothing Then
        Set RPCCache = CreateObject("Scripting.Dictionary")
    End If
End Sub

Public Sub RPCClearCache()
    RPCInitCache
    RPCCache.RemoveAll
End Sub
'---------------------------------------------------------
' RPC CALL
'---------------------------------------------------------
Public Function RPCGetRS(SQL As String) As Object
    On Error GoTo ERR_HANDLER
    Set RPCGetRS = RPC_GetRecordset( _
                        RPC_IP, _
                        RPC_PORT, _
                        RPC_DLL, _
                        RPC_FUNC, _
                        RPC_DB, _
                        SQL)

    Exit Function
ERR_HANDLER:
    MsgBox "RPC Error:" & vbCrLf & _
           Err.Description, _
           vbCritical, _
           "RPC Error"
    Set RPCGetRS = Nothing
End Function
'---------------------------------------------------------
' RECORDSET ? ARRAY
'---------------------------------------------------------
 Public Function RS2Array(RS As Object, Optional Header As Boolean = True)
    Dim Data
    Dim Arr()
    Dim ColNames()
    Dim r As Long
    Dim c As Long
    Dim Rows As Long
    Dim Cols As Long
    Dim Offset As Long

    If RS Is Nothing Then
        RS2Array = CVErr(xlErrNA)
        Exit Function
    End If

    If RS.EOF Then
        RS2Array = ""
        Exit Function
    End If

    ' Lưu tên c?t
    If Header Then
        ReDim ColNames(0 To RS.Fields.Count - 1)
        For c = 0 To RS.Fields.Count - 1
            ColNames(c) = RS.Fields(c).Name
        Next c
    End If

    ' L?y d? li?u nhanh
    Data = RS.GetRows

    RS.Close
    Set RS = Nothing

    Cols = UBound(Data, 1) + 1
    Rows = UBound(Data, 2) + 1

    If Header Then
        Offset = 1
    Else
        Offset = 0
    End If

    ReDim Arr(0 To Rows - 1 + Offset, 0 To Cols - 1)

    ' Header
    If Header Then
        For c = 0 To Cols - 1
            Arr(0, c) = ColNames(c)
        Next c
    End If

    ' Data
    For r = 0 To Rows - 1
        For c = 0 To Cols - 1
            Arr(r + Offset, c) = Data(c, r)
        Next c
    Next r
    RS2Array = Arr
End Function

'---------------------------------------------------------
' SIMPLE RPC QUERY
'
' Example
' =RPC("SELECT * FROM Orders")
'---------------------------------------------------------
Public Function RPC(SQL As String)
    Dim RS As Object
    Set RS = RPCGetRS(SQL)
    RPC = RS2Array(RS, True)
End Function
'---------------------------------------------------------
' CACHE QUERY
'
' Example
' =RPC_CACHE("SELECT * FROM Orders")
' =RPC_CACHE("SELECT * FROM NhapXuatTon")
'---------------------------------------------------------
Public Function RPC_CACHE(SQL As String)
    Dim RS As Object
    Dim Arr
    Dim Key As String
    RPCInitCache
    Key = RPC_DB & "|" & SQL
    If RPCCache.Exists(Key) Then
        RPC_CACHE = RPCCache(Key)
        Exit Function
    End If

    Set RS = RPCGetRS(SQL)
    Arr = RS2Array(RS, True)
    RPCCache.Add Key, Arr
    RPC_CACHE = Arr
End Function
'---------------------------------------------------------
' EXECUTE SQL ? WRITE TO SHEET
'
' Example
' RPCExec "SELECT * FROM Orders", Range("A1")
'---------------------------------------------------------
Public Sub RPCExec(SQL As String, Target As Range)
    Dim RS As Object
    Dim Arr
    Dim Rows As Long
    Dim Cols As Long
    Application.ScreenUpdating = False
    Set RS = RPCGetRS(SQL)
    Arr = RS2Array(RS, True)
    If IsArray(Arr) = False Then Exit Sub

    Rows = UBound(Arr, 1) + 1
    Cols = UBound(Arr, 2) + 1


    Target.Resize(Rows, Cols).Clear
    Target.Resize(Rows, Cols).Value = Arr
    Application.ScreenUpdating = True
End Sub

'---------------------------------------------------------
' DASHBOARD REFRESH
'---------------------------------------------------------
Public Sub RPCRefresh()
    Application.CalculateFull
End Sub
Public Sub RPCRefreshCache()
    RPCClearCache
    Application.CalculateFull
End Sub

'---------------------------------------------------------
' BIG DATA LOADER
'
' Example
' RPC_BIGLOAD "SELECT * FROM Sales", Range("A1")
'---------------------------------------------------------
Public Sub RPC_BIGLOAD(SQL As String, Target As Range)
    Dim T As Double
    T = Timer
    RPCExec SQL, Target
    MsgBox "Load completed in " & _
           Format(Timer - T, "0.00") & _
           " seconds"
End Sub

Public Declare PtrSafe Function RPC_VariantExecute Lib "RPCServerCore.dll" ( _
ByVal Host As Variant, _
ByVal Port As Long, _
ByVal DLLName As Variant, _
ByVal FuncName As Variant, _
ByVal Params As Variant _
) As Variant

"127.0.0.1"

9000

"MathPlugin.dll"

"Unique"
"Average"

[value1,value2,value3]

"[1,2,3,4]"
"[10,20,30]"

#RPC_ERROR: message

Sub TestUnique()
    Dim V As Variant
    V = CallRPC("Unique", "[1,2,3,3,5,5,7,8,8]")
    Sheet2.Cells.Clear
    Sheet2.Range("A1").Resize(UBound(V, 1), 1).Value = V
End Sub

[1,2,3,4,5,6]

Range.Resize(...).Value = V

RPC_VariantExecute(...)

Option Explicit

'=========================================================
' modRPCClientCore
'
' RPC Excel Client Core Module
'
' Module nay cung cap cac ham co ban de Excel VBA
' goi ham tren RPC Server thong qua RPCServerCore.dll
'
' Bao gom:
'   - Khai bao API RPC_VariantExecute
'   - Cau hinh RPC Server
'   - Ham goi RPC tong quat
'   - Ham chuyen Excel Range -> RPC Array
'
' Author : Kieu Manh
'=========================================================


'=========================================================
' RPC API
'=========================================================
'
' RPC_VariantExecute
'
' Goi ham trong Plugin DLL tren RPC Server
' thong qua TCP Socket.
'
' Params phai dang chuoi mang:
'   "[1,2,3]"
'
' Ket qua tra ve Variant:
'   - Gia tri don
'   - Mang 1 chieu
'   - Mang 2 chieu
'
' Neu loi:
'   "#RPC_ERROR: message"
'=========================================================
Public Declare PtrSafe Function RPC_VariantExecute Lib "RPCServerCore.dll" ( _
            ByVal Host As Variant, _
            ByVal Port As Long, _
            ByVal DLLName As Variant, _
            ByVal FuncName As Variant, _
            ByVal Params As Variant _
    ) As Variant

'=========================================================
' RPC CONFIG
'=========================================================
Public Const RPC_HOST As String = "127.0.0.1"
Public Const RPC_PORT As Long = 9000
Public Const RPC_DLL As String = "MathPlugin.dll"
'=========================================================
' GENERIC RPC CALL
'
' FuncName
'   Ten ham trong Plugin DLL
'
' Params
'   Chuoi tham so dang mang
'   Vi du:
'       "[1,2,3]"
'=========================================================
Public Function CallRPC(FuncName As String, Params As String) As Variant
    On Error GoTo ERR_HANDLER
    CallRPC = RPC_VariantExecute( _
                    RPC_HOST, _
                    RPC_PORT, _
                    RPC_DLL, _
                    FuncName, _
                    Params)

    Exit Function
ERR_HANDLER:
    CallRPC = "#VBA_ERROR: " & Err.Description
End Function


'=========================================================
' RANGE -> RPC ARRAY STRING
'
' Chuyen du lieu tu Excel Range thanh chuoi RPC
'
' Vi du:
'
' Excel Range:
'   1   2
'   3   4
'
' RPC Params:
'   "[1,2,3,4]"
'=========================================================
Public Function RangeToRPCArray(Rng As Range) As String
    Dim V As Variant
    Dim i As Long, j As Long
    Dim S As String

    V = Rng.Value

    S = "["

    For i = 1 To UBound(V, 1)
        For j = 1 To UBound(V, 2)

            If Len(V(i, j)) > 0 Then
                S = S & V(i, j) & ","
            End If

        Next j
    Next i

    If Right$(S, 1) = "," Then
        S = Left$(S, Len(S) - 1)
    End If

    S = S & "]"
    RangeToRPCArray = S
End Function

A1=RPCUniqueRange(A1:B24)

'=========================================================
' HAM UNIQUE TU RANGE (GO TRUC TIEP TRONG CELL)
'
' Vi du su dung trong Excel:
'
'   =RPCUniqueRange(A1:B24)
'
' Ham se:
'   - Chuyen du lieu Range thanh chuoi RPC
'   - Goi ham Unique tren RPC Server
'   - Tra ve mang ket qua cho Excel
'
' Excel se tu dong do ket qua xuong cac dong
'=========================================================
Function RPCUniqueRange(Rng As Range) As Variant
    Dim Payload As String
    Dim V As Variant

    On Error GoTo ERR_HANDLER

    ' Chuyen Range thanh chuoi RPC
    Payload = RangeToRPCArray(Rng)

    ' Goi ham Unique tren RPC Server
    V = CallRPC("Unique", Payload)

    ' Neu server tra ve chuoi loi
    If VarType(V) = vbString Then
        RPCUniqueRange = V
        Exit Function
    End If

    ' Tra ket qua ve Excel
    RPCUniqueRange = V

    Exit Function

ERR_HANDLER:
    RPCUniqueRange = "#VBA_ERROR: " & Err.Description
End Function