E-Fatura Kurum Listesi

[Murat OSMA]

E Fatura'ya kayıtlı Kurumların listesini ListBox'ta görüntüleyip arama yapabilirsiniz.

Faydalı olması dileğiyle...


■ Module kodları;

Public Dosya_Yolu As String, Desk As String, Rky As Object

Sub Baglan()
    Set Rky = CreateObject("adodb.connection")
    Rky.Open "provider=microsoft.ace.oledb.12.0; data source=" & _
    Dosya_Yolu & ";extended properties=""Excel 12.0;hdr=yes"""
End Sub

Sub Emre()
    UserForm1.Show
End Sub

■ UserForm kodları;

Private Declare Function Dosya_Indir Lib "urlmon" Alias "URLDownloadToFileA" _
    (ByVal pCaller As Long, ByVal Adres As String, ByVal Dosya_Adı As String, _
    ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

Private Sub CommandButton1_Click()
    Dim rs As Object, Sorgu As String, Dosya_Adresi As String, Ac As Workbook
    Set rs = CreateObject("adodb.recordSet")
    Sorgu = "Select [Kurum Unvanı] from [EFatura - Kurumlar$]"
    rs.Open Sorgu, Rky, 1, 1
    ListBox1.Column = rs.getrows
    Label2.Caption = ListBox1.ListCount & " Adet Kurum Listelendi."
    rs.Close
    Set rs = Nothing: Sorgu = ""
End Sub

Private Sub UserForm_Activate()
    Application.ScreenUpdating = False
    Desk = CreateObject("Wscript.Shell").specialfolders("Desktop")
    If Dir(Desk & "\efatura_kurumlar.xls") <> "" Then Kill Desk & "\efatura_kurumlar.xls"
    Dosya_Yolu = Desk & "\efatura_kurumlar.xls"
    Dosya_Adresi = "http://sorgu.efatura.gov.tr/kullanicilar/oliste.php?bolum=asltd&xls"
    Dosya_Indir 0&, Dosya_Adresi, Dosya_Yolu, 0&, 0&
    Application.DisplayAlerts = False
    Set Ac = Workbooks.Open(Dosya_Yolu)
    ActiveWorkbook.SaveAs Filename:=Dosya_Yolu, FileFormat:=xlExcel8, _
    Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
    Ac.Close False
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Call Baglan
End Sub

Private Sub Textbox1_Change()
    Dim Evn As Object, s As String
    Call Baglan
    Set Evn = CreateObject("adodb.recordset")
    Evn.Open "Select [Kurum Unvanı] from [EFatura - Kurumlar$] where [Kurum Unvanı] LIKE '%" & TextBox1.Text & "%'", Rky, 1, 1
    ListBox1.Clear
    If Evn.RecordCount > 0 Then
        ListBox1.Column = Evn.getrows
    End If
    Evn.Close
End Sub

Private Sub UserForm_Terminate()
    Rky.Close
    Set Rky = Nothing
End Sub

 

[Korhan Ayhan]

Murat Bey,

Elinize sağlık. Paylaşımınız için teşekkür ederim.

 

[excelland]

elinize sağlık çok teşekkürler

 

[Zeki Gürsoy]

64 bit office api sorunu ile karşılaşanlar aşağıdaki proseduru kullanabilir.

Sub Dosya_Indir()
    Dim b() As Byte
    
    Set http = CreateObject("msxml2.xmlhttp")
    
    URL = "http://sorgu.efatura.gov.tr/kullanicilar/oliste.php?bolum=asltd&xls"
    
    http.Open "get", URL, False
    http.send
    
    b = http.responsebody
    
    Desk = CreateObject("Wscript.Shell").specialfolders("Desktop")
    
    Open Desk & "\efatura_kurumlar.xls" For Binary As #1
        Put #1, , b
    Close #1
    
    http.abort
End Sub

 

[Murat OSMA]

Murat Bey,

Elinize sağlık. Paylaşımınız için teşekkür ederim.

Rica ederim Korhan Bey.


Zeki Bey, alternatif dosya indirme yöntemi için teşekkür ederim. k::

 

[turanb]

Teşekkür ederim Murat bey. Elinize sağlık.