Bilgisayarın IP kodunu yazdırmak

[aoeflatun]

Bilgisayarın IP kodunu a1 hücresine yazdırmak istiyorum.
Yardımlarınız için teşekkür ederim.
Ali Osman Eflatun

 

[Mahmut Bayram]

Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

Sub auto_open()
Dim ip As String
download = URLDownloadToFile(0, "http://k.domaindlx.com/nailgg/tr/ip.asp", "c:\windows\temp\a1.tmp", 0, 0)
Open "c:\windows\temp\a1.tmp" For Input As #1
 Input #1, ip
Close
Sheets("Sayfa1").Range("A1").Value = ip
End Sub

 

[aoeflatun]

TeŞekkÜr

Mahmut bey teşekkür ederim yardımlarınız için.
Ben yanlış anlattım konuyu. Yapmak istediğim şu;
her bilgisayarın seri numarası vardır ya benim yapmak istediğim o seri numarasını a1 bir hücresine yazdırmak
bu konuda yardım ederseniz sevinirim.

 

[Mahmut Bayram]

Haluk abi'nin kodlarından alıntıdır.

Private Declare Function GetWindowLongA Lib "user32" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLongA Lib "user32" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Sub auto_open()
Dim strManufacturer As String, strRegisteredUser As String, strSerialNumber As String
strComputerName = "."
strNameSpace = "root\cimv2"
strClassName = "Win32_OperatingSystem"
'
On Error Resume Next
If Err.Number <> 0 Then
MsgBox "WMI y&#252;klenmemis! Programdan &#231;ikilacak...", vbExclamation, _
"Windows Management Instrumentation"
Exit Sub
On Error GoTo 0
End If
Set objWMIService = GetObject("winmgmts:\\" & strComputerName & "\" & strNameSpace)
Set Osinf = objWMIService.ExecQuery("Select * from " & strClassName)
For Each OS In Osinf
strSerialNumber = OS.SerialNumber
Range("A1").Value = strSerialNumber
Next
End Sub

 

[aoeflatun]

Teşekkür

Mahmut bey göndermiş olduğunuz kodlar işime çok yaradı teşekkür ederim.
Ali Osman Eflatun

 

[ECYavuz]

Forumdan alınan başka bir örnek...

Kod bankasında yer alan bir başka örnek...

Public Function GetVolumeInformationa(ByVal lpRootPathName As String, _
ByVal lpVolumeNameBuffer As String, _
ByVal nVolumeNameSize As Long, _
ByVal lpVolumeSerialNumber As Long, _
ByVal lpMaximumComponentLength As Long, _
ByVal lpFileSystemFlags As Long, _
ByVal lpFileSystemNameBuffer As String, _
ByVal nFileSystemNameSize As Long _
) As Long
End Function

Private Sub SBilgi_Click()
Dim s As String, oSystem As Object, item As Object
Dim sdosya
Dim dosya
Dim SeriNo As Long
GetVolumeInformationA "C:\", vbNullString, 0, SeriNo, 0, 0, vbNullString, 0
Set sdosya = CreateObject("Scripting.FileSystemObject")
Set dosya = sdosya.getfile(ThisWorkbook.Path & "\" & ActiveWorkbook.Name)
Set oSystem = GetObject("winmgmts:").instancesOf("Win32_ComputerSystem")
For Each item In oSystem
s = "Bilgisayar Sistem Bilgileri" & vbCrLf
s = s & "-------------------------------" & vbCrLf
s = s & "Name : " & item.Name & vbCrLf
s = s & "Status : " & item.Status & vbCrLf
s = s & "Type : " & item.SystemType & vbCrLf
s = s & "Mfg : " & item.Manufacturer & vbCrLf
s = s & "Model : " & item.Model & vbCrLf
s = s & "RAM : " & item.TotalPhysicalMemory \ 1024000 & "mb" & vbCrLf
s = s & "Domain : " & item.Domain & vbCrLf
s = s & "Role : " & TranslateDomainRole(item.DomainRole) & vbCrLf
s = s & "Current User : " & item.UserName & vbCrLf & vbCrLf
s = s & "Program Adı : " & ActiveWorkbook.Name & vbCrLf
s = s & "Dosya Boyutu : " & Format(dosya.Size \ 1024@, "#######0") & " Kb" & vbCrLf
s = s & "Seri No : " & SeriNo
MsgBox s, vbOKOnly + vbInformation, Application.UserName
Next
Set oSystem = Nothing
End Sub

Function TranslateDomainRole(ByVal roleID) As String
Dim RetString As String
Select Case roleID
Case 0
RetString = "Standart Workstation"
Case 1
RetString = "Member Workstation"
Case 2
RetString = "Standart Server"
Case 3
RetString = "Member Server"
Case 4
RetString = "Backup Domain Controller"
Case 5
RetString = "Primary Domain Controller"
Case Else
RetString = "Unknown"
End Select
TranslateDomainRole = RetString
End Function

 

[Mahmut Bayram]

Rica ederim.
Kolay gelsin.