Lấy địa chỉ IP Address

Liên hệ QC

Po_Pikachu

Po_pikachu@ymail.com
Tham gia
29/4/08
Bài viết
2,209
Được thích
3,572
Nghề nghiệp
#VALUE!
Tình cờ lượm được thằng này. Viết bài góp vui với mọi người nha! --=0
Mã:
Private Declare Function GetIpAddrTable_API Lib "IpHlpApi" Alias "GetIpAddrTable" (pIPAddrTable As Any, pdwSize As Long, ByVal bOrder As Long) As Long
' Returns an array with the local IP addresses (as strings).
' Author: Christian d'Heureuse, [URL="http://www.source-code.biz"]www.source-code.biz[/URL]
Public Function GetIpAddrTable()
   Dim Buf(0 To 511) As Byte
   Dim BufSize As Long: BufSize = UBound(Buf) + 1
   Dim rc As Long
   rc = GetIpAddrTable_API(Buf(0), BufSize, 1)
   If rc <> 0 Then Err.Raise vbObjectError, , "GetIpAddrTable failed with return value " & rc
   Dim NrOfEntries As Integer: NrOfEntries = Buf(1) * 256 + Buf(0)
   If NrOfEntries = 0 Then GetIpAddrTable = Array(): Exit Function
   ReDim IpAddrs(0 To NrOfEntries - 1) As String
   Dim i As Integer
   For i = 0 To NrOfEntries - 1
      Dim j As Integer, s As String: s = ""
      For j = 0 To 3: s = s & IIf(j > 0, ".", "") & Buf(4 + i * 24 + j): Next
      IpAddrs(i) = s
   Next
   GetIpAddrTable = IpAddrs
End Function
 
 
' Test program for GetIpAddrTable.
Public Sub Test()
   Dim IpAddrs
   IpAddrs = GetIpAddrTable
   [A1] = "Nr of IP addresses: " & UBound(IpAddrs) - LBound(IpAddrs) + 1
   Dim i As Integer
   For i = LBound(IpAddrs) To UBound(IpAddrs)
      Cells(i + 2, "A") = IpAddrs(i)
   Next
End Sub
 
Tình cờ lượm được thằng này. Viết bài góp vui với mọi người nha!
Thí nghiệm cái này xem thế nào:
PHP:
Sub Test()
  With CreateObject("WScript.Shell")
    MsgBox .Exec("ipconfig").StdOut.ReadAll
  End With
End Sub
Tùy biến tiếp thế nào nữa là... TÙY
Gọn không?
 
Upvote 0
Thí nghiệm cái này xem thế nào:
PHP:
Sub Test()
  With CreateObject("WScript.Shell")
    MsgBox .Exec("ipconfig").StdOut.ReadAll
  End With
End Sub
Tùy biến tiếp thế nào nữa là... TÙY
Gọn không?
Thế muốn tự động mở file New Text Document.txt rồi chép nội dung đó vào, sau đó lưu thành IP_Address.txt được không sư phụ?
 
Upvote 0
Thế muốn tự động mở file New Text Document.txt rồi chép nội dung đó vào, sau đó lưu thành IP_Address.txt được không sư phụ?
Thử vầy xem:
PHP:
Sub Test()
  With CreateObject("Wscript.Shell")
    .Run "cmd /c IPCONFIG > C:\IP_Address.txt", 0, True
  End With
  With CreateObject("Shell.Application")
    .Open "C:\IP_Address.txt"
  End With
End Sub
 
Upvote 0
Gọn thật, thưa Anh! Học thêm được chiêu của Anh, vui quá.
 
Upvote 0
Gọn thật, thưa Anh! Học thêm được chiêu của Anh, vui quá.
Nếu bạn hứng thú, tôi xin diễn giải thêm về mấy lệnh này:
1> Run "cmd /c IPCONFIG > C:\IP_Address.txt", 0, True tương đương với việc bạn bấm Start, chọn Run, gõ vào lệnh CMD ---> Sau đó, trong cửa số CMD, bạn gõ lệnh IPCONFIG > C:\IP_Address.txt
Số 0 mang mục đích ẩn cửa số CMD
Chữ True mang mục đích "đợi" cho lệnh này làm việc xong rồi mới làm tiếp các lệnh bên dưới ---> Điều này rất quan trọng, nếu đặt tham số này = FALSE thì file IP_Address.txt chưa kịp hình thành mà lệnh mở file ở bên dưới đã thực thi thì sẽ chẳng nhận được kết quả gì (1 file rổng)
2>
PHP:
With CreateObject("Shell.Application")
    .Open "Đường dẩn đến file"
  End With
