|
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" rel="nofollow - 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
|