Excel VBA 用户表单在服务器上使用用户名和密码登录

Question

I have a userform where the user can enter username and password. I found the code here Excel VBA & UserForm Login and Password VLOOKUP Table in Sheet

Private Sub LogIn_Click()
    Dim Username As String
    Dim Password As String
    Dim passWs As Worksheet
    Dim lRow As String
    Dim rng As Range
    Dim CorrectDetails As Boolean
    Dim i As Integer


    Username = Me.Username.Text

    Password = Me.Password.Text

    If Len(Trim(Username)) = 0 Then
        Me.Username.SetFocus
        MsgBox "Username", vbOKOnly, "Username"
        Exit Sub
    End If

    If Len(Trim(Password)) = 0 Then
        Me.Password.SetFocus
        MsgBox "Password", vbOKOnly, "Password"
        Exit Sub
    End If

    Set passWs = ThisWorkbook.Worksheets("Users")

    With passWs
        lRow = .Range("B" & .Rows.Count).End(xlUp).Row

        For i = 1 To lRow
            If UCase(Trim(.Range("B" & i).Value)) = UCase(Trim(Username)) Then '<~~ Username Check
                If .Range("C" & i).Value = Password Then '<~~ Password Check
                    CorrectDetails = True
                    Unload Me
                    MsgBox "Välkommen " & Username


                    Sheets("Start").Activate

                    '~~> Admin is True
                    If .Range("D" & i).Value = "True" Then
                        '
                        '~~> Do what you want
                        '
                    Else
                        '
                        '~~> Do what you want
                        '
                    End If

                    Exit For
                End If
            End If
        Next i

        '~~> Incorrect Username/Password
        If CorrectDetails = False Then
            MsgBox "Felaktivt användarnamn och/eller lösenord"
        End If
    End With
End Sub

I also have a function I found at https://www.ozgrid.com/forum/forum/help-forums/excel-general/86714-vba-read-text-file-from-a-url

Function GetFromWebpage(URL As String) As String
On Error GoTo Err_GetFromWebpage

Dim objWeb As Object
Dim strXML As String

' Instantiate an instance of the web object
Set objWeb = CreateObject("Microsoft.XMLHTTP")

' Pass the URL to the web object, and send the request
objWeb.Open "GET", URL, False
objWeb.send

' Look at the HTML string returned
strXML = objWeb.responsetext

GetFromWebpage = strXML


End_GetFromWebpage:
' Clean up after ourselves!
Set objWeb = Nothing
Exit Function

Err_GetFromWebpage:
' Just in case there's an error!
MsgBox Err.Description & " (" & Err.Number & ")"
Resume End_GetFromWebpage
End Function

And the function is called:

Sub MainSub()
Dim MyString As String, s As String

MyString = GetFromWebpage("http://127.0.0.1/test3.csv")

s = MyString
Debug.Print s
End sub

The contents of my .csv file is:

Username;Password
User1;123
User2;333

I am trying to split mystring into username and password pairs and then check in my login form if the username and password entered is the same as on the server.

Answer 1

To help you with the obtaining the usernames and passwords part:

You could use the text to columns functionality in Excel to split into two columns and then loop those. However, I would read the CSV column A info into an array and then loop the array. Use the Split function with delimiter ";"to generate your pairs, assign the values from the split to password and username variables and then use those for your testing.

Example that needs adapting below:

Option Explicit
Public Sub test()
    Dim ws As Worksheet, loginDetails(), currentLogin As Long, pairs() As String, lastRow As Long
    Set ws = Workbooks("name of CSV").Worksheets("Sheet1")   '<==change this to the open CSV name
    Dim pword As String, username As String
    With ws
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        If lastRow = 1 Then                      '<change to 2 if header present
            ReDim loginDetails(1, 1): loginDetails(1, 1) = .Range("A1").Value '<= change this to A2 if header
        Else
            loginDetails = .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value 'Change to A2: if header present
        End If
        For currentLogin = LBound(loginDetails, 1) To UBound(loginDetails, 1)
            pword = vbNullString: username = vbNullString
            If InStr(loginDetails(currentLogin, 1), ";") > 0 Then
                pairs = Split(loginDetails(currentLogin, 1), ";")
                username = pairs(0)
                pword = pairs(1)
                'Debug.Print username, pword
                'other code to test login

            End If
        Next
    End With
End Sub