Set Password cho macro

[cang95166]

Xin chào các bạn,
Cho mình hỏi khi bấm phím gọi macro chạy thì trước khi chạy yêu cầu nhập Password
cám ơn các bạn

 

[Po_Pikachu]

Bạn dùng thử code sau thì sẽ hiểu thôi!

Sub chay()
If InputBox("Nhap pass:", "Login") = "ABC" Then
MsgBox ("Chay code")    '<- phan nay la code cua ban
Else
If MsgBox("Xin loi pass ko hop le. Ban co muon thu lai ko?", vbOKCancel) = vbOK Then chay
End If
End Sub

Hoặc viết như vầy hay hơn.

Sub chay()
Dim k As String
k = Application.InputBox("Nhap pass:", "Login")
If k = False Then Exit Sub
If k = "ABC" Then
MsgBox ("Chay code")    '<- phan nay la code cua ban
Else
If MsgBox("Xin loi pass ko hop le. Ban co muon thu lai ko?", vbOKCancel) = vbOK Then chay
End If
End Sub

Thân.

 

[cang95166]

cám ơn bạn rất nhiều,tôi đã thử và chạy được rồi.Bạn cho tôi hỏi thêm khi gõ Pass thì có cách nào cho nó chị hiện ra các dấu *** không hả bạn
cám ơn bạn

 

[ndu96081631]

cám ơn bạn rất nhiều,tôi đã thử và chạy được rồi.Bạn cho tôi hỏi thêm khi gõ Pass thì có cách nào cho nó chị hiện ra các dấu *** không hả bạn
cám ơn bạn

