'öncelikle projeye reference bölümünden Microsoft XML, Version 2.0 ' ý ekleyin (msxml.dll)
'_____________________________________________________
'module 1 içeriði
Option Explicit
Public Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Public Declare Function InternetOpenUrl Lib "wininet.dll" Alias "InternetOpenUrlA" (ByVal hInternetSession As Long, ByVal sURL As String, ByVal sHeaders As String, ByVal lHeadersLength As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
Public Declare Function InternetReadFile Lib "wininet.dll" (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer
Public Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer
Public Const IF_FROM_CACHE = &H1000000
Public Const IF_MAKE_PERSISTENT = &H2000000
Public Const IF_NO_CACHE_WRITE = &H4000000
Private Const BUFFER_LEN = 256
Public Function GetUrlSource(sURL As String) As String
Dim sBuffer As String * BUFFER_LEN, iResult As Integer, sData As String
Dim hInternet As Long, hSession As Long, lReturn As Long
hSession = InternetOpen("vb wininet", 1, vbNullString, vbNullString, 0)
If hSession Then hInternet = InternetOpenUrl(hSession, sURL, vbNullString, 0, IF_NO_CACHE_WRITE, 0)
If hInternet Then
iResult = InternetReadFile(hInternet, sBuffer, BUFFER_LEN, lReturn)
sData = sBuffer
Do While lReturn <> 0
iResult = InternetReadFile(hInternet, sBuffer, BUFFER_LEN, lReturn)
sData = sData + Mid(sBuffer, 1, lReturn)
Loop
End If
iResult = InternetCloseHandle(hInternet)
GetUrlSource = sData
End Function
'___________________________________________
module2 içeriði
Function xml_post(web_url As Variant, xml_veri As Variant)
Dim donen_deger As String
Dim XML_objesi As New MSXML.XMLHTTPRequest
donen_deger = "connection error"
DoEvents
On Local Error Resume Next
XML_objesi.Open "GET", web_url, False
XML_objesi.setRequestHeader "Content-type:", "text/xml"
XML_objesi.setRequestHeader "Depth", "1"
On Local Error Resume Next
XML_objesi.send xml_veri
On Local Error Resume Next
donen_deger = XML_objesi.responseText
donen_deger = Replace(donen_deger, vbCrLf, "")
xml_post = donen_deger
End Function
'__________________________________________
'bir form üzerine text1 (textbox), bilgi2(textbox), bir de comamnd ekleyin
Private Function tC_aL()
Dim mMm
MousePointer = vbHourglass
SONUC2 = xml_post("http://tckimlik.nvi.gov.tr/Web/VerifyIdentityNumber.aspx?__VIEWSTATE=%2FwEPDwULLTE2MDQ5ODgyNjUPZBYCAgEPZBYCAgUPDxYCHgRUZXh0ZRYMHgZpc1JlYWwFBWZhbHNlHgVpc1BvcwUEdHJ1ZR4HdmFsRXhwcgUKXlxkezEsMTE%2FJB4JZGVjUGxhY2VzBQItMR4HZGVjU2lnbgUBLh4PcGxhY2VzQmVmb3JlRGVjBQIxMWRkiSg0VIchgmSMKJEHuAh%2FyBB41Vg%3D&ctlIdentityNumber=" & Text1.Text & "&ctlVerify=T.C.+Kimlik+No+Do%F0rula&__EVENTVALIDATION=%2FwEWAwK1vcCcDAKL86WHCgKc85DLBRSWVXAHdB0xS1j%2Bax7ASwV%2BjJhZ", "")
MousePointer = vbDefault
If Len(SONUC2) > 14000 Then
'ADI ÇEK
ILK2 = InStr(1, SONUC2, " ")
BASLANGIC2 = InStr(ILK2 + 1, SONUC2, "BOLD") + 12
BITIS2 = InStr(BASLANGIC2 + 1, SONUC2, "")
ISIM2 = Replace(Mid(SONUC2, BASLANGIC2, BITIS2 - BASLANGIC2), "BOLD", "")
bilgi2 = ISIM2
'SOYADI ÇEK
ILK2 = BITIS2
BASLANGIC2 = InStr(ILK2 + 1, SONUC2, "BOLD") + 12
BITIS2 = InStr(BASLANGIC2 + 1, SONUC2, "")
SOY2 = Replace(Mid(SONUC2, BASLANGIC2, BITIS2 - BASLANGIC2), "BOLD", "")
bilgi2.Text = bilgi2.Text & " " & SOY2
'YILI ÇEK
ILK2 = BITIS2
BASLANGIC2 = InStr(ILK2 + 1, SONUC2, "BOLD") + 12
BITIS2 = InStr(BASLANGIC2 + 1, SONUC2, "")
YIL = Replace(Mid(SONUC2, BASLANGIC2, BITIS2 - BASLANGIC2), "BOLD", "")
bilgi2.Text = bilgi2.Text & ", " & YIL
Else
bilgi.Text = "T.C. Kimlik No'ya ait bilgi bulunamadý." & vbCrLf & vbCrLf & "Lütfen Kontrol Edin."
End If
50000
If Mid(bilgi2, 1, 10) = "TML PUBLIC" Then
bilgi2.Text = "TC KÝMLÝK NO BULUNAMADI"
End If
bilgi2.Text = Replace(bilgi2.Text, "Ç", "Ç")
bilgi2.Text = Replace(bilgi2.Text, "Ö", "Ö")
bilgi2.Text = Replace(bilgi2.Text, "Ü", "Ü")
End Function
'bu tc_al fonksiyonu textbox1 deki tc numarasýna ait bilgileri bilgi2 adýndaki textbox a atar. türkçe karakterleri düzenler. ekleyeceðiniz command nesnesinin kod kýsmýna tC_aL
yazarsanız sorunsuz çalışacaktır.
NOT : ALINTIDIR ama denedim kodlar sağlam.
'_____________________________________________________
'module 1 içeriði
Option Explicit
Public Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Public Declare Function InternetOpenUrl Lib "wininet.dll" Alias "InternetOpenUrlA" (ByVal hInternetSession As Long, ByVal sURL As String, ByVal sHeaders As String, ByVal lHeadersLength As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
Public Declare Function InternetReadFile Lib "wininet.dll" (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer
Public Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer
Public Const IF_FROM_CACHE = &H1000000
Public Const IF_MAKE_PERSISTENT = &H2000000
Public Const IF_NO_CACHE_WRITE = &H4000000
Private Const BUFFER_LEN = 256
Public Function GetUrlSource(sURL As String) As String
Dim sBuffer As String * BUFFER_LEN, iResult As Integer, sData As String
Dim hInternet As Long, hSession As Long, lReturn As Long
hSession = InternetOpen("vb wininet", 1, vbNullString, vbNullString, 0)
If hSession Then hInternet = InternetOpenUrl(hSession, sURL, vbNullString, 0, IF_NO_CACHE_WRITE, 0)
If hInternet Then
iResult = InternetReadFile(hInternet, sBuffer, BUFFER_LEN, lReturn)
sData = sBuffer
Do While lReturn <> 0
iResult = InternetReadFile(hInternet, sBuffer, BUFFER_LEN, lReturn)
sData = sData + Mid(sBuffer, 1, lReturn)
Loop
End If
iResult = InternetCloseHandle(hInternet)
GetUrlSource = sData
End Function
'___________________________________________
module2 içeriði
Function xml_post(web_url As Variant, xml_veri As Variant)
Dim donen_deger As String
Dim XML_objesi As New MSXML.XMLHTTPRequest
donen_deger = "connection error"
DoEvents
On Local Error Resume Next
XML_objesi.Open "GET", web_url, False
XML_objesi.setRequestHeader "Content-type:", "text/xml"
XML_objesi.setRequestHeader "Depth", "1"
On Local Error Resume Next
XML_objesi.send xml_veri
On Local Error Resume Next
donen_deger = XML_objesi.responseText
donen_deger = Replace(donen_deger, vbCrLf, "")
xml_post = donen_deger
End Function
'__________________________________________
'bir form üzerine text1 (textbox), bilgi2(textbox), bir de comamnd ekleyin
Private Function tC_aL()
Dim mMm
MousePointer = vbHourglass
SONUC2 = xml_post("http://tckimlik.nvi.gov.tr/Web/VerifyIdentityNumber.aspx?__VIEWSTATE=%2FwEPDwULLTE2MDQ5ODgyNjUPZBYCAgEPZBYCAgUPDxYCHgRUZXh0ZRYMHgZpc1JlYWwFBWZhbHNlHgVpc1BvcwUEdHJ1ZR4HdmFsRXhwcgUKXlxkezEsMTE%2FJB4JZGVjUGxhY2VzBQItMR4HZGVjU2lnbgUBLh4PcGxhY2VzQmVmb3JlRGVjBQIxMWRkiSg0VIchgmSMKJEHuAh%2FyBB41Vg%3D&ctlIdentityNumber=" & Text1.Text & "&ctlVerify=T.C.+Kimlik+No+Do%F0rula&__EVENTVALIDATION=%2FwEWAwK1vcCcDAKL86WHCgKc85DLBRSWVXAHdB0xS1j%2Bax7ASwV%2BjJhZ", "")
MousePointer = vbDefault
If Len(SONUC2) > 14000 Then
'ADI ÇEK
ILK2 = InStr(1, SONUC2, " ")
BASLANGIC2 = InStr(ILK2 + 1, SONUC2, "BOLD") + 12
BITIS2 = InStr(BASLANGIC2 + 1, SONUC2, "")
ISIM2 = Replace(Mid(SONUC2, BASLANGIC2, BITIS2 - BASLANGIC2), "BOLD", "")
bilgi2 = ISIM2
'SOYADI ÇEK
ILK2 = BITIS2
BASLANGIC2 = InStr(ILK2 + 1, SONUC2, "BOLD") + 12
BITIS2 = InStr(BASLANGIC2 + 1, SONUC2, "")
SOY2 = Replace(Mid(SONUC2, BASLANGIC2, BITIS2 - BASLANGIC2), "BOLD", "")
bilgi2.Text = bilgi2.Text & " " & SOY2
'YILI ÇEK
ILK2 = BITIS2
BASLANGIC2 = InStr(ILK2 + 1, SONUC2, "BOLD") + 12
BITIS2 = InStr(BASLANGIC2 + 1, SONUC2, "")
YIL = Replace(Mid(SONUC2, BASLANGIC2, BITIS2 - BASLANGIC2), "BOLD", "")
bilgi2.Text = bilgi2.Text & ", " & YIL
Else
bilgi.Text = "T.C. Kimlik No'ya ait bilgi bulunamadý." & vbCrLf & vbCrLf & "Lütfen Kontrol Edin."
End If
50000
If Mid(bilgi2, 1, 10) = "TML PUBLIC" Then
bilgi2.Text = "TC KÝMLÝK NO BULUNAMADI"
End If
bilgi2.Text = Replace(bilgi2.Text, "Ç", "Ç")
bilgi2.Text = Replace(bilgi2.Text, "Ö", "Ö")
bilgi2.Text = Replace(bilgi2.Text, "Ü", "Ü")
End Function
'bu tc_al fonksiyonu textbox1 deki tc numarasýna ait bilgileri bilgi2 adýndaki textbox a atar. türkçe karakterleri düzenler. ekleyeceðiniz command nesnesinin kod kýsmýna tC_aL
yazarsanız sorunsuz çalışacaktır.
NOT : ALINTIDIR ama denedim kodlar sağlam.
