access ten okuyup rowsource etme

E

excellium

Katılım
16 Eylül 2005
Mesajlar
179
Excel Vers. ve Dili
Excel 2007 12.0
1,2 satır kod lazım arkadaşlar, sabırsızlıkla bekliyorum :yardim:

leventm bu konuda sizden yardım alabilirim sanırım
 
Son düzenleme:
E

excellium

Katılım
16 Eylül 2005
Mesajlar
179
Excel Vers. ve Dili
Excel 2007 12.0
.......................
access tablosundanki belli bir veri aralığını -ki select * from... ile okutabiliyorum- :

1) userform üzerinde combobox veya listbox a nasıl doldururum?

2) textbox veya optionbutton lara nasıl nasıl veri alırım?

3) vs. olayları excel hücreleri veya VBA componentlerine nasıl çekerim?

bi türlü yapamadım.
arayıp bulduklarım pek işime yaramadı.
yardımlarınızı bekliyorum,
1 - 2 satır kod yollarsanız yeterli olur.
teşekkürler...
 
E

excellium

Katılım
16 Eylül 2005
Mesajlar
179
Excel Vers. ve Dili
Excel 2007 12.0
access tablosundanki belli bir veri aralığını -ki select * from... ile okutabiliyorum- :

1) userform üzerinde combobox veya listbox a nasıl doldururum?

2) textbox veya optionbutton lara nasıl nasıl veri alırım?

3) vs. olayları excel hücreleri veya VBA componentlerine nasıl çekerim?

bi türlü yapamadım.
arayıp bulduklarım pek işime yaramadı.
yardımlarınızı bekliyorum,
1 - 2 satır kod yollarsanız yeterli olur.
teşekkürler...
 
E

excellium

Katılım
16 Eylül 2005
Mesajlar
179
Excel Vers. ve Dili
Excel 2007 12.0
ben hallettim

şirkette 5 arkadaşız. işlerimizi kendi client excel sayfamızdan giriyoruz. serverdaki access e atıyoruz, sonra hep birlikte hepsini okuyabliyoruz
 
M

mnz

Katılım
5 Eylül 2005
Mesajlar
282
Excel Vers. ve Dili
Excel 2002 (Tr)
Nasıl yaptığınızı buraya eklerseniz, biz de faydalanmış oluruz.
 
E

excellium

Katılım
16 Eylül 2005
Mesajlar
179
Excel Vers. ve Dili
Excel 2007 12.0
kayıtları raporlayıp yazdırabliyor ve mail atabiliyoruz. kayıtlar ortak bir access database ine yazılıyor. herkes o kayıtları görebiliyor. herkesin ayrı bir şifresi var ve en son login tarihlerini kaydedip gösteriyor. excel i gizleyince form kalıyor ve onun bir excel olduğunu kimse bilmiyor ;) dosyayı eklemek istedm ama 1,4 MB (dışardan çağırdığı dosyalar hariç).
programdan bir kaç satır göndereyim sn mnz

Kod: 
Dim adoCN As Object
Dim RS As Object
Dim strSQL As String
Dim DatabasePath As String
Sub AUTO_OPEN()
S3.Select
Call AppGG
FYKayıt.Show
Call DBCtrl
End Sub
Sub AppGG()
If S2.[D8] = 0 Then
Application.Visible = False
Application.ScreenUpdating = False
Else
Application.Visible = True
Application.ScreenUpdating = True
End If
End Sub
Sub DBCtrl()
    RemotePath = S2.[d5] '"[URL="file://\\10.0.0.221\TestTakip\Database\"]\\10.0.0.221\TestTakip\Database\[/URL]"
    DBName = S2.[d6]
    FilePath = S2.[D7]
On Error GoTo b
    Set adoCN = CreateObject("ADODB.Connection")
    DatabasePath = RemotePath & DBName
        If Dir(DatabasePath) = "" Then
            MsgBox DatabasePath & " dosyası bulunamadı. Belirtilen konumda olduğundan emin olunuz.", vbCritical, "Hata..."
            'Unload Me
            'FAyalar.Show
        End If
GoTo d
b:
    MsgBox DatabasePath & " yolu bulunamadı. Belirtilen yolun var olduğundan emin olunuz.", vbCritical, "Hata..."
    Exit Sub