Không biết InputBox có làm được việc này không (nếu được chắc cũng không dể!
Vậy bạn có 2 cách chọn:
- Dùng UserForm với TextBox là chổ cho bạn gõ pass (TextBox có thuộc tính PasswordChar cho phép ẩn pass thành dấu *)
- Dùng EditBox của DialogSheet cũng có chức năng này

 

[ptlong04x1]

Không biết InputBox có làm được việc này không (nếu được chắc cũng không dể!
Vậy bạn có 2 cách chọn:
- Dùng UserForm với TextBox là chổ cho bạn gõ pass (TextBox có thuộc tính PasswordChar cho phép ẩn pass thành dấu *)
- Dùng EditBox của DialogSheet cũng có chức năng này

Em mới search ra cái này, dùng được nhưng mà nhìn code thấy

Option Explicit
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, _
                                                      ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _
                                          (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, _
                                          ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" _
                                            (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, _
                                            ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, _
                                                                          ByVal lpClassName As String, _
                                                                          ByVal nMaxCount As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Const EM_SETPASSWORDCHAR = &HCC
Private Const WH_CBT = 5
Private Const HCBT_ACTIVATE = 5
Private Const HC_ACTION = 0
Private hHook As Long

Public Function NewProc(ByVal lngCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim RetVal
    Dim strClassName As String, lngBuffer As Long
    If lngCode < HC_ACTION Then
        NewProc = CallNextHookEx(hHook, lngCode, wParam, lParam)
        Exit Function
    End If
    strClassName = String$(256, " ")
    lngBuffer = 255
    If lngCode = HCBT_ACTIVATE Then
        RetVal = GetClassName(wParam, strClassName, lngBuffer)
        If Left$(strClassName, RetVal) = "#32770" Then
            SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc("*"), &H0
        End If
    End If
    CallNextHookEx hHook, lngCode, wParam, lParam
End Function
Public Function InputBoxDK(Prompt, Optional Title, Optional Default, Optional XPos, _
                        Optional YPos, Optional HelpFile, Optional Context) As String
    Dim lngModHwnd As Long, lngThreadID As Long
    lngThreadID = GetCurrentThreadId
    lngModHwnd = GetModuleHandle(vbNullString)
    hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID)
    InputBoxDK = InputBox(Prompt, Title, Default, XPos, YPos, HelpFile, Context)
    UnhookWindowsHookEx hHook
End Function
Sub Test()
    Dim st As String
    st = InputBoxDK("Nhap pass : ")
    MsgBox "Pass : " & st
End Sub

 

[thuyyeu99]

Em có tìm thấy trên mạng cái này cũng hay (In phut Box Unicode và pass * )
Code

    'InputBox ho tro xuat nhap du lieu Unicode co ho tro password
    'Tac gia: Tran Dai Nghia (Giang Ho)
    'Email: gianghopphoenix@yahoo.com
    'Website: http://www.giangho.biz; http://www.caulacbovb.com
    'Ngay viet: 19/05/2008
    '---------------------------------------------------------
   
    Private Const GWL_WNDPROC = (-4&)
    Private Const WH_CBT As Long = &H5
   Private Const HCBT_ACTIVATE As Long = &H5
   Public Const WM_SETTEXT = &HC
   Public Const WM_SETFONT = &H30
   Public Const NV_INPUTBOX As Long = &H5000&
   Private Const EM_SETPASSWORDCHAR = &HCC
  
   Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal H As Long, ByVal w As Long, ByVal E As Long, ByVal O As Long, ByVal w As Long, ByVal i As Long, ByVal U As Long, ByVal s As Long, ByVal C As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, ByVal f As String) As Long
   Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd&, ByVal nIndex&, ByVal dwNewLong&) As Long
   Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hMod As Long, ByVal dwThreadId As Long) As Long
   Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal CodeNo As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
   Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
   Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
   Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal ParenthWnd As Long, ByVal ChildhWnd As Long, ByVal ClassName As String, ByVal Caption As String) As Long
   Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
   Public Declare Function MessageBoxW Lib "user32.dll" (ByVal hwnd As Long, ByVal lpText As Long, ByVal lpCaption As Long, ByVal uType As Long) As Long
   Private Declare Function SetWindowTextW Lib "user32" (ByVal hwnd As Long, ByVal lpString As Long) As Long
   Private Declare Function DefWindowProcW Lib "user32" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
   Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
   Public Declare Function GetWindowTextW Lib "user32.dll" (ByVal hwnd As Long, ByVal lpString As Long, ByVal cch As Long) As Long
   Public Declare Function GetWindowTextLengthW Lib "user32" (ByVal hwnd As Long) As Long
   Private Declare Function SetTimer& Lib "user32" (ByVal hwnd&, ByVal nIDEvent&, ByVal uElapse&, ByVal lpTimerFunc&)
   Private Declare Function KillTimer& Lib "user32" (ByVal hwnd&, ByVal nIDEvent&)
   Public Declare Sub InitCommonControls Lib "comctl32.dll" ()
  
   Private pHook2 As Long, pHook3 As Long, hEdit As Long, hIdEvent As Long, UsePass As Boolean
   Private sStatic As String, sDefault As String, sTitle As String, sInput As String, txt As String
  
  Private Function InputHookProc(ByVal ncode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  Dim hStatic1 As Long, hStatic2 As Long, hButton As Long, hFont As Long
  InputHookProc = CallNextHookEx(pHook2, ncode, wParam, lParam)
  If ncode = HCBT_ACTIVATE Then
     hFont = CreateFont(13, 0, 0, 0, 500, 0, 0, 0, 0, 0, 0, 0, 0, "Tahoma")
 
     hStatic1 = FindWindowEx(wParam, 0&, "Static", vbNullString)
     hStatic2 = FindWindowEx(wParam, hStatic1, "Static", vbNullString)
     If hStatic2 = 0 Then hStatic2 = hStatic1
     SendMessage hStatic2, WM_SETFONT, hFont, ByVal 1&
     DefWindowProcW hStatic2, WM_SETTEXT, &H0&, StrPtr(sStatic)
     DefWindowProcW wParam, WM_SETTEXT, &H0&, StrPtr(sTitle)
 
     hButton = FindWindowEx(wParam, 0&, "Button", "OK")
     SendMessage hButton, WM_SETFONT, hFont, ByVal 1&
     DefWindowProcW hButton, WM_SETTEXT, &H0&, StrPtr("Xác nh" & ChrW(7853) & "n")
 
     hButton = FindWindowEx(wParam, 0&, "Button", "Cancel")
     SendMessage hButton, WM_SETFONT, hFont, ByVal 1&
     DefWindowProcW hButton, WM_SETTEXT, &H0&, StrPtr("H" & ChrW(7911) & "y b" & ChrW(7887))
 
      hEdit = FindWindowEx(wParam, 0&, "Edit", "")
      SendMessage hEdit, WM_SETFONT, hFont, ByVal 1&
 
      If sDefault <> "" Then
      SetWindowTextW hEdit, StrPtr(sDefault) 'Khong ho tro Tieng Viet o Input Textbox khi Style = Windows Classic
      SendKeys "+{END}" 'Select text
      End If
 
      If UsePass Then SendMessage hEdit, EM_SETPASSWORDCHAR, Asc("*"), 0
 
      UnhookWindowsHookEx pHook3
  End If
  End Function
 
  Public Function UniInputBox(ByVal Prompt As String, Optional ByVal Title As String = "", Optional ByVal Default As String = "", Optional ByVal Password As Boolean = False) As String
      pHook3 = SetWindowsHookEx(WH_CBT, AddressOf InputHookProc, Application.Hinstance, GetCurrentThreadId())
      UsePass = Password
      sStatic = VnToUni(Prompt)
      sDefault = VnToUni(Default)
      sTitle = VnToUni(Title)
      SetTimer 0, NV_INPUTBOX, 50, AddressOf TimerProc 'Lay du lieu Tieng Viet o Input Text Box
      txt = InputBox(sStatic, sTitle, sDefault)
      KillTimer 0, hIdEvent
      If txt <> "" Then UniInputBox = StripNulls(sInput)
  End Function
 
  Public Sub TimerProc(ByVal hwnd&, ByVal uMsg&, ByVal idEvent&, ByVal dwTime&)
  If hEdit <> 0 Then sInput = GetUniText(hEdit) 'Copy lien tuc ^^!
  hIdEvent = idEvent
  End Sub
 
  Private Function GetUniText(ByVal hwnd As Long) As String
  Dim lLen As Long, sBuf As String
  lLen = 1 + GetWindowTextLengthW(hwnd)
  If (lLen > 1) Then
      sBuf = String$(lLen, 0)
      GetWindowTextW hwnd, StrPtr(sBuf), lLen
      GetUniText = (sBuf)
  Else
      GetUniText = vbNullString
  End If
  End Function
 
  Private Function StripNulls(ByVal sString As String) As String
  Dim lPos As Long
      lPos = InStr(sString, vbNullChar)
      If (lPos = 1) Then
          StripNulls = vbNullString
      ElseIf (lPos > 1) Then
          StripNulls = Left$(sString, lPos - 1)
          Exit Function
      End If
      StripNulls = sString
  End Function
 
  'Code convert TCVN3 -> Unicode by TruongPhu
  Public Function VnToUni(str As String) As String
  Dim i&, arrUNI() As String, sUni$, ABC$, UNI$
  ABC = "¸µ¶·¹¨¾»¼½Æ©ÊÇÈÉËÐÌÎÏѪÕÒÓÔÖÝ×ØÜÞãßáâä«èåæçé¬íêëìîóïñòô­øõö÷ùýúûüþ®¸µ¶·¹¡¾»¼½Æ¢ÊÇÈÉËÐÌÎÏÑ£ÕÒÓÔÖÝ×ØÜÞãßáâä¤èåæçé¥íêëìîóïñòô¦øõö÷ùýúûüþ§"
  UNI = "225,224,7843,227,7841,259,7855,7857,7859,7861,7863,226,7845,7847,7849,7851,7853,233,232,7867,7869,7865,234,7871,7873,7875,7877,7879,237,236,7881,297,7883,243,242,7887,245,7885,244,7889,7891,7893,7895,7897,417,7899,7901,7903,7905,7907,250,249,7911,361,7909,432,7913,7915,7917,7919,7921,253,7923,7927,7929,7925,273,225,224,7843,227,7841,258,7855,7857,7859,7861,7863,194,7845,7847,7849,7851,7853,233,232,7867,7869,7865,202,7871,7873,7875,7877,7879,237,236,7881,297,7883,243,242,7887,245,7885,212,7889,7891,7893,7895,7897,416,7899,7901,7903,7905,7907,250,249,7911,361,7909,431,7913,7915,7917,7919,7921,253,7923,7927,7929,7925,272"
  arrUNI = Split(UNI, ",")
  For i = 1 To Len(str$)
  If InStr(ABC, Mid(str$, i, 1)) > 0 Then
   sUni = sUni & ChrW(arrUNI(InStr(ABC, Mid(str$, i, 1)) - 1))
   Else
   sUni = sUni & Mid(str$, i, 1)
   End If
  Next
  VnToUni = sUni
  End Function
  Sub jf()
  s = Application.InputBox("dfbdf", "thuy")
  End Sub

Form

   Dim ret As String
  
   Private Sub Form_Initialize()
   InitCommonControls
   End Sub
  
  
   Private Sub Command1_Click()
   ret = UniInputBox("InputBox hç trî nhËp xuÊt TiÕng ViÖt Unicode" & vbCrLf & _
   "T¸c gi¶: TrÇn §¹i NghÜa (Giang Hå)" & vbCrLf & "Hç trî nhËp Password" & vbCrLf & _
   "Textbox kh«ng hç trî Unicode ë Windows Classic Style", "Input Box Unicode", "NÕu thÊy hay th× nhÊn Thanks c¸i nha !")
   If ret <> "" Then MessageBoxW hwnd, StrPtr(ret), StrPtr("www.caulacbovb.com"), 0
   End Sub
  
   Private Sub Command2_Click()
   ret = UniInputBox("NhËp Password v« ®©y !", "Enter Password", , True)
   If ret <> "" Then MessageBoxW hwnd, StrPtr(ret), StrPtr("www.caulacbovb.com"), 0
   End Sub

Private Sub UserForm_Click()

End Sub

 

[ndu96081631]

Code các bạn đưa lên có lẽ để nghiên cứu thì tốt hơn... chứ mà xài thì chắc... chả ai thèm
Sủ dụng 1 công cụ nào đó là khai thác tối đa sở trường của nó chứ không phải "ép" nó làm mọi thứ

 

[thuyyeu99]

Code các bạn đưa lên có lẽ để nghiên cứu thì tốt hơn... chứ mà xài thì chắc... chả ai thèm
Sủ dụng 1 công cụ nào đó là khai thác tối đa sở trường của nó chứ không phải "ép" nó làm mọi thứ

Anh nói đúng em cũng nghĩ như vậy, xài cái gì chuẩn MSO thì tốt hơn, không thì nhiều lúc nó đụng tùm lum không biết đường giải quyết, em nghĩ cái nào MSO không có hoặc không cho thì chắc phải có cái lý của nó "chứ không phải "ép" nó làm mọi thứ" . Cám ơn anh