Dùng để mở 1 file bất kỳ với đường dẩn cho trước
 
Upvote 0
Anh ndu! thế chắc nếu Anh muốn làm Hắc-cơ bằng Excel thì cũng làm được nhỉ?
Xin lỗi vì tôi dốt cả tiếng Anh.
 
Lần chỉnh sửa cuối:
Upvote 0
Nếu bạn hứng thú, tôi xin diễn giải thêm về mấy lệnh này:
1> Run "cmd /c IPCONFIG > C:\IP_Address.txt", 0, True tương đương với việc bạn bấm Start, chọn Run, gõ vào lệnh CMD ---> Sau đó, trong cửa số CMD, bạn gõ lệnh IPCONFIG > C:\IP_Address.txt
Số 0 mang mục đích ẩn cửa số CMD
Chữ True mang mục đích "đợi" cho lệnh này làm việc xong rồi mới làm tiếp các lệnh bên dưới ---> Điều này rất quan trọng, nếu đặt tham số này = FALSE thì file IP_Address.txt chưa kịp hình thành mà lệnh mở file ở bên dưới đã thực thi thì sẽ chẳng nhận được kết quả gì (1 file rổng)
2>
PHP:
With CreateObject("Shell.Application")
.Open "Đường dẩn đến file"
End With
Dùng để mở 1 file bất kỳ với đường dẩn cho trước

Code rất ngắn! Tuyệt lắm!
Nhưng anh đã nêu là ẩn cửa sổ CMD rùi và còn đợi các lệnh liên tiếp nữa. Vậy không biết có thể đưa chúng vào trong code VBA ko? :D
<Ham hố thui!>
Thân.
 
Upvote 0
Code rất ngắn! Tuyệt lắm!
Nhưng anh đã nêu là ẩn cửa sổ CMD rùi và còn đợi các lệnh liên tiếp nữa. Vậy không biết có thể đưa chúng vào trong code VBA ko? :D
<Ham hố thui!>
Thân.
Mính chưa hiểu ý bạn cho lắm! Đây toàn là code VBA thôi chứ có gì khác đâu?
 
Upvote 0
A! Tại vì khi chạy code VBA thì nó hiện lên khung DOS đó mà. Mình muốn không hiện lên cái khung đen đó thôi. Nếu không được thì thôi, không sao đâu!
Thân.
 
Upvote 0
A! Tại vì khi chạy code VBA thì nó hiện lên khung DOS đó mà. Mình muốn không hiện lên cái khung đen đó thôi. Nếu không được thì thôi, không sao đâu!
Sao mình không có cái "khung đen" nhỉ?
Thử vầy xem:

PHP Code:
Sub Test()
With CreateObject("Wscript.Shell")
.Run "cmd /c IPCONFIG > C:\IP_Address.txt", 0, True
End With
With CreateObject("Shell.Application")
.Open "C:\IP_Address.txt"
End With
End Sub
Anh ndu, tôi thí nghiệm đoạn code trên sau khi chạy code xong thì
1. Tại C:\ ngoài file IP_Address.txt còn xuất hiện thêm một file trace.txt ngoài ý muốn, anh có biết file này là file gì không?
2. Khi thay "True" thành "False" thì im lặng luôn, có phải do VBA chạy nhanh hơn Windows nên lúc này file IP_Address.txt chưa tồn tại trên C:\ =>thằng VBA bỏ qua.
Luôn tiện cho hỏi Anh có thể viết được câu lệnh dò tìm USB và chỉ ra tên (vd: F:\ hoặc G:\ ...)không?
 
Lần chỉnh sửa cuối:
Upvote 0
A! Tại vì khi chạy code VBA thì nó hiện lên khung DOS đó mà. Mình muốn không hiện lên cái khung đen đó thôi. Nếu không được thì thôi, không sao đâu!
Thân.
Code đầu tiên khác code thứ 2 mà bạn!
Code ở bài #4 ẩn cái "khung đen" rồi đấy
Xem thêm bài này:
http://www.giaiphapexcel.com/forum/showthread.php?37051-L%C3%A0m-sao-%E1%BA%A9n-c%E1%BB%ADa-s%E1%BB%95-Command-Prompt-khi-th%E1%BB%B1c-thi-l%E1%BB%87nh-DOS-trong-VBA

1. Tại C:\ ngoài file IP_Address.txt còn xuất hiện thêm một file trace.txt ngoài ý muốn, anh có biết file này là file gì không?
Chắc file ấy có sẳn thôi ---> Xóa nó đi rồi chạy lại code xem!