d:
End Sub
Sub AUTO_CLOSE()
S3.Select
End Sub
Sub DBDis() 'db tanımlama
RemotePath = S2.[d5] 'uzakbilgisayar DB klasörü
DBName = S2.[d6] 'data.mdb
FilePath = S2.[D7] 'resim, flash ve raporların bulunduğu dizin
Set adoCN = CreateObject("ADODB.Connection") 'access e bağlan
DatabasePath = RemotePath & DBName 'db yolu
adoCN.Provider = "Microsoft.Jet.OLEDB.4.0"
adoCN.ConnectionString = DatabasePath
adoCN.Open
Set RS = CreateObject("ADODB.recordset") ' tabloya bağlan
RS.Open "TSettings", adoCN, 1, 3 'sorgu oluştur
SON = RS.RecordCount 'şu an gerekli değil ancak daha sonra kullanılacak
RS.Close
RS.Open "SELECT top 1 * FROM TSettings order by SN desc", adoCN, 1, 3 'tablonun en son satırını bul
 
        versiyonx = RS("versiyonx") 'ilgili tanımları çek
        versiyony = RS("versiyony")
        RemotePath = RS("RemotePath")
        DBName = RS("DBName")
        FilePath = RS("FilePath")
RS.Close 'tabloyu kapat
Set RS = Nothing
adoCN.Close 'veritabanını kapat
Set adoCN = Nothing
MyPath = ThisWorkbook.Path
versiyon = versiyonx & "." & versiyony
DBUserID = "Admin"
DBPass = ""
'loopx = 6
End Sub
Sub Makro3() 'mail gönder
    Sheets("print").Select
    Sheets("print").Copy
    ActiveWorkbook.SaveAs Filename:=FilePath & "\SendItem\TestRaporu " & Format(Now, "ddmmyyyyhhmm") & ".xls", _
        FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
 
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    ActiveSheet.EnableSelection = xlUnlockedCells
    Application.Dialogs(xlDialogSendMail).Show
    ActiveWindow.Close
    ThisWorkbook.Activate
    S3.Select
End Sub
FYKayıt (userform) kodları

Kod: 
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@   AKIF   @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@   AKIF   @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
Private Declare Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function EnableWindow Lib "user32" (ByVal hwnd As Long, ByVal bEnable As Long) As Long
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
Dim X, koşullar, ListboxSatır, metin, c As Integer
Dim metiniçinde As String
Dim Msg As String
Dim adoCN As Object
Dim RS As Object
Dim strSQL As String
Dim DatabasePath As String
Private Sub BExit_Click()
unload Me
End Sub
Private Sub BNot_Click()
    a = InputBox("Lütfen şifrenizi giriniz...", "Login")
    If a = 1 Then
    fnot.Show
    GoTo c
    End If
    MsgBox " Giriş iptal edildi.   "
c:
End Sub
Private Sub BTAc_Click()
durum = 1
FGozat2.Show
End Sub
Private Sub BTAc_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'ShockwaveFlash1.Movie = FilePath & "\Files\robo2.swf"
LStatus = "Kayıtlara göz atın..."
End Sub
Private Sub BTayarlar_Click()
a = InputBox("Lütfen şifrenizi giriniz...", "Login")
 
    If a = 1 Then
    FAyalar.Show
    GoTo c
    End If
 
    MsgBox " Giriş iptal edildi.   "
c:
End Sub
Private Sub BTAyarlar_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'ShockwaveFlash1.Movie = FilePath & "\Files\robo4.swf"
LStatus = "Program ayarlarını değiştirin..."
End Sub
Private Sub BTTest_Click()
FTest.Show
End Sub
Private Sub BTTest_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'ShockwaveFlash1.Movie = FilePath & "\Files\robo1.swf"
LStatus = "Yeni test kaydı açın..."
End Sub
Private Sub BTYazdır_Click()
durum = 0
FGozat2.Show
End Sub
Private Sub BTYazdır_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'ShockwaveFlash1.Movie = FilePath & "\Files\robo3.swf"
LStatus = "Kayıtları raporlayın..."
End Sub
Private Sub BTYeni_Click()
FEkle.Show 'LBaslık.SetFocus
End Sub
Private Sub BTYeni_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'ShockwaveFlash1.Movie = FilePath & "\Files\robo1.swf"
LStatus = "Yeni bir kayıt ekleyin..."
End Sub
'Private Sub PauseButton1_ButtonPressed()
'PlayAllButton1.Visible = True
'PauseButton1.Visible = False
'ShockwaveFlash2.Movie = "..."
'TextBox1.SetFocus
'Label71 = "Volume: ON"
'PlaySectionButton1.Visible = False
'Label72.Visible = False
'LB.AddItem Now & " - " & "Ses kapatıldı"
'Call logs
'End Sub
Private Sub PlayAllButton1_ButtonPressed()
PauseButton1.Visible = True
PlayAllButton1.Visible = False
ShockwaveFlash2.Movie = FilePath & "\Files\loop6.swf"
TextBox1.SetFocus
Label71 = "Volume: OFF"
PlaySectionButton1.Visible = True
Label72.Visible = True
LB.AddItem Now & " - " & "Ses Açıldı: Loop " & loopx & " çalıyor..."
Call logs
End Sub
Private Sub PlaySectionButton1_ButtonPressed()
If loopx = 6 Then loopx = 0
loopx = loopx + 1
ShockwaveFlash2.Movie = FilePath & "\Files\loop" & loopx & ".swf"
LB.AddItem Now & " - " & "Sonraki ses: loob " & loopx & " çalıyor..."
Call logs
End Sub
Private Sub Linf_Click()
End Sub
Private Sub TextBox1_Change()
If TextBox1 = "mao01" Then
TextBox2.Visible = True
TextBox2.SetFocus
Else
TextBox2 = ""
TextBox2.Visible = False
End If
End Sub
Private Sub TextBox2_Change()
If TextBox2 = "settings" Then FAyalar.Show
'If TextBox2 = "close" Then unload Me
If TextBox2 = "mehmetakiforakci" Then UserForm2.Show
End Sub
Private Sub UserForm_Initialize()
If S2.[d3] = "" Then
    CheckBox1.Value = False
