Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Şubat 2007 Salı

Excel - Access Connection And DataBase Relations








'UserForm1

'A) Windows XP® Office 2003® Normal Referance List

'Visual Basic For Applications
'Microsoft Excel 11.0 Object Library
'OLE Automation
'Microsoft Office 11.0 Object Library
'Microsoft Forms 2.0 Object Library
'Microsoft DAO 3.6 Object Library.
'Microsoft ActiveX Data Objects 2.8 Object Library.
'Microsoft ADO Ext. 2.8 For DDL and Security
'Microsoft Office Web Components 11.0
'B) UserForm1 E Eklenen Araçlar (Add Tools)
'Frama1
'Frame1\Image1, Label1, Label2
'Label3, Label4, Label5, Label6
'TextBox1, TextBox2, TextBox3, TextBox4
'SpinButton1
Option Explicit
Dim No As Single, i As Single
Option Base 1
Dim Yol As String, Dosya As String, Tablo As String, İlişki As String, HedefTablo As String, DosyaDeseni As String
Dim Satır As Integer, Kolon As Integer
Dim CN As ADODB.Connection
Dim RS As ADODB.Recordset
Dim Komut As New ADODB.Command
Private Sub UserForm_Initialize()

On Error Resume Next
Me.Caption = "[PBİD ®] Excel - Access Connection And DataBase Relations"
Call EkranDüzenle
Call VeriTabanınıAç
No = 1
SpinButton1.Value = 1
Call KayıtGetir
End Sub
Private Sub SpinButton1_SpinDown()

On Error GoTo Hata
No = No - 1
Call KayıtGetir
Exit Sub
Hata:
End Sub
Private Sub SpinButton1_SpinUp()

On Error GoTo Hata
No = No + 1
Call KayıtGetir
Exit Sub
Hata:
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

On Error Resume Next
CN.Close: Set CN = Nothing
Set Komut = Nothing
End
End Sub
Sub EkranDüzenle()

On Error Resume Next
With Me
.Height = 163.5
.Width = 339.75
.BackColor = &H8000000F
With Frame1
.Top = -2
.Left = -2
.Height = 36
.Width = Me.Width + 12
If .Picture = vbNull Then .Picture = LoadPicture("C:\Documents and Settings\PC\Desktop\BLOGSPOT\zarifVİSTA.bmp")
.PictureAlignment = fmPictureAlignmentTopLeft
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = False
With Image1
.BackStyle = fmBackStyleTransparent
.BorderColor = &HFF0000
.BorderStyle = fmBorderStyleSingle
.Top = 6
.Left = 6
.Height = 24
.Width = 24
If .Picture = vbNull Then .Picture = LoadPicture("C:\Documents and Settings\PC\Desktop\BLOGSPOT\Örnekİkonlar\PBİD.ico")
End With
With Label1
.Caption = " " & "Mustafa ULUSARAÇ"
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.Left = 30
.Top = 6
.Height = 12
.Width = 198
.Font.Bold = True
.ForeColor = &HFF0000
End With
With Label2
.Caption = " " & "01ulusarac@superonline.com"
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.Left = 30
.Top = 18
.Height = 12
.Width = 198
.Font.Bold = True
.ForeColor = &HFF0000
End With
End With
With Label3
.Caption = " " & "ID"
.SpecialEffect = fmSpecialEffectEtched
.Left = 6
.Top = 42
.Height = 18
.Width = 66
.ForeColor = &H80000012
End With
With Label4
.Caption = " " & "ADI"
.SpecialEffect = fmSpecialEffectEtched
.Left = 6
.Top = 60
.Height = 18
.Width = 66
.ForeColor = &H80000012
End With
With Label5
.Caption = " " & "SOYADI"
.SpecialEffect = fmSpecialEffectEtched
.Left = 6
.Top = 78
.Height = 18
.Width = 66
.ForeColor = &H80000012
End With
With Label6
.Caption = " " & "DOĞUM TARİHİ"
.SpecialEffect = fmSpecialEffectEtched
.Left = 6
.Top = 96
.Height = 18
.Width = 66
.ForeColor = &H80000012
End With
With TextBox1
.SpecialEffect = fmSpecialEffectEtched
.Left = 78
.Top = 42
.Height = 18
.Width = 36
.ForeColor = &H80000012
.Locked = True
End With
With TextBox2
.SpecialEffect = fmSpecialEffectEtched
.Left = 78
.Top = 60
.Height = 18
.Width = 246
.ForeColor = &HFF0000
End With
With TextBox3
.SpecialEffect = fmSpecialEffectEtched
.Left = 78
.Top = 78
.Height = 18
.Width = 246
.ForeColor = &HFF0000
End With
With TextBox4
.SpecialEffect = fmSpecialEffectEtched
.Left = 78
.Top = 96
.Height = 18
.Width = 66
.ForeColor = &HFF0000
End With
With SpinButton1
.Left = 6
.Top = 114
.Height = 18
.Width = 66
.Min = 1
.Max = 37000
End With
End With
End Sub
Sub VeriTabanınıAç()

On Error Resume Next
Yol = "C:\"
Dosya = "Örnek.mdb"
Tablo = "Tablo1"
Devam1:
On Error GoTo Hata1
Set CN = New ADODB.Connection
CN.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & Yol & Dosya & ";"
Devam2:
On Error GoTo Hata2
Set RS = New ADODB.Recordset
RS.Open Tablo, CN, adOpenStatic, adLockOptimistic, adCmdTable
Exit Sub
Hata1:
Call VeriTabanıYaratADO
Resume Devam1
Hata2:
Call KayıtTablosuDüzenlemek
ThisWorkbook.Sheets("Sayfa2").Select
Call ExceldenAccesseDAOVeriAl
Resume Devam2
End Sub
Sub KayıtGetir()