2. Khi thay "True" thành "False" thì im lặng luôn, có phải do VBA chạy nhanh hơn Windows nên lúc này file IP_Address.txt chưa tồn tại trên C:\ =>thằng VBA bỏ qua.
Đã giải thích rõ ràng tại bài số 5 mà bạn chẳng chịu xem
Luôn tiện cho hỏi Anh có thể viết được câu lệnh dò tìm USB và chỉ ra tên (vd: F:\ hoặc G:\ ...)không?
Để tôi nghiên cứu tiếp xem thế nào nhé!
 
Lần chỉnh sửa cuối:
Upvote 0
Chắc file ấy có sẳn thôi ---> Xóa nó đi rồi chạy lại code xem!
À không, tôi đã thử xóa và chạy nhiều lần nó vẫn vậy, mà nó chỉ xuất hiện khi mở My Computer lại, thôi quên cái này đi.
Đã giải thích rõ ràng tại bài số 5 mà bạn chẳng chịu xem
Không những xem một lần (trình độ vịt mà!), tôi muốn hỏi cho cặn kẽ vậy thôi.
 
Upvote 0
Luôn tiện cho hỏi Anh có thể viết được câu lệnh dò tìm USB và chỉ ra tên (vd: F:\ hoặc G:\ ...)không?
Tạm dùng code này xem:
PHP:
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
PHP:
Sub GetFDrive()
  Dim i As Long, Fdvr As String
  For i = 65 To 90
    If GetDriveType(Chr(i) & ":\") = 2 Then
      Fdvr = Chr(i)
      MsgBox "Flash drive letter is: """ & Fdvr & """"
      With CreateObject("Scripting.FileSystemObject")
        MsgBox .Drives("" & Fdvr & "").VolumeName
      End With
      Exit Sub
    End If
  Next i
End Sub
Code này lấy cả Volume Label đấy!
---------------------------------
Chưa biết cách nào để bỏ vòng lập!
 
Upvote 0
Tạm dùng code này xem:
PHP:
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
PHP:
Sub GetFDrive()
  Dim i As Long, Fdvr As String
  For i = 65 To 90
    If GetDriveType(Chr(i) & ":\") = 2 Then
      Fdvr = Chr(i)
      MsgBox "Flash drive letter is: """ & Fdvr & """"
      With CreateObject("Scripting.FileSystemObject")
        MsgBox .Drives("" & Fdvr & "").VolumeName
      End With
      Exit Sub
    End If
  Next i
End Sub
Code này lấy cả Volume Label đấy!
---------------------------------
Chưa biết cách nào để bỏ vòng lập!
MsgBox "Flash drive letter is: """ & Fdvr & """" Không đúng thứ tự ổ đĩa Anh ạ.
Còn MsgBox .Drives("" & Fdvr & "").VolumeName bị lỗi
Có lẽ cả 2 lỗi trên đều do máy tôi có ổ đĩa ảo, anh nghiên cứu thử, tôi chịu.
 
Upvote 0
Thử lại code này xem:
PHP:
Sub GetFDrive()
  Dim Drv, Arr(1)
  On Error Resume Next
  With CreateObject("Scripting.FileSystemObject")
    For Each Drv In .Drives
      If .Drives("" & Drv & "").DriveType = 1 Then
        Arr(0) = "Drive Letter: " & Drv
        Arr(1) = "Volume Label: " & .Drives("" & Drv & "").VolumeName
        MsgBox Join(Arr, vbLf)
      End If
    Next
  End With
End Sub
Code này không cần dùng hàm API
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
Còn cái này:
Thử lại code này xem:
PHP:
Sub GetFDrive()
  Dim i As Long, Drv, Arr(1)
  On Error Resume Next
  With CreateObject("Scripting.FileSystemObject")
    For Each Drv In .Drives
      If .Drives("" & Drv & "").DriveType = 1 Then
        Arr(0) = "Drive Letter: " & Drv
        Arr(1) = "Volume: " & .Drives("" & Drv & "").VolumeName
        MsgBox Join(Arr, vbLf)
      End If
    Next
  End With
End Sub
Code này không cần dùng hàm API
Thì đúng nhưng hiện ra một loạt ổ đĩa, không biết cái nào là USB để ứng dụng truy cập vào.
 
Upvote 0
Cho em hỏi 1 chút : Có thể dùng VB trong Excel để điều khiển tất cả các lệnh trong Dos hay ko. Ví dụ : em có 1 thiết bị, có thể truy cập và điều khiển bằng DOS nhưng đòi hỏi phải nhập ID và password,liệu có thể truy cập và điều khiển thiết bị ko. Xin cảm ơn.
 
Upvote 0
Web KT

Bài viết mới nhất

Back
Top Bottom