Sử dụng API trong VBA (3 người xem)

[PhanTuHuong]

Dưới đây là một số ví dụ về sử dụng API trong VBA (lấy từ Sample.xls của Excel 2000) để các bạn tham khảo:

1. Lấy tên các ổ đĩa trong máy:

Option Explicit
Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsA" _
        (ByVal nBufferLength As Long, _
         ByVal lpBuffer As String) As Long

Sub Get_Logical_Drive_String()

    Dim DrvString As String
    Dim TotDrvs As Long
    Dim Counter As Integer
    
    'TotDrvs returns the total number of characters in return string
    TotDrvs = GetLogicalDriveStrings(0&, DrvString)
    'DrvString is the buffer created to hold the string
    DrvString = String(TotDrvs - 1, " ")
    'Calling GetLogicalDriveStrings a second time fills the string with valid data
    'example "a:\
c:\
d:\
e:\
"
    TotDrvs = GetLogicalDriveStrings(TotDrvs, DrvString)
    
    'Parse through the return string displaying each in a msgbox
    For Counter = 1 To TotDrvs Step 4
        MsgBox Mid(DrvString, Counter, 3)
    Next Counter
    
End Sub

2. Xác định độ phân giải màn hình:

Option Explicit
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long

    'Constants for GetSystemMetrics

     Const SM_CXSCREEN = 0        ' Width of screen
     Const SM_CYSCREEN = 1        ' Height of screen


Sub Get_System_Metrics()

    Dim XVal As Long, YVal As Long
    YVal = GetSystemMetrics(SM_CYSCREEN)
    XVal = GetSystemMetrics(SM_CXSCREEN)
    MsgBox "Your Screen Resolution is " & XVal & " by " & YVal
    
End Sub

3. Xác định UserName truy cập Window:

Option Explicit
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" _
                                                        (ByVal lpBuffer As String, _
                                                        nSize As Long) As Long

Sub Get_User_Name()
    
    Dim lpBuff As String * 25
    Dim ret As Long, UserName As String
    ret = GetUserName(lpBuff, 25)
    UserName = Left(lpBuff, InStr(lpBuff, Chr(0)) - 1)
    MsgBox UserName
    
End Sub

 

[PhanTuHuong]

3. Xác định đường dẫn chi tiết và đường dẫn tắt của file hiện hành:

Private Declare Function GetShortPathName Lib "KERNEL32.DLL" Alias "GetShortPathNameA" _
(ByVal lpctstrLongName As String, _
ByVal lptstrShortName As String, _
ByVal bufLen As Long) As Long

Sub Get_Short_Name()
Dim LongStr As String, ShortStr As String
Dim lStrLen As Long, lRet As Long

'LongStr is any long file name or variable pointing to a file
LongStr = ThisWorkbook.FullName
lRet = GetShortPathName(LongStr, ShortStr, lStrLen)
'This allows us to create a buffer the same length as
'the returned string, saving us the trouble of having
'to strip the left of the buffer to get the string
ShortStr = String(lRet, " ")
lRet = GetShortPathName(LongStr, ShortStr, lRet)
MsgBox LongStr & " was converted to " & ShortStr
End Sub

4. Trả về tên máy tính:

Hiệu quả đối với bảo mật phần mềm

Option Explicit
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, _
nSize As Long) As Long

Sub Get_Computer_Name()
Dim Comp_Name_B As String * 255
Dim Comp_Name As String
GetComputerName Comp_Name_B, Len(Comp_Name_B)
'but the string is always ended with a null terminated string so we can use the Chr(0) function to find the end
Comp_Name = Left(Comp_Name_B, InStr(Comp_Name_B, Chr(0)))
'and return only the computer name
MsgBox Comp_Name
End Sub

 

[sonmaplx]

ở phần Xác định UserName truy cập Window, e muốn Username được in ra ô A1 thì có được không? nếu được thì làm thế nào vậy anh?

 

[ndu96081631]

ở phần Xác định UserName truy cập Window, e muốn Username được in ra ô A1 thì có được không? nếu được thì làm thế nào vậy anh?

Thay thay đoạn:
MsgBox UserName
thành:
Range("A1") = UserName