On Error GoTo Devam
Satır = No
With RS
.MoveFirst
For i = 1 To Satır - 1
.MoveNext
Next i
Devam:
On Error GoTo Hata
TextBox1.Text = RS.Fields("ID").Value
TextBox2.Text = RS.Fields("ADI").Value
TextBox3.Text = RS.Fields("SOYADI").Value
TextBox4.Text = RS.Fields("DTARIHI").Value
End With
Exit Sub
Hata:
End Sub

'Module1
Option Explicit
Dim Yol As String, Dosya As String
Dim Katalog As New ADOX.Catalog
Sub VeriTabanıYaratADO()
'Create Data Base

Yol = "C:\"
Dosya = "Örnek.mdb"
Katalog.Create "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & Yol & Dosya & ";" & ";Data Source = " & Yol & Dosya
Set Katalog = Nothing
Exit Sub
Hata:
MsgBox "Veri tabanıoluşturma hatası..." & Chr(10) & Chr(10) & "Hata No: " & Err & Chr(10) & "Hata Tanımı: " & VBA.Err.Description, vbExclamation, "[PBİD®]Create a Database by ADOX"
End Sub

'Module 2

'DataType property.


'Text1 = Text(Size)
'Text2 = CHAR(Size)
'Memo = MEMO
'Number:Byte= BYTE
'Number:Integer= SHORT
'Number:Long= LONG
'Number:Single= SINGLE
'Number:Double= DOUBLE
'Number:Replica= GUID
'Number:Decimal= DECIMAL (precision, scale)
'Date/Time= DATETIME
'Currency= CURRENCY
'Auto Number= COUNTER (seed, increment)
'Yes/No= YESNO
'OLE Object= LONGBINARY


Option Explicit
Dim CN As ADODB.Connection
Dim Komut As New ADODB.Command
Dim DosyaDeseni
Dim Yol As String, Dosya As String, Tablo As String
Sub KayıtTablosuDüzenlemek()
'Create Table

On Error GoTo Hata
Yol = "C:\"
Dosya = "Örnek.mdb"
Tablo = "Tablo1"
Set CN = New ADODB.Connection
CN.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & Yol & Dosya & ";"
On Error GoTo Hata
DosyaDeseni = " CREATE TABLE " & Tablo _
& " (" _
& "ID COUNTER(1,1), " _
& "ADI TEXT(60), " _
& "SOYADI TEXT(60), " _
& "DTARIHI DATETIME" _
& ")"
Komut.CommandText = DosyaDeseni
Komut.ActiveConnection = CN
Komut.Execute
Set CN = Nothing
Set Komut = Nothing
Exit Sub
Hata:
Set CN = Nothing
Set Komut = Nothing
MsgBox "Kayıt Tablosu Düzenleme Hatası" & Chr(10) & Chr(10) & "Hata No: " & Err & Chr(10) & "Hata Tanımı: " & VBA.Err.Description, vbInformation, "[PBİD®]Kayıt Tablosu (Create Table)"
End Sub

'Module3

Option Explicit
Dim DB As DAO.Database
Dim RS As DAO.Recordset
Dim Satır As Long
Dim Yol As String, Dosya As String, Tablo As String
Sub ExceldenAccesseDAOVeriAl()
'ExcelToAccessTransferByDAO

Yol = "C:\"
Dosya = "Örnek.mdb"
Tablo = "Tablo1"
Set DB = OpenDatabase(Yol & Dosya)
Set RS = DB.OpenRecordset(Tablo, dbOpenTable)
Satır = 2
Do While (VBA.Len(Range("A" & Satır).Formula) > 0)'VeriVarsa
With RS
.AddNew
.Fields("ID") = Range("A" & Satır).Value
.Fields("ADI") = Application.WorksheetFunction.Proper(Range("B" & Satır).Value)
.Fields("SOYADI") = VBA.UCase(Range("C" & Satır).Value)
.Fields("DTARIHI") = VBA.Format(VBA.CDate(Range("D" & Satır).Value), "dd.mm.yyyy")
.Update
End With
Satır = Satır + 1
Loop
RS.Close: Set RS = Nothing
DB.Close: Set DB = Nothing
End Sub
Sub AccesstenExceleDAOVeriAl()
'AccessToExcelTransferByDAO

Yol = "C:\"
Dosya = "Örnek.mdb"
Tablo = "Tablo1"
Set DB = OpenDatabase(Yol & Dosya)
Set RS = DB.OpenRecordset(Tablo, dbOpenTable)
Satır = 1
Do While RS.EOF = False
With RS
Cells(Satır, 1) = .Fields("ID")
Cells(Satır, 2) = Application.WorksheetFunction.Proper(.Fields("ADI"))
Cells(Satır, 3) = VBA.UCase(.Fields("SOYADI"))
Cells(Satır, 4) = VBA.Format(.Fields("DTARIHI"), "dd.mm.yyyy")
Satır = Satır + 1
.MoveNext
End With
Loop
RS.Close: Set RS = Nothing
DB.Close: Set DB = Nothing
End Sub

'Module4

