Lập trình VBA tạo giao diện máy khách kết nối máy chủ Add-in A-Tools đẹp!

[Nguyễn Duy Tuân]

Mã nguồn VBA chia sẻ trong video này bạn sẽ thấy phương pháp lập trình VBA chuyên nghiệp, các controls trong BSAC phối hợp để tạo ra giao diện phần mềm đẹp như tây được lập trình trên các ngôn ngữ hiện đại. Kết hợp thư viện lập trình BSNetwork cho phép bạn giao tiếp với máy chủ, liệt kê danh sách các file, sheet Excel trên máy chủ để mở mà không phụ thuộc vào menu A-Tools.
Đây là ví dụ đầu tiên tôi viết kết hợp hai thành phần được cài chung trong bộ cài Add-in A-Tools: #BSAC.ocx, AddinATools.dll. Các controls: #BSListView, #BSImageList, #BSEdit, #BSTaskPaneX, #BSNetwork.

Option Explicit
'Author: Nguyen Duy Tuan - http://bluesofts.net
'Facebook: https://www.facebook.com/groups/hocexcel
Private WithEvents xnet As BSNetwork

Private Sub UserForm_Initialize()
    'Userform.ShowModal = False
    'Setup buttons with image/icon
    Set cmdConnect.ImageList = BSImageList1
    cmdConnect.ImageIndex = 0
    Set cmdOpenRange.ImageList = BSImageList1
    cmdOpenRange.ImageIndex = 2
    'Setup BSListView
    BSListView1.Columns.Add UNC("Range/Sheet tõ m¸y chñ")
    BSListView1.Columns(0).Width = BSListView1.nWidth - 18
    BSListView1.View = vsReport
    BSListView1.ReadOnly = True
    BSListView1.GroupView = True
    Set BSListView1.ImageList = BSImageList1
    'Task Pane
    BSTaskPaneX1.Create Me
End Sub

Private Sub cmdConnect_OnClick()
    DoConnect
End Sub

Sub DoConnect()
    On Error GoTo lbEndSub
    If Not xnet Is Nothing Then
        If xnet.Connected Then 'if connecting then disonnect
            DoDisconnect
            Exit Sub
        End If
        Set xnet = Nothing
    End If
    Set xnet = New BSNetwork
    xnet.Connect txtServer.Text, txtUser.Text, txtPassword.Text
    Exit Sub
lbEndSub:
    If Err <> 0 Then
        MsgBoxW Err.Description, vbCritical, "Connect", strUNICODE
        UpdateView
    End If
End Sub

Sub DoDisconnect()
    If Not xnet Is Nothing Then
        xnet.Disconnect
        Set xnet = Nothing
    End If
End Sub

'xnet_OnConnect: run when A-Tools connect to server
Private Sub xnet_OnConnect(ByVal User As AddinATools.BSUser)
    UpdateListRange
    UpdateView
End Sub
'xnet_OnDisconnect: run when A-Tools disconnect from server
Private Sub xnet_OnDisconnect(ByVal User As AddinATools.BSUser)
    ClearList
    UpdateView
End Sub
'xnet_OnProgress: run when A-Tools connect or open range
Private Sub xnet_OnProgress(ByVal State As AddinATools.BSProgressState, _
                            ByVal PositionValue As Variant, _
                            ByVal MaxValue As Variant, _
                            Cancel As Boolean, _
                            DefaultForm As Boolean)
    If (State = psPrepare) Then
         DefaultForm = False
         BSProgressBar1.Visible = True
         BSProgressBar1.Style = pbstMarquee
     ElseIf (State = psBegin) Then
         BSProgressBar1.Style = pbstNormal
         BSProgressBar1.Max = MaxValue
     ElseIf (State = psRunning) Then
         'BSProgressBar1.Maximum = MaxValue
         BSProgressBar1.Position = PositionValue
         'BSProgressBar1.Invalidate()
     ElseIf (State = psFinished) Then
         BSProgressBar1.Visible = False
    End If
End Sub

