Navigation

   Hej alle,
Jeg har et ark, som indeholder fortrolige oplysninger, som bruges af diverse ansatte på mit arbejde. Udfordringen ligger i, at når medarbejderen forlader jobbet, skal arket f.eks. ikke kunne tages med over til en konkurrent.
Jeg tænker andre virksomheder må have samme udfordring - og måske en af jer, allerede ligger inde med en løsning på dette?

Jeg har selv tænkt følgende:
Når arket åbnes, laves en kontrol af brugeren (windows-login). Hvis brugeren er i en defineret liste, sendes en mail, med password til at åbne filen. Findes brugeren ikke, lukkes filen. Grunden til denne tanke, er at vi altid kan lukke for adgangen til en tidligere ansats email-konto. Dermed vil de ikke kunne åbne den, selvom den er gemt lokalt.

Jeg har selv forsøgt at sætte nedenstående koder sammen og det virker sådan set efter hensigten.
Arket har det bare med at "fryse", så jeg har på fornemmelsen der er noget kode som ikke kører/bliver afsluttet optimalt/korrekt.
Jeg er ikke en haj i VBA, så håber der er en som vil se koden igennem, om den evt. kan optimeres.

/Skovgaard

Module1 (Tjek bruger og password):

Sub CheckUser()

Dim strUser As String
Dim strUserName As Variant
Dim strEmail As Variant
Const Quotes As String = """"
Dim SendOK As Integer

Application.ScreenUpdating = False
Worksheets("Users").Visible = True

strUser = Environ$("UserName") 'Windows user login
strUserName = Application.VLookup(strUser, Worksheets("Users").Range("A:C"), 2, False)
strUserEmail = Application.VLookup(strUser, Worksheets("Users").Range("A:C"), 3, False)

If IsError(strUserName) Then 'Check if user is in list
    MsgBox "User " & Quotes & strUser & Quotes & " is not authorized to open this file." _
            & vbNewLine & vbNewLine & "Please contact Administrator."
    End
Else
    SendOK = MsgBox("Hi " & strUserName _
            & vbNewLine & vbNewLine _
            & "Press OK to send password to open this file" _
            & vbNewLine & vbNewLine _
            & "Password will be sent to " & strUserEmail, vbOKCancel)
    If SendOK = vbCancel Then
        Worksheets("Users").Visible = xlSheetVeryHidden
        Application.ScreenUpdating = True
        End
    Else
        Sheets("Users").Range("E2").FormulaR1C1 = "=RANDBETWEEN(1000000,9999999)"
        Sheets("Users").Range("E2").Copy
        Sheets("Users").Range("E2").PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False

        Call send_email
    End If

End If

End Sub

Sub CheckPassword()

Dim strUser As String
Dim strUserName As Variant
Const Quotes As String = """"
Dim Password As String

strUser = Environ$("UserName")
strUserName = Application.VLookup(strUser, Worksheets("Users").Range("A:C"), 2, False)

Password = InputBox("Type password received on your email")

If Password = Worksheets("Users").Cells(2, 5) Then
    MsgBox "Correct password" _
            & vbNewLine & vbNewLine _
            & "Press OK to continue"
    Worksheets("Users").Visible = xlSheetVeryHidden
    Worksheets("Sheet2").Visible = True
    Worksheets("Sheet2").Activate
Else
    MsgBox "Wrong Password"
    Worksheets("Users").Visible = xlSheetVeryHidden
    Application.ScreenUpdating = True
    ActiveWorkbook.Close SaveChanges:=False
    End
End If

Application.ScreenUpdating = True

End Sub

Module2 (Send password på mail):

Sub send_email()

Dim NewMail As Object
Dim MailConfig As Object
Dim SMTP_Config As Variant
Dim strSubject As String
Dim strFrom As String
Dim strTo As String
Dim strCc As String
Dim strBcc As String
Dim strBody As String
Dim strUser As String

strUser = Environ$("UserName")
strSubject = "Password Generated"
strFrom = "???@gmail.com" 'Sender email-adress
strTo = Application.VLookup(strUser, Worksheets("Users").Range("A:C"), 3, False)
strCc = ""
strBcc = ""
strBody = "Password to open file: " & Worksheets("Users").Cells(2, 5)

Set NewMail = CreateObject("CDO.Message")
Set MailConfig = CreateObject("CDO.Configuration")

MailConfig.Load -1

Set Fields = MailConfig.Fields

    msConfigURL = "http://schemas.microsoft.com/cdo/configuration"

    With Fields
        'Enable SSL Authentication
        .Item(msConfigURL & "/smtpusessl") = True

        'Make SMTP authentication Enabled=true (1)
        .Item(msConfigURL & "/smtpauthenticate") = 1

        'Set the SMTP server and port Details
        'To get these details you can get on Settings Page of your Gmail Account
        .Item(msConfigURL & "/smtpserver") = "smtp.gmail.com"
        .Item(msConfigURL & "/smtpserverport") = 465
        .Item(msConfigURL & "/sendusing") = 2

        'Set your credentials of your Gmail Account
        .Item(msConfigURL & "/sendusername") = "???@gmail.com" 'Sender email-adress
        .Item(msConfigURL & "/sendpassword") = "???" 'Password to Gmail-account

        'Update the configuration fields
        .Update

    End With
    NewMail.Configuration = MailConfig
    NewMail.Subject = strSubject
    NewMail.From = strFrom
    NewMail.To = strTo
    NewMail.TextBody = strBody
    NewMail.CC = strCc
    NewMail.BCC = strBcc
    NewMail.Send
    MsgBox ("Password has been sent")

Call CheckPassword

Exit_Err:

    Worksheets("Users").Visible = xlSheetVeryHidden

    Set NewMail = Nothing
    Set MailConfig = Nothing
    End

Err:

    Worksheets("Users").Visible = xlSheetVeryHidden

    Select Case Err.Number

    Case -2147220973  'Could be because of Internet Connection
        MsgBox " Could be no Internet Connection !!  -- " & Err.Description

    Case -2147220975  'Incorrect credentials User ID or password
        MsgBox "Incorrect Credentials !!  -- " & Err.Description

    Case Else   'Rest other errors
        MsgBox "Error occured while sending the email !!  -- " & Err.Description
    End Select

    Resume Exit_Err

With NewMail
 Set .Configuration = MailConfig
End With

Error_Handling:
If Err.Description <> "" Then MsgBox Err.Description

Application.ScreenUpdating = True

End Sub

Navigation

Beskyttelse af data