Option Explicit
Dim CN As ADODB.Connection
Dim RS As ADODB.Recordset
Dim Satır As Long
Dim Yol As String, Dosya As String, Tablo As String
Sub ExceldenAccesseADOVeriAl()
'ExcelToAccessTransferByADO

Yol = "C:\"
Dosya = "Örnek.mdb"
Tablo = "Tablo1"
Set CN = New ADODB.Connection
CN.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & Yol & Dosya & ";"
Set RS = New ADODB.Recordset
RS.Open Tablo, CN, adOpenKeyset, adLockOptimistic, adCmdTable
Satır = 1
Do While (VBA.Len(Range("A" & Satır).Formula) > 0)'VeriVarsa
With RS
.AddNew
.Fields("ID") = Range("A" & Satır).Value
.Fields("ADI") = Application.WorksheetFunction.Proper(Range("B" & Satır).Value)
.Fields("SOYADI") = VBA.UCase(Range("C" & Satır).Value)
.Fields("DTARIHI") = VBA.Format(Range("D" & Satır).Value, "dd.mm.yyyy")
.Update
End With
Satır = Satır + 1
Loop
RS.Close: Set RS = Nothing
CN.Close: Set CN = Nothing
End Sub
Sub AccesstenExceleADOVeriAl()
'AccessToExcelTransferByADO

Yol = "C:\"
Dosya = "Örnek.mdb"
Tablo = "Tablo1"
Set CN = New ADODB.Connection
CN.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & Yol & Dosya & ";"
Set RS = New ADODB.Recordset
RS.Open Tablo, CN, adOpenKeyset, adLockOptimistic, adCmdTable
Satır = 1
Do While RS.EOF = False
With RS
Range("A" & Satır).Value = .Fields("ID")
Range("B" & Satır).Value = Application.WorksheetFunction.Proper(.Fields("ADI"))
Range("C" & Satır).Value = VBA.UCase(.Fields("SOYADI"))
Range("D" & Satır).Value = VBA.Format(.Fields("DTARIHI"), "dd.mm.yyyy")
.MoveNext
End With
Satır = Satır + 1
Loop
RS.Close: Set RS = Nothing
CN.Close: Set CN = Nothing
End Sub

'Module5

References Description= Microsoft DAO x.xx Object Library.
Option Explicit
Dim DB As DAO.Database
Dim RS As DAO.Recordset
Dim Satır As Long, Kolon As Long
Dim Yol As String, Dosya As String, Tablo As String
Dim HedefAlan As Range
Sub AccesstenExceleDAOTümVeriAl()
'AccessToExcelAllTransferByDAO

Yol = "C:\"
Dosya = "Örnek.mdb"
Tablo = "Tablo1"
Set HedefAlan = ThisWorkbook.Sheets("Sayfa1").Cells(1, 1)
Set DB = OpenDatabase(Yol & Dosya)
Set RS = DB.OpenRecordset(Tablo, dbOpenTable) 'All records
For Kolon = 0 To RS.Fields.Count - 1
HedefAlan.Offset(0, Kolon).Value = RS.Fields(Kolon).Name
Next
HedefAlan.Offset(1, 0).CopyFromRecordset RS
RS.Close: Set RS = Nothing
DB.Close: Set DB = Nothing
End Sub
Sub AccesstenExceleDAOTekVeriAl() '
AccessToExcelSingleTransferByDAO

Yol = "C:\"
Dosya = "Örnek.mdb"
Tablo = "Tablo1"
Set HedefAlan = ThisWorkbook.Sheets("Sayfa1").Cells(1, 1)
Set DB = OpenDatabase(Yol & Dosya)
Set RS = DB.OpenRecordset(Tablo, dbOpenTable) 'All records
Satır = 0
With RS
If Not .BOF Then .MoveFirst
While .EOF = False
HedefAlan.Offset(Satır, 0).Formula = .Fields("ADI")
.MoveNext
Satır = Satır + 1
Wend
End With
RS.Close: Set RS = Nothing
DB.Close: Set DB = Nothing
End Sub

'Module6
Option Explicit
Dim i As Single
Dim CN As ADODB.Connection
Dim RS As ADODB.Recordset
Dim Satır As Integer, Kolon As Integer
Dim Yol As String, Dosya As String, Tablo As String
Dim HedefAlan As Range
Sub AccesstenExceleADOTümVeriAl()
'AccessToExcelAllTransferByADO

Yol = "C:\"
Dosya = "Örnek.mdb"
Tablo = "Tablo1"
Set HedefAlan = ThisWorkbook.Sheets("Sayfa1").Cells(1, 1)
Set CN = New ADODB.Connection
CN.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & Yol & Dosya & ";"
Set RS = New ADODB.Recordset
With RS
.Open Tablo, CN, adOpenStatic, adLockOptimistic, adCmdTable
For Kolon = 0 To RS.Fields.Count - 1 'Fields Name
HedefAlan.Offset(0, Kolon).Value = RS.Fields(Kolon).Name
Next
HedefAlan.Offset(1, 0).CopyFromRecordset RS
End With
RS.Close: Set RS = Nothing
CN.Close: Set CN = Nothing
End Sub
Sub AccesstenExceleADOTekVeriAl()
'AccessToExcelSingleTransferByADO