Function UpdateListRange()
    BSListView1.Items.BeginUpdate
    BSListView1.Items.Clear
    Dim db As BSDatabase, ur As BSUserRange
    Dim GroupIdx As Long, lvit As BSListItem
    'Display progress when loading database info
    BSProgressBar1.Max = xnet.Databases.Count
    BSProgressBar1.Position = 0
    BSProgressBar1.Style = pbstNormal
    BSProgressBar1.Visible = True
    '-------
    For Each db In xnet.Databases
        'Create group header that display by UCase(db.Name);
        'key=db.Name for open range later
        BSProgressBar1.Position = BSProgressBar1.Position + 1 'progress running
        GroupIdx = BSListView1.Groups.Add(UCase(db.Name), , db.Name).GroupID
        db.UserRanges.Update
        For Each ur In db.UserRanges
            Set lvit = BSListView1.Items.Add(ur.Name)
            lvit.GroupID = GroupIdx 'group by database/workbook name
            lvit.ImageIndex = 1 'get icon from BSImageList
        Next
    Next
    BSListView1.Items.EndUpdate
    'BSListView1.AutoColumns
    BSProgressBar1.Visible = False
    UpdateListRange = BSListView1.Items.Count
End Function

Sub ClearList()
    BSListView1.Items.Clear
    cmdOpenRange.Enabled = False
End Sub

Sub UpdateView()
    BSProgressBar1.Visible = False
    If Not xnet Is Nothing Then
        frmConnectInfo.Visible = Not xnet.Connected
    Else
        frmConnectInfo.Visible = True
    End If
    frmImage.Visible = Not frmConnectInfo.Visible
    'if frmImage.Visible=True =>xNet.Connected = True
    cmdConnect.Text = IIf(frmImage.Visible, UNC("Ng¾t kÕt nèi"), UNC("KÕt nèi"))
    cmdOpenRange.Enabled = frmImage.Visible And (BSListView1.Items.Count > 0)
    'UserForm_Resize
End Sub

Private Sub cmdOpenRange_OnClick()
    Dim lvit As BSListItem
    Dim db As BSDatabase, sDbName As String
    If Not xnet Is Nothing Then
        If xnet.Connected Then
            Set lvit = BSListView1.Selected
            sDbName = BSListView1.Groups(lvit.GroupID).Key
            Set db = xnet.Databases(sDbName)
            db.UserRanges.Open lvit.Text 'Open range from database
        End If
    End If
End Sub

Private Sub BSListView1_OnItemDblClick(ByVal Item As BSAC.BSListItem)
    cmdOpenRange_OnClick
End Sub

Private Sub UserForm_Resize()
    On Error Resume Next
    'Adjust BSListView1
    BSListView1.Height = Height - BSListView1.Top - 2
    BSListView1.Width = Width - BSListView1.Left * 2 'margin: 2
    'Adjust width of frames: frmConnectInfo, frmImage
    frmConnectInfo.Width = Width - frmConnectInfo.Left * 2
    frmImage.Width = Width - frmImage.Left * 2
    'BSImage center
    BSImage1.Left = (Width - BSImage1.Width) / 2
    'Adjust BSEdit in frame
    txtServer.Width = frmConnectInfo.Width - _
                      (frmConnectInfo.Left + txtServer.Left) - 10
    txtUser.Width = txtServer.Width
    txtPassword.Width = txtServer.Width
    'Adjust buttons is center
    Dim w As Single 'Width of 2 buttons
    Dim Delta As Single 'from button1 -> button2
    w = cmdOpenRange.Left + cmdOpenRange.Width - cmdConnect.Left
    Delta = cmdOpenRange.Left - (cmdConnect.Left + cmdConnect.Width)
    cmdConnect.Left = (Width - w) / 2
    cmdOpenRange.Left = cmdConnect.Left + cmdConnect.Width + Delta
End Sub

(*) File Excel với mã nguồn: https://drive.google.com/file/d/1oH88I7HDP0yEXkheixNHjHMNWm3Z8qJ7/view?usp=sharing