Else
    CheckBox1.Value = True
    TB01 = S2.[d3].Value
End If
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
On Error GoTo a
    If adoCN.State = 1 Then
    adoCN.Close
    Else
    End
    End If
a:
Application.Visible = True
If S2.[D8] = 0 Then
    ActiveWorkbook.Save
    ActiveWorkbook.Close
Else
End If
End Sub
Private Sub BTLogin_Click()
LStatus = "Lütfen bekleyiniz..."
Call DBCtrl
Call DBDis
Set adoCN = CreateObject("ADODB.Connection")
DatabasePath = RemotePath & DBName
adoCN.Provider = "Microsoft.Jet.OLEDB.4.0"
adoCN.ConnectionString = DatabasePath
adoCN.Open
TextBox1.SetFocus
S2.Select
    If (TB01 = [h1].Value And TB02 = [h2].Value) Then
        Call anaekran
        Cells([h65536].End(3).Row + 1, "h") = Format(Now, "dd.mm.yyyy hh:mm:ss")
        Linf = "Kullanıcı       : " & TB01.Value & Chr(10) _
             & "Son ziyaretiniz : " & Format(Cells([h65536].End(3).Row - 1, "h"), "dd.mm.yyyy hh:mm:ss")
    Kullanıcı = TB01.Value
    ElseIf (TB01 = [i1].Value And TB02 = [i2].Value) Then
        Call anaekran
        Cells([i65536].End(3).Row + 1, "i") = Format(Now, "dd.mm.yyyy hh:mm:ss")
        Linf = "Kullanıcı       : " & TB01 & Chr(10) _
             & "Son ziyaretiniz : " & Format(Cells([i65536].End(3).Row - 1, "i"), "dd.mm.yyyy hh:mm:ss")
    Kullanıcı = TB01.Value
 
    ElseIf (TB01 = [j1].Value And TB02 = [j2].Value) Then
        Call anaekran
        Cells([j65536].End(3).Row + 1, "j") = Format(Now, "dd.mm.yyyy hh:mm:ss")
        Linf = "Kullanıcı       : " & TB01 & Chr(10) _
             & "Son ziyaretiniz : " & Format(Cells([j65536].End(3).Row - 1, "j"), "dd.mm.yyyy hh:mm:ss")
    Kullanıcı = TB01.Value
 
    Else
    Msg = MsgBox("Kullanıcı adı veya şifre yanlış. Lütfen tekrar deneyiniz." & Chr(10) _
        & "İptal ederseniz program kapatılacak.", vbOKCancel + vbCritical, "Login")
        If Msg = vbCancel Then
            ActiveWorkbook.Save
            ActiveWorkbook.Close
            Exit Sub
        Else
            TB02.SetFocus
            Exit Sub
        End If
    End If
 
    If CheckBox1.Value = True Then 'beni hatırla
    S2.[d3] = TB01.Value
    Else
    S2.[d3] = ""
    End If
 
    Label70 = "v" & versiyon
    Me.Caption = "Test Takip v" & versiyon
    loopx = 6
    'ShockwaveFlash2.Movie = FilePath & "\Files\loop" & loopx & ".swf"
    LB.AddItem Now & " - " & "''" & Kullanıcı & "''" & " adıyla login oldunuz. Son ziyaretiniz. " & Format(Cells(S2.[j65536].End(3).Row - 1, "j"), "dd.mm.yyyy hh:mm:ss") & " tarihindeydi."
    Call logs
LStatus = "H O Ş G E L D İ N İ Z . . . "
End Sub
Sub anaekran()
    FYKayıt.BTLogin.Visible = False
    FYKayıt.BTYeni.Visible = True
    FYKayıt.BTAc.Visible = True
    FYKayıt.BTYazdır.Visible = True
    FYKayıt.BExit.Visible = True
    FYKayıt.BTAyarlar.Visible = True
    FYKayıt.BTTest.Visible = True
    FYKayıt.BNot.Visible = True
    FYKayıt.Frame7.Visible = False
    FYKayıt.Image3.Picture = LoadPicture(FilePath & "\picture\kalem.jpg")
    'ShockwaveFlash1.Visible = True
    BTYeni.Picture = LoadPicture(FilePath & "\picture\new.gif")
    BTYazdır.Picture = LoadPicture(FilePath & "\picture\print.gif")
    BTAyarlar.Picture = LoadPicture(FilePath & "\picture\setting.gif")
    BTAc.Picture = LoadPicture(FilePath & "\picture\view.gif")
    BTTest.Picture = LoadPicture(FilePath & "\picture\star.gif")
    BExit.Picture = LoadPicture(FilePath & "\picture\exit.gif")
    BNot.Picture = LoadPicture(FilePath & "\picture\txt.gif")
End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
LStatus = ""
End Sub
Private Sub UserForm_Resize()
LB.AddItem Now & " - " & "Boyutlar: (T|L|H|W) " & Chr(10) & Me.Top & "|" & Me.Left & "|" & Me.Height & "|" & Me.Width
Call logs
End Sub
Sub logs()
LB.ListIndex = LB.ListCount - 1
End Sub
siteyi şişirmemişizdir inşallah, birilerinin işine yarar belki...
kolaygelsin
bir de şunu eklemek istiyorum

Kod: 
Private Sub BEkle_Click()
If TB3 = "" Or TB14 = "" Then
MsgBox "Gerekli alanları doldurunuz !"
Exit Sub
Else
End If
Msg = MsgBox("Yeni Kayıt Eklensin mi?", vbOKCancel + vbQuestion, "Yeni Kayıt")
        If Msg = vbCancel Then Exit Sub
'GENEL---------------------------------
'        SNo = ((CM1 - 10000) * 15) + 2
'        S2.Select
'        SonSat = S2.[a65536].End(3).Row
'        Cells(SonSat + 1, 1) = CM1.Value
'        Cells(SonSat + 1, 2) = TB2.Value
'        Cells(SonSat + 1, 3) = SNo
 
Set RS = Nothing
    Set RS = CreateObject("ADODB.recordset")
    RS.Open "TGenel", adoCN, 1, 3
    RS.AddNew
        RS("ISNO") = CInt(CM1.Value) 'İŞNO
        RS("ISPNO") = TB2.Value 'İKİNCİL İŞ NO
        RS("ISINADI") = TB3 'İŞ ADI
        RS("ISIYAPAN1") = TB14 'İŞİ YAPAN1
        RS("ISIYAPAN2") = TB15 'İŞİ YAPAN1
        RS("YONLENDIREN") = TB5
        RS("BASTARIH") = TB6
        RS("BASSAAT") = TB7
        RS("BITTARIH") = TB9
        RS("BITSAAT") = TB8
    RS.Update
    RS.Close
 
    RS.Open "TIstBilg", adoCN, 1, 3
    RS.AddNew
'İSTASYON------------------------------
        RS("ISNO") = CInt(CM1.Value)
        RS("PETSTI") = Txt_PetrolSirketi
        RS("ISTADI") = Cmb_IstAdi
        RS("ISTKODU") = Txt_IstKodu
        RS("TEL") = Txt_IstTel
        RS("ADRES") = Txt_IstAdresi
        RS("ISTILI") = Txt_IstIli
        RS("ISTUNV") = Cmb_IstUnvani
        RS("FAX") = Txt_IstFax
'SİSTEM BİLGİLERİ----------------------
    RS.Update
    RS.Close
 
    RS.Open "TSistBlg", adoCN, 1, 3
    RS.AddNew
        RS("ISNO") = CInt(CM1.Value)
        For X = 0 To 11
            RS("B" & (X + 1)) = Controls("TB3" & X + 1)
            RS("B" & (X + 13)) = Controls("TB3" & X + 1 + 12)
        Next X
    RS.Update
    RS.Close
 
    RS.Open "TIsler", adoCN, 1, 3
    RS.AddNew
        RS("ISNO") = CInt(CM1.Value)
        RS("ISLEMLER") = TB41
        RS("HATALAR") = TB42
        RS("SONUCLAR") = TB43
        RS("ISLEMLER1") = TB410
        RS("HATALAR1") = TB420
        RS("SONUCLAR1") = TB430
 
    RS.Update
    RS.Close
 
''-----------------------------------
Set RS = Nothing
    Msg = MsgBox(" Kayıt Eklendi. ", vbOKOnly, "Yeni Kayıt")
    FYKayıt.LB.AddItem Now & " - " & "Yeni kayıt eklendi: " & IsNo + 1
Call FYKayıt.logs
    unload Me
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst