Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Mayıs 2006 Cumartesi

Common Gatevay Interface (cgi) Data Read (Navigate)



'UserForm1

Option Explicit
Private i, ii As Integer
Private Liste As MSForms.ListBox
Private Etiket1 As MSForms.Label
Private Etiket2 As MSForms.Label
Private CGIAdres As String
Private BaşlangıçTarihi As Date
Private ArananTarih As Variant
Private InternetTarayıcı As Object
Private CGIDosya As Object
Private CGITablo As Object
Private VeriAlanı As Object
Private Veri1, Veri2, Veri3, Veri4, Veri5, Veri6, Veri7, Veri8, Veri9, Veri10

Private Sub UserForm_Initialize()
On Error Resume Next
With Me
.Caption = "[PBİD®]CGI Veri Tabanını Okuma"
.Width = 360
.Height = 258
Set Liste = .Controls.Add("Forms.ListBox.1")
With Liste
.Name = "Liste"
.BackColor = &H80000018
.SpecialEffect = fmSpecialEffectEtched
.ColumnCount = 8
.ColumnWidths = "30;60;36;36;36;36;36;36"
.Top = 6
.Left = 6
.Width = 342
.Height = 207
End With
DoEvents
Set Etiket1 = .Controls.Add("Forms.Label.1")
With Etiket1
.Name = "Etiket1"
.Caption = ""
.BackColor = &H80000018
.SpecialEffect = fmSpecialEffectEtched
.Top = 216
.Left = 6
.Width = 60
.Height = 12
.TextAlign = fmTextAlignCenter
End With
DoEvents
Set Etiket2 = .Controls.Add("Forms.Label.1")
With Etiket2
.Name = "Etiket2"
.Caption = ""
.BackColor = &H80000018
.SpecialEffect = fmSpecialEffectEtched
.Top = 216
.Left = 66
.Width = 282
.Height = 12
End With
DoEvents
End With
End Sub
Private Sub UserForm_Activate()
On Error Resume Next
CGIAdres = "http://649.tr.net/cgi-bin/sayisal.cgi?"
BaşlangıçTarihi = DateValue("09/11/1996")
Set InternetTarayıcı = CreateObject("InternetExplorer.Application")
For i = 2 To VBA.DateDiff("ww", BaşlangıçTarihi, VBA.Date) + 1
ii = ii + 1
ArananTarih = VBA.DateAdd("ww", ii, BaşlangıçTarihi)
With InternetTarayıcı
.Navigate CGIAdres & VBA.Format(ArananTarih, "yyyymmdd")
With .Document.All
On Error Resume Next
.Haftalar.Value = VBA.Format(ArananTarih, "dd/mm/yyyy")
On Error GoTo 0
End With
Do Until .ReadyState = 4: DoEvents: Loop
Do While .Busy: DoEvents: Loop
On Error GoTo CGIHata:
Set CGIDosya = .Document.Body
Set CGITablo = CGIDosya.GetElementsByTagName("Table")
Set VeriAlanı = CGITablo(4)
Veri1 = (i - 1)
Veri2 = VBA.Format(ArananTarih, "dd.mm.yyyy")
Veri3 = VeriAlanı.Cells(0, 0).InnerText
Veri4 = VeriAlanı.Cells(1, 1).InnerText
Veri5 = VeriAlanı.Cells(2, 2).InnerText
Veri6 = VeriAlanı.Cells(3, 3).InnerText
Veri7 = VeriAlanı.Cells(4, 4).InnerText
Veri8 = VeriAlanı.Cells(5, 5).InnerText
Veri9 = VeriAlanı.InnerText
Veri10 = CGIAdres & InternetTarayıcı.Document.All.Haftalar.Value
End With
Etiket1.Caption = Veri9
Etiket2.Caption = " " & Veri10
With Liste
.AddItem Veri1
.List(i - 2, 1) = Veri2
.List(i - 2, 2) = Veri3
.List(i - 2, 3) = Veri4
.List(i - 2, 4) = Veri5
.List(i - 2, 5) = Veri6
.List(i - 2, 6) = Veri7
.List(i - 2, 7) = Veri8
.ListIndex = Veri1 - 1
End With
Next
ReDim Hafıza(1 To Liste.ListCount, 1 To 8)
For i = 1 To Liste.ListCount
For ii = 1 To 8
Hafıza(i, ii) = Liste.List((i - 1), (ii - 1))
Next ii
Next i
Call VeriTabanıOluştur(CGIAdres, Hafıza(), Liste.ListCount)
GoTo CGIKapat:
CGIHata:
MsgBox "Ortak Geçit Arayüzü [CGI: Common Gatevay Interface]" & vbCrLf & "Erişimi ve/veya Verisi Bulunamadı!", vbInformation, "[PBİD®]"
CGIKapat:
Set CGIDosya = Nothing
Set CGITablo = Nothing
Set VeriAlanı = Nothing
Set InternetTarayıcı = Nothing
End Sub
Sub VeriTabanıOluştur(ByVal CGIAdres As String, ByVal Veriler, ByVal Adet As Double)
On Error GoTo Devam:
Sheets("CGIVeriTabanı").Delete
Devam:
On Error Resume Next
Dim Alan As String
Application.Sheets.Add Sheets(1)
Application.ActiveSheet.Name = "CGIVeriTabanı"
Sheets("CGIVeriTabanı").Select
[A1] = "CGI Adres= " & CGIAdres
Alan = "A3:H" & (Adet + 2)
Sheets("CGIVeriTabanı").Range(Alan).Value = Veriler
With [A1:H1]
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
.Font.Bold = True
End With
[A2] = "[HaftaNo]": [B2] = "[Tarih]": [C2] = "[No1]": [D2] = "[No2]": [E2] = "[No3]": [F2] = "[No4]": [G2] = "[No5]": [H2] = "[No6]":
With [A2:H2]
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
.Font.Bold = True
End With
With [A1:H2]
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Interior.ColorIndex = 15
.Interior.Pattern = xlSolid
End With
Application.Cells.Font.Size = 8
[B:B].ColumnWidth = 10
End Sub

Hiç yorum yok:

Blog Arşivi

Bu gadget'ta bir hata oluştu

Bu Blogda Ara

Contributor

Contributor
Mustafa ULUSARAÇ İstanbul, TÜRKİYE
free counters
T. C. Central Bank Indicative Exchange Rates
Currency Exchange Rate Widget,Currency Converter Widget
Borsa İstanbul