Yol = "C:\"
Dosya = "Örnek.mdb"
Tablo = "Tablo1"
Satır = 1
Set HedefAlan = ThisWorkbook.Sheets("Sayfa1").Cells(1, 1)
Set CN = New ADODB.Connection
CN.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & Yol & Dosya & ";"
Set RS = New ADODB.Recordset
With RS
.Open Tablo, CN, adOpenStatic, adLockOptimistic, adCmdTable
.MoveFirst
For i = 1 To Satır
.MoveNext
Next i
For Kolon = 0 To RS.Fields.Count - 1 'Fields Name
HedefAlan.Offset(0, Kolon).Value = RS.Fields(Kolon).Name
HedefAlan.Offset(1, Kolon).Value = RS(Kolon)
Next
End With
RS.Close: Set RS = Nothing
CN.Close: Set CN = Nothing
End Sub

'Module7

Option Explicit
Dim Yol As String, Dosya As String
Sub VeriTabanıSil()
'Delete Data Base

Yol = "C:\"
Dosya = "Örnek.mdb"
VeriTabanıSilmek Yol & Dosya, 1
End Sub
Function VeriTabanıSilmek(ByVal VeriTabanıAdı$, İşaret)
'Delete Data Base Function

On Error Resume Next
If İşaret = 0 Then GoTo İptal
If vbYes = MsgBox(Yol & Dosya & " Access veri tabanını silmek istediğinizden emin misiniz?", vbCritical + vbYesNo, "[PBİD®]Delete Access DataBase : " & VeriTabanıAdı) Then
GoTo İptal
Else
VeriTabanıSilmek = 0
End If
Exit Function
İptal:
VBA.Kill VeriTabanıAdı
VeriTabanıSilmek = 1
End Function

'Module8

Option Explicit
Dim Yol As String, Dosya As String, Tablo As String, İlişki As String
Dim CN As ADODB.Connection
Dim RS As ADODB.Recordset
Dim Komut As New ADODB.Command
Sub KayıtTablosunuSil()
'Delete Table

On Error GoTo Hata
Yol = "C:\"
Dosya = "Örnek.mdb"
Tablo = "Tablo1"
İlişki = " DROP TABLE " & Tablo
Komut.CommandText = İlişki
Set CN = New ADODB.Connection
CN.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & Yol & Dosya & ";"
Komut.ActiveConnection = CN
Komut.Execute
Durak:
Set RS = Nothing
Set Komut = Nothing
Exit Sub
Hata:
MsgBox "Kayıt tablosu Silme Hatası oluştu..." & Chr(10) & Chr(10) & "Hata No: " & VBA.Err.Number & Chr(10) & "Hata Tanımı: " & VBA.Err.Description, vbInformation, "[PBİD®] Delete Record Set"
Resume Durak
End Sub

'Module9

Option Explicit
Option Base 1
Dim Yol As String, Dosya As String, Tablo As String, İlişki As String
Dim CN As ADODB.Connection
Dim RS As ADODB.Recordset
Dim Komut As New ADODB.Command
Sub AccesstenKayıtGetir()
'SelectAndReturnRecordsADO

Yol = "C:\"
Dosya = "Örnek.mdb"
Tablo = "Tablo1"
Set CN = New ADODB.Connection
CN.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & Yol & Dosya & ";"
Set RS = New ADODB.Recordset
Set RS.ActiveConnection = CN
Set Komut = New ADODB.Command
Set Komut.ActiveConnection = CN
With Komut
.CommandText = " SELECT * " & " FROM " & Tablo & " WHERE ID Like '1%'"
.CommandType = adCmdText '1
.Execute
End With
RS.Open Komut
With ThisWorkbook.Sheets("Sayfa3")
With .Cells(1, 1)
.CurrentRegion.Clear
.Cells(1, 1) = .CopyFromRecordset(RS)

End With
End With
CN.Close: Set CN = Nothing
Set Komut = Nothing
Set RS = Nothing
End Sub

'Module10
Option Explicit
Option Base 1
Dim Yol As String, Dosya As String, Tablo As String, İlişki As String
Dim CN As ADODB.Connection
Dim RS As ADODB.Recordset
Dim Komut As New ADODB.Command
Sub AccesseKayıtGönder()
'UpdateSomeRecordsADODB

Yol = "C:\"
Dosya = "Örnek.mdb"
Tablo = "Tablo1"
Set CN = New ADODB.Connection
CN.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & Yol & Dosya & ";"
Set Komut = New ADODB.Command
Set Komut.ActiveConnection = CN
İlişki = ""
İlişki = İlişki & " UPDATE " & Tablo
İlişki = İlişki & " SET ADI= 'Eflatun'"
İlişki = İlişki & " WHERE ID=6"
With Komut
.CommandText = İlişki
.CommandType = adCmdText
.Execute
End With
CN.Close: Set CN = Nothing
Set Komut = Nothing
End Sub

'Module11

Option Explicit
Option Base 1
Dim Yol As String, Dosya As String, Tablo As String, İlişki As String
Dim CN As ADODB.Connection
Dim RS As ADODB.Recordset
Dim Komut As New ADODB.Command
Sub AccessteKayıtSil()
'DeleteSomeRecordsADO

Yol = "C:\"
Dosya = "Örnek.mdb"
Tablo = "Tablo1"
Set CN = New ADODB.Connection
CN.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & Yol & Dosya & ";"
Set Komut = New ADODB.Command
Set Komut.ActiveConnection = CN
With Komut
.CommandText = " DELETE * " & " FROM " & Tablo & " WHERE ADI='Eflatun'"
.CommandType = adCmdText
.Execute
End With
CN.Close: Set CN = Nothing
Set Komut = Nothing
End Sub

'Module12
Option Explicit
Option Base 1
Dim Yol As String, Dosya As String, Tablo As String, İlişki As String
Dim CN As ADODB.Connection
Dim RS As ADODB.Recordset
Dim Komut As New ADODB.Command
Sub AccessteKayıtlarıSil()
'DeleteRecordsADO

Yol = "C:\"
Dosya = "Örnek.mdb"
Tablo = "Tablo1"
Set CN = New ADODB.Connection
CN.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & Yol & Dosya & ";"
Set Komut = New ADODB.Command
Set Komut.ActiveConnection = CN
With Komut
.CommandText = " DELETE *" & " FROM " & Tablo
.CommandType = adCmdText
.Execute
End With
CN.Close: Set CN = Nothing
Set Komut = Nothing
End Sub

'Module13
Option Explicit
Option Base 1
Dim Yol As String, Dosya As String, Tablo As String, İlişki As String, HedefTablo As String, DosyaDeseni As String
Dim CN As ADODB.Connection
Dim RS As ADODB.Recordset
Dim Komut As New ADODB.Command
Sub AccessteTablodanTabloyaVeriAktarmak1()


End Sub


'Module14

Option Explicit
Option Base 1
Dim Yol As String, Dosya As String, Tablo As String, İlişki As String, HedefTablo As String, DosyaDeseni As String
Dim CN As ADODB.Connection
Dim RS As ADODB.Recordset
Dim Komut As New ADODB.Command

Sub AccessteTablodanTabloyaVeriAktarmak2() 'CreateAnAccessTableFromAnExistingAccessTableADO
Yol = "C:\"
Dosya = "Örnek.mdb"
Tablo = "Tablo1"
HedefTablo = "Tablo2"
Set CN = New ADODB.Connection
CN.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & Yol & Dosya & ";"
DosyaDeseni = " CREATE TABLE " & HedefTablo _
& " (" _
& "ID COUNTER(1,1), " _
& "ADI TEXT(60), " _
& "SOYADI TEXT(60), " _
& "DTARIHI DATETIME" _
& ")"
Komut.CommandText = DosyaDeseni
Komut.ActiveConnection = CN
Komut.Execute
Set Komut = New ADODB.Command
Set Komut.ActiveConnection = CN
İlişki = ""
İlişki = İlişki & " DROP TABLE " & HedefTablo
With Komut
.CommandText = İlişki
.CommandType = adCmdText
.Execute
End With
İlişki = ""
İlişki = İlişki & " SELECT " & Tablo & ".* INTO " & HedefTablo
İlişki = İlişki & " FROM " & Tablo
With Komut
.CommandText = İlişki
.CommandType = adCmdText
.Execute
End With
CN.Close: Set CN = Nothing
Set Komut = Nothing
End Sub

10 Şubat 2007 Cumartesi

VBProject Referans Dosya (olb-tlb-dll-exe-ocx) ve Guid Yönetimi





UserForm1

A) Normal Reference Add

1 Visual Basıc For Applications;
2 Microsoft Excel 11.0 Object Library
3 Microsoft Forms 2.0 Object Library
4 Microsoft Windows Common Controls 6.0 (SP6)
5 OLE Automation
6 Microsoft Office 11.0 Object Library
7 Wicrosoft Office WebComponents 11.0
B) Tools Add on UserForm1\
1. Frame1
2. Frame1\Label1 ve Frame\Label2
3. Frame\Image1
4. ListBox1
5. CommandButton1
6. ComboBox1
7. TexBox1, TexBox2, TexBox3

Option Explicit
Dim i As Single, No As Single
Dim Aranan As Variant, Sorgu, Major As Double, Minor As Double
Private EkranBezeme As New Class1

Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®] VBProject Referans Dosya (olb-tlb-dll-exe-ocx) ve Guid Yönetimi"
Application.Visible = False
Application.VBE.MainWindow.Visible = False
Call EkranDüzenle
Call MevcutReferansListesi
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
On Error Resume Next
Application.Visible = True
End
End Sub
Private Sub CommandButton1_Click()
On Error Resume Next
If (TextBox1.Text <> "") Then Call HedeflenenReferansTaraması
End Sub
Sub EkranDüzenle()
On Error Resume Next
With Me
.Width = 510
.Height = 294.75
.BackColor = &H80000016
With Frame1
.Top = -2
.Left = -2
.Height = 36
.Width = Me.Width + 12
.Picture = LoadPicture("C:\Documents and Settings\PC\Desktop\BLOGSPOT\Örnekİkonlar\VistaWP01.bmp")
.PictureAlignment = fmPictureAlignmentTopLeft
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = False
With Label1
.Caption = " " & "Mustafa ULUSARAÇ"
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.Left = 30
.Top = 6
.Height = 12
.Width = 198
.Font.Bold = True
.ForeColor = &HFF0000
End With
With Label2
.Caption = " " & "01ulusarac@superonline.com"
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.Left = 30
.Top = 18
.Height = 12
.Width = 198
.Font.Bold = True
.ForeColor = &HFF0000
End With
With Image1
.BackStyle = fmBackStyleTransparent
.BorderColor = &HFF0000
.BorderStyle = fmBorderStyleSingle
.Top = 6
.Left = 6
.Height = 24
.Width = 24
.Picture = LoadPicture("C:\Documents and Settings\PC\Desktop\BLOGSPOT\Örnekİkonlar\PBİD.ico")
End With
End With
With ListBox1
.Top = 42
.Left = 6
.Width = 492
.Height = 198.05
.BackColor = &H80000001
.SpecialEffect = fmSpecialEffectEtched
.ColumnCount = 2
.ColumnWidths = "96;384"
.ForeColor = &HFF00&
End With
With CommandButton1
.Left = 6
.Top = 246
.Height = 18
.Width = 84
.Caption = "Reference Ekle"
End With
With ComboBox1
.Left = 96
.Top = 246
.Height = 18
.Width = 66
.AddItem "FormFile"
.AddItem "FormGuid"
.ListIndex = 0
.SpecialEffect = fmSpecialEffectEtched
End With
With TextBox1
.Left = 162
.Top = 246
.Height = 18
.Width = 300
.SpecialEffect = fmSpecialEffectEtched
End With
With TextBox2
.Left = 462
.Top = 246
.Height = 18
.Width = 18
.SpecialEffect = fmSpecialEffectEtched
.ControlTipText = "FormGuid Major"
End With
With TextBox3
.Left = 480
.Top = 246
.Height = 18
.Width = 18
.SpecialEffect = fmSpecialEffectEtched
.ControlTipText = "FormGuid Minor"

End With
End With
End Sub
Sub MevcutReferansListesi()
On Error Resume Next
ListBox1.Clear
For i = 1 To ThisWorkbook.VBProject.References.Count
No = ListBox1.ListCount
ListBox1.AddItem "References.Item": ListBox1.List(No, 1) = i: ListBox1.AddItem
ListBox1.List(No + 1, 0) = "References.Name": ListBox1.List(No + 1, 1) = ThisWorkbook.VBProject.References.item(i).Name: ListBox1.AddItem ""
ListBox1.List(No + 2, 0) = "References.Description": ListBox1.List(No + 2, 1) = ThisWorkbook.VBProject.References.item(i).Description: ListBox1.AddItem ""
ListBox1.List(No + 3, 0) = "References.FullPath": ListBox1.List(No + 3, 1) = ThisWorkbook.VBProject.References.item(i).FullPath: ListBox1.AddItem ""
ListBox1.List(No + 4, 0) = "References.BuiltIn": ListBox1.List(No + 4, 1) = ThisWorkbook.VBProject.References.item(i).BuiltIn: ListBox1.AddItem ""
ListBox1.List(No + 5, 0) = "References.GUID": ListBox1.List(No + 5, 1) = ThisWorkbook.VBProject.References.item(i).GUID: ListBox1.AddItem ""
ListBox1.List(No + 6, 0) = "References.IsBroken": ListBox1.List(No + 6, 1) = ThisWorkbook.VBProject.References.item(i).IsBroken: ListBox1.AddItem ""
ListBox1.List(No + 7, 0) = "References.Major": ListBox1.List(No + 7, 1) = ThisWorkbook.VBProject.References.item(i).Major: ListBox1.AddItem ""
ListBox1.List(No + 8, 0) = "References.Minor": ListBox1.List(No + 8, 1) = ThisWorkbook.VBProject.References.item(i).Minor: ListBox1.AddItem ""
ListBox1.List(No + 9, 0) = "References.Type": ListBox1.List(No + 9, 1) = ThisWorkbook.VBProject.References.item(i).Type: ListBox1.AddItem ""
ListBox1.List(No + 10, 0) = "References.VBE.Version": ListBox1.List(No + 10, 1) = ThisWorkbook.VBProject.References.item(i).VBE.Version: ListBox1.AddItem ""
Next
End Sub
Sub HedeflenenReferansTaraması()
On Error GoTo Hata
For i = 1 To ThisWorkbook.VBProject.References.Count
Aranan = ThisWorkbook.VBProject.References.item(i).Name
If Aranan = TextBox1.Text Then
MsgBox "Aranan Referans Bu Projede Mevcuttur..."
Exit Sub
End If
Next i
Sorgu = MsgBox("Referansın bu projeye eklenmesini istiyor musunuz?" & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbYesNo, "[PBİD®] VBA Project Referans Tercihi")
If ComboBox1.Value = "FormFile" Then
If Sorgu = vbYes Then ThisWorkbook.VBProject.References.AddFromFile TextBox1.Value 'Örnek: Outlook
Else
Major = TextBox2.Value: Minor = TextBox3.Value
If Sorgu = vbYes Then ThisWorkbook.VBProject.References.AddFromGuid TextBox1.Value, Major, Minor
'Örnek: OutLook; "{00062FFF-0000-0000-C000-000000000046}",9,2
End If
MsgBox "Referansın bu projeye eklendi." & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbExclamation, "[PBİD®] VBA Project Referans Tercihi"
Call MevcutReferansListesi
Exit Sub
Hata:
MsgBox "Referans bulunamadı." & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbExclamation, "[PBİD®] VBA Project Referans Tercihi"
End Sub

1 Şubat 2007 Perşembe

To Prepare The Accounting Trial Balance Based On Daily Records



'UserForm1

'A) Normal Reference Add

'1 Visual Basıc For Applications;
'2 Microsoft Excel 11.0 Object Library
'3 Microsoft Forms 2.0 Object Library
'4 Microsoft Windows Common Controls 6.0 (SP6)
'5 OLE Automation
'6 Microsoft Office 11.0 Object Library
'7 Wicrosoft Office WebComponents 11.0
'B) Tools Add on UserForm1\
'1. Frame1
'2. Frame1\Image1, Label1, Label2
'3. Label3, Label4, Label5, Label6, Label7, Label8, Label9, Label10, Label11, Label12, Label13
'4. ListBox1

Option Explicit
Dim i As Single, ii As Single
Dim No As Double, BorçToplam As Double, AlacakToplam As Double, KalanToplam As Double
Dim Alan As Range, Hücre As Range
Dim HesapNo As New Collection, Anahtar As String
Dim TakasH1, TakasH2, TakasB1, TakasB2, TakasA1, TakasA2
Dim Eleman
Private Sub UserForm_Initialize()

On Error Resume Next
Me.Caption = "[PBİD®] To Prepare The Accounting Trial Balance Based On Daily Records"
Application.Visible = True
Application.VBE.MainWindow.Visible = False
Call VeriTabanıHazırlama
Call EkranDüzenle
Call MizanHazırlamak
End Sub
Private Sub UserForm_Activate()

On Error Resume Next
With Me
.Top = (Application.Height - .Height) / 2
.Left = (Application.Width - .Width) / 2
End With
End Sub
Private Sub UserForm_Resize()

On Error Resume Next
With Me
.Top = (Application.Height - .Height) / 2
.Left = (Application.Width - .Width) / 2
End With
Call EkranDüzenle
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

On Error Resume Next
Application.Visible = True
End
End Sub
Sub EkranDüzenle()

On Error Resume Next
With Me
.BackColor = &H80000016
With Frame1
.Top = -2
.Left = -2
.Height = 36
.Width = Me.Width + 12
.Picture = LoadPicture("C:\Documents and Settings\PC\Desktop\BLOGSPOT\zarifVİSTA.bmp")
.PictureAlignment = fmPictureAlignmentTopLeft
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = False
With Image1
.BackStyle = fmBackStyleTransparent
.BorderColor = &HFF0000
.BorderStyle = fmBorderStyleSingle
.Top = 6
.Left = 6
.Height = 24
.Width = 24
.Picture = LoadPicture("C:\Documents and Settings\PC\Desktop\BLOGSPOT\Örnekİkonlar\PBİD.ico")
End With
With Label1
.Caption = " " & "Mustafa ULUSARAÇ"
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.Left = 30
.Top = 6
.Height = 12
.Width = 198
.Font.Bold = True
.ForeColor = &HFF0000
End With
With Label2
.Caption = " " & "01ulusarac@superonline.com"
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.Left = 30
.Top = 18
.Height = 12
.Width = 198
.Font.Bold = True
.ForeColor = &HFF0000
End With
With Label3
.Caption = "Müşteri Adı"
.SpecialEffect = fmSpecialEffectEtched
.Left = 6
.Top = 42
.Height = 18
.Width = 204
.Font.Bold = False
.ForeColor = &H404000
.TextAlign = fmTextAlignCenter
End With
With Label4
.Caption = "Borç Tutarı"
.SpecialEffect = fmSpecialEffectEtched
.Left = 210
.Top = 42
.Height = 18
.Width = 96
.Font.Bold = False
.ForeColor = &H404000
.TextAlign = fmTextAlignCenter
End With
With Label5
.Caption = "Alacak Tutarı"
.SpecialEffect = fmSpecialEffectEtched
.Left = 306
.Top = 42
.Height = 18
.Width = 96
.Font.Bold = False
.ForeColor = &H404000
.TextAlign = fmTextAlignCenter
End With
With Label6
.Caption = "Bakiye Tutar"
.SpecialEffect = fmSpecialEffectEtched
.Left = 402
.Top = 42
.Height = 18
.Width = 96
.Font.Bold = False
.ForeColor = &H404000
.TextAlign = fmTextAlignCenter
End With
With Label7
.Caption = " Kayıt Adet"
.SpecialEffect = fmSpecialEffectEtched
.Left = 6
.Top = 288
.Height = 18
.Width = 54
.Font.Bold = False
.ForeColor = &H404000
.TextAlign = fmTextAlignLeft
End With
With Label8
.Caption = ""
.SpecialEffect = fmSpecialEffectEtched
.Left = 60
.Top = 288
.Height = 18
.Width = 48
.Font.Bold = True
.ForeColor = &HFF0000
.TextAlign = fmTextAlignCenter
End With
With Label9
.Caption = " Müşteri Adet"
.SpecialEffect = fmSpecialEffectEtched
.Left = 108
.Top = 288
.Height = 18
.Width = 54
.Font.Bold = False
.ForeColor = &H404000
.TextAlign = fmTextAlignLeft
End With
With Label10
.Caption = ""
.SpecialEffect = fmSpecialEffectEtched
.Left = 162
.Top = 288
.Height = 18
.Width = 48
.Font.Bold = True
.ForeColor = &HFF0000
.TextAlign = fmTextAlignCenter
End With
With Label11
.Caption = ""
.SpecialEffect = fmSpecialEffectEtched
.Left = 210
.Top = 288
.Height = 18
.Width = 96
.Font.Bold = True
.ForeColor = &HFF0000
.TextAlign = fmTextAlignCenter
End With
With Label12
.Caption = ""
.SpecialEffect = fmSpecialEffectEtched
.Left = 306
.Top = 288
.Height = 18
.Width = 96
.Font.Bold = True
.ForeColor = &HFF0000
.TextAlign = fmTextAlignCenter
End With
With Label13
.Caption = ""
.SpecialEffect = fmSpecialEffectEtched
.Left = 402
.Top = 288
.Height = 18
.Width = 96
.Font.Bold = True
.ForeColor = &HFF0000
.TextAlign = fmTextAlignCenter
End With
With ListBox1
.Top = 60
.Left = 6
.Height = 227.3
.Width = 491.95
.ColumnCount = 4
.ColumnWidths = "204;96;96;96;12"
.BackColor = &H80000018
.SpecialEffect = fmSpecialEffectEtched
End With
End With
End With
End Sub
Sub MizanHazırlamak()
'To Prepare The Accounting Trial Balance

On Error Resume Next
No = Cells(65536, 1).End(xlUp).Row
Set Alan = Range("A2:A" & No)
ReDim Hesap(1 To No)
ReDim Borç(1 To No)
ReDim Alacak(1 To No)
No = 1
For Each Hücre In Alan
Anahtar = VBA.CStr(Hücre.Value)
HesapNo.Add Hücre.Value, Anahtar
If VBA.Err.Number = 0 Then
No = HesapNo.Count
Hesap(No) = Hücre.Value
Borç(No) = Hücre.Offset(0, 1)
Alacak(No) = Hücre.Offset(0, 2)
Else
No = Application.WorksheetFunction.Match(Hücre.Value, Hesap(), 0)
Borç(No) = Borç(No) + Hücre.Offset(0, 1).Value
Alacak(No) = Alacak(No) + Hücre.Offset(0, 2).Value
End If
VBA.Err.Number = 0
Next Hücre
On Error GoTo 0
For i = 1 To (HesapNo.Count - 1)
For ii = (i + 1) To HesapNo.Count
If Hesap(i) > Hesap(ii) Then
TakasH1 = Hesap(i)
TakasH2 = Hesap(ii)
TakasB1 = Borç(i)
TakasB2 = Borç(ii)
TakasA1 = Alacak(i)
TakasA2 = Alacak(ii)
Hesap(ii) = TakasH1
Borç(ii) = TakasB1
Alacak(ii) = TakasA1
Hesap(i) = TakasH2
Borç(i) = TakasB2
Alacak(i) = TakasA2
End If
Next ii
Next i
No = 0: BorçToplam = 0: AlacakToplam = 0: KalanToplam = 0
For Each Eleman In HesapNo
UserForm1.ListBox1.AddItem Eleman
ListBox1.List(No, 1) = Borç(No + 1)
BorçToplam = BorçToplam + Borç(No + 1)
ListBox1.List(No, 2) = Alacak(No + 1)
AlacakToplam = AlacakToplam + Alacak(No + 1)
ListBox1.List(No, 3) = Borç(No + 1) - Alacak(No + 1)
KalanToplam = KalanToplam + (Borç(No + 1) - Alacak(No + 1))
No = No + 1
Next Eleman
Label8.Caption = Alan.Count
Label10.Caption = HesapNo.Count
Label11 = VBA.Format(BorçToplam, "###,##0.00"): Range("F" & HesapNo.Count + 2) = VBA.CCur(BorçToplam)
Label12 = VBA.Format(AlacakToplam, "###,##0.00"): Range("G" & HesapNo.Count + 2) = VBA.CCur(AlacakToplam)
Label13 = VBA.Format(KalanToplam, "###,##0.00"): Range("H" & HesapNo.Count + 2) = VBA.CCur(KalanToplam)
Range("E2:H" & HesapNo.Count + 1).Value = ListBox1.List()
With Range("E" & HesapNo.Count + 2 & ":H" & HesapNo.Count + 2)
.Cells(1, 1) = "Toplam"
.Interior.ColorIndex = 5
.Interior.Pattern = xlSolid
.Font.ColorIndex = 2
End With
End Sub
Sub VeriTabanıHazırlama()
'To prepare the data base

On Error Resume Next
Cells.Delete Shift:=xlUp
Range("A1").FormulaR1C1 = "Müşteri No"
Range("B1").FormulaR1C1 = "Borç"
Range("C1").FormulaR1C1 = "Alacak"
Range("D1").FormulaR1C1 = "Kalan"
With Range("A1:D1")
.Font.Bold = True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("A:A").ColumnWidth = 24
Columns("B:D").ColumnWidth = 12
Range("A1:D1").Copy
Range("E1:H1").PasteSpecial xlPasteAll
Application.CutCopyMode = False
Columns("E:E").ColumnWidth = 24
Columns("F:G").ColumnWidth = 12
Range("A2").Select
For i = 1 To 20
For ii = 1 To 36
Cells(((i - 1) * 36) + ii + 1, 1) = "Müşteri " & ii
Cells(((i - 1) * 36) + ii + 1, 2) = VBA.CCur(VBA.Rnd * 30)
Cells(((i - 1) * 36) + ii + 1, 3) = VBA.CCur(VBA.Rnd * 10)
Cells(((i - 1) * 36) + ii + 1, 4) = Cells(((i - 1) * 36) + ii + 1, 2) - Cells(((i - 1) * 36) + ii + 1, 3)
Next ii
Next i
With Range("A1:H1")
.Interior.ColorIndex = 5
.Interior.Pattern = xlSolid
.Font.ColorIndex = 2
End With
End Sub

'Module

Sub FormAç()
On Error Resume Next
UserForm1.Show 0
End Sub

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