ADO dosya açık ise

Barons · 16 Ağustos 2016

merhaba
Aşağıdaki kod ile kaynak dosyadan (ana.xlsm) database sayfası verilerini alabiliyorum ancak ana dosyanın kapalı olması gerekiyor.Eğer dosya açık ise dosyayı tekrar açmaya çalışıyor ve tabiki salt okunur açıyor.
Benim istediğim dosya açık iken dosyayı açıp kapatmadan verileri alması, yardımcı olursanız çok sevinirim.

teşekkürler

Kullandığım kod aşağıdadır.

Kullanıdğım kod aşağıdadır.

Sub veri_Al()
Dim Con As Object, rs As Object, Sorgu As String
Set Con = CreateObject("Adodb.Connection")
Set rs = CreateObject("Adodb.RecordSet")
Con.Open "provider=microsoft.ace.oledb.12.0;data source=" & "\\okan\d\ana.xlsm" & ";extended properties=""excel 12.0;hdr=no"""
Sorgu = "Select * from [database$] "
rs.Open Sorgu, Con, 1, 1
Range("A1").CopyFromRecordset rs
rs.Close: Con.Close
Set Con = Nothing: Set rs = Nothing: Sorgu = ""

End Sub

Barons · 16 Ağustos 2016

zor bir soru sorduğumun farkındayım))...ama Forumdaki Üstadların çözeceğine eminim...

Korhan Ayhan · 16 Ağustos 2016

Aşağıdaki kodu deneyiniz.

Kod:

Sub Veri_Al()
    Dim Con As Object, rs As Object, Sorgu As String, Yol As String, Dosya As String, K1 As Workbook
    
    Yol = "\\okan\d\"
    Dosya = "ana.xlsm"
    
    If Dosya_Acikmi(Yol & Dosya) Then
        Set K1 = Workbooks(Dosya)
        K1.Sheets("database").Range("A1").CurrentRegion.Copy Range("A1")
        K1.Close 0
    Else
        Set Con = CreateObject("Adodb.Connection")
        Set rs = CreateObject("Adodb.RecordSet")
        Con.Open "provider=microsoft.ace.oledb.12.0;data source=" & Yol & Dosya & ";extended properties=""excel 12.0;hdr=no"""
        Sorgu = "Select * from [database$] "
        rs.Open Sorgu, Con, 1, 1
        Range("A1").CopyFromRecordset rs
        rs.Close: Con.Close
        Set Con = Nothing: Set rs = Nothing: Sorgu = ""
    End If
End Sub

Function Dosya_Acikmi(Dosya_Adi As String)
    Dim Dosya_No As Integer, Hata_Kodu As Integer

    On Error Resume Next
    Dosya_No = FreeFile()
    Open Dosya_Adi For Input Lock Read As #Dosya_No
    Close Dosya_No
    Hata_Kodu = Err
    On Error GoTo 0
    
    Select Case Hata_Kodu
        Case 0
            Dosya_Acikmi = False
        Case 70
            Dosya_Acikmi = True
        Case Else
            Error Hata_Kodu
    End Select
End Function

Barons · 17 Ağustos 2016

Korhan hocam..teşekkürler ancak ana dosya kapalı iken veriler geldi ,ana dosyayı açıp tekrar çalıştır dediğimde şöyle bir hata verdi.

runtime error 9
subcript out of Range

hata verdiği yer ise;

set K1=workbooks(Dosya)

Barons · 17 Ağustos 2016

Korhan hocam...bazı denemeler yaptım ama olmuyor maalesef...sürekli o satırda hata veriyor.

halit3 · 17 Ağustos 2016

Alternatif olarak birde bunu denermisiniz.

Kod:

Sub Veri_Al()
Dim Con As Object, rs As Object, Sorgu As String, Yol As String, Dosya As String, K1 As Workbook
[COLOR="red"]Dim deg1[/COLOR]
Yol = "\\okan\d\"
Dosya = "ana.xlsm"

[COLOR="Red"]deg1 = ""

Dim wkbk As Workbook
For Each wkbk In Application.Workbooks
If wkbk.Name = "ana.xlsm" Then
deg1 = 1
End If
Next[/COLOR]


[COLOR="red"]If deg1 = 1 Then[/COLOR]
Set K1 = Workbooks(Dosya)
K1.Sheets("database").Range("A1").CurrentRegion.Copy Range("A1")
K1.Close 0
Else
Set Con = CreateObject("Adodb.Connection")
Set rs = CreateObject("Adodb.RecordSet")
Con.Open "provider=microsoft.ace.oledb.12.0;data source=" & Yol & Dosya & ";extended properties=""excel 12.0;hdr=no"""
Sorgu = "Select * from [database$] "
rs.Open Sorgu, Con, 1, 1
Range("A1").CopyFromRecordset rs
rs.Close: Con.Close
Set Con = Nothing: Set rs = Nothing: Sorgu = ""
End If
End Sub

veya bunu dene

Kod:

Sub Veri_Al()
Dim Con As Object, rs As Object, Sorgu As String, Yol As String, Dosya As String, K1 As Workbook

Yol = "\\okan\d\"
Dosya = "ana.xlsm"


[COLOR="Red"]Dim wkbk As Workbook
For Each wkbk In Application.Workbooks
If wkbk.Name = Dosya Then
Windows(wkbk.Name).Sheets("database").Range("A1").CurrentRegion.Copy Range("A1")
GoTo atla
End If
Next[/COLOR]

Set Con = CreateObject("Adodb.Connection")
Set rs = CreateObject("Adodb.RecordSet")
Con.Open "provider=microsoft.ace.oledb.12.0;data source=" & Yol & Dosya & ";extended properties=""excel 12.0;hdr=no"""
Sorgu = "Select * from [database$] "
rs.Open Sorgu, Con, 1, 1
Range("A1").CopyFromRecordset rs
rs.Close: Con.Close
Set Con = Nothing: Set rs = Nothing: Sorgu = ""
atla:

End Sub

Barons · 17 Ağustos 2016

Halit bey..kod çalıştığında (ana dosya açık ) tekrar ana dosyayı salt okunur olarak tekrar açtı ve aynı hatayı verdi.

runtime error 9
subcript out of Range

hatanın olduğu kod;

Con.Open "provider=microsoft.ace.oledb.12.0;data source=" & Yol & Dosya & ";extended properties=""excel 12.0;hdr=no"""

Korhan Ayhan · 17 Ağustos 2016

Ben şu şekilde denedim.

Masaüstünde iki dosya oluşturdum. Birisinin adı "ana.xlsm" diğerinin adı ise "Kitap1.xlsm"

Kod içindeki yolu da masaüstünü görecek şekilde ayarladım ve önerdiğim kodu çalıştırdığımda olumlu sonuç aldım.

Sizin "ana.xlsm" dosyanız nerede bulunuyor?

Barons · 17 Ağustos 2016

ana.xlsm dosyası başka bir bölümdeki bir arkadaşın bilgisayarında bulunmaktadır.Server üzerinden tüm Pc'ler birbirini verilen izinler doğrultusunda görmektedir.Ben tüm hepsini görmekteyim.zaten dosya kapalı iken anında veriler hızlı bir şekilde gelmektedir.sorun o dosyanın gün boyu açık olması ve veri giriliyor olması yani dosyayı kapatırma gibi bir durum yok..mecburen açık iken bağlanmak durumundayım.
teşekkürler

Korhan Ayhan · 17 Ağustos 2016

ADO konusuna çok vakıf değilim. Fakat başka pc'de açık olan bir dosyadan açık durumda iken veri alabileceğinizi zannetmiyorum.

Şöyle bir önerim olabilir. Dosyanın açık olması sorgulanır. Eğer açıksa "Dosya Açık daha sonra deneyiniz!" uyarısı verip veri almaktan vazgeçilir. Eğer kapalı ise güncel veriler aktarılır.

Barons · 18 Ağustos 2016

eğer mümkün değilse şunu yapsak olurmu acaba? eğer açık ise dosyanın bir kopyasını benim bilgisayarımda C'nin altına atsın ve oradan veriyi alayım,yok kapalı ise oradan alayım.
Bunun kodlaması nasıl olur?

halit3 · 18 Ağustos 2016

Merhaba
Şimdi ben iki bilgisayarı ağa bağladım ve veri alınacak dosya kapalı veya acık olması veri alma işlemini etkilemedi yani dosya kapalıda olsa açık da olsa ado ile veri alınabiliyor.

Burada şunu hatırlatayım windows7 de ağdaki bilgisayar kapalı veya uyku modun da ise o ağa erişilemiyor.

kullandığım kod:

Kod:

Sub aaverial2()

Dosya = Application.GetOpenFilename("All Files (*.*),*.*.")
If Dosya = False Then
MsgBox "Veri alınacak dosyayı seçmediniz.", vbInformation, "DİKKAT"
Exit Sub
Else
End If

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
yer3 = fL.GetBaseName(Dosya)
Uzanti = fL.GetExtensionName(Dosya)
sifre = "1234"

If Uzanti = "mdb" Or Uzanti = "accdb" Then Exit Sub

Cells.ClearContents
Cells.NumberFormat = "General"
Cells.Font.Bold = False
sat = 1

Dim Katalog As Object, Data3 As Object, Tablo As Object
Dim son1

Set Data = CreateObject("ADODB.Connection")
Dosya_Yolu = (Dosya)

Set Katalog = CreateObject("ADOX.Catalog")



If Uzanti = "xls" Then
Data.Open "Driver={Microsoft Excel Driver (*.xls)};Dbq=" & Dosya_Yolu & ";"
Else
Data.Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};Dbq=" & Dosya_Yolu & ";"
End If



Katalog.ActiveConnection = Data
For Each Tablo In Katalog.Tables
'MsgBox Tablo.Name
If InStr(1, Tablo.Type, "TABLE") > 0 Then
If Right(Tablo.Name, 19) <> "kaynağından_sorgula" Then
If Right(Tablo.Name, 14) <> "Yazdırma_Alanı" Then
son1 = Replace(Tablo.Name, "'", "")
If Right(son1, 1) <> "_" Then
If Right(son1, 1) = "$" Then

Sayfa_adı = Left$(son1, Len(son1) - 1)

Cells(sat, 1) = fL.GetFileName(Dosya)
Cells(sat, 2) = Tablo.Name



sat = sat + 1
Dim Kayit As ADODB.Recordset
Set Kayit = New ADODB.Recordset

If Uzanti = "xls" Then
baglan = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & Dosya & ";Extended Properties=""Excel 8.0;HDR=yes""" 'ofis 2003
Kayit.Open "SELECT * FROM [" & Sayfa_adı & "$] ", baglan, adOpenKeyset, adLockOptimistic
ElseIf Uzanti = "xlsb" Or Uzanti = "xlsx" Or Uzanti = "xlsm" Then
baglan = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & Dosya & ";Extended Properties=""Excel 12.0;HDR=yes""" 'ofis 2007
Kayit.Open "SELECT * FROM [" & Sayfa_adı & "$] ", baglan, adOpenKeyset, adLockOptimistic
Else
Exit Sub
End If


For i = 1 To Kayit.Fields.Count
Cells(sat, i) = Kayit.Fields(i - 1).Name
Cells(sat, i).NumberFormat = "@"
Cells(sat, i).Font.Bold = True
Next i
sat = sat + 1

Range("A" & sat).CopyFromRecordset Kayit
sat = Cells(Rows.Count, "a").End(3).Row + 1

Kayit.Close

'Exit For
End If
End If
End If
End If
End If
Next
Data.Close
Set Data = Nothing
Set Katalog = Nothing

MsgBox "işlem tamam"

End Sub

halit3 · 18 Ağustos 2016

Bu kod bende çalışıyor.
dosya kapalıysa düzgün çalışıyor. dosya açıksa salt okunur olarak açıyor dosyadan verileri alıyor ve dosyayı kapatıyor.

Kod:

Private Sub CommandButton1_Click()

Dim Con As Object, rs As Object, Sorgu As String, Yol As String, Dosya As String, K1 As Workbook

Yol = "\\okan\d\"
Dosya = "ana.xlsm"

'Exit Sub
Set Con = CreateObject("Adodb.Connection")
Set rs = CreateObject("Adodb.RecordSet")
Con.Open "provider=microsoft.ace.oledb.12.0;data source=" & Yol & Dosya & ";extended properties=""excel 12.0;hdr=no"""
Sorgu = "Select * from [database$] "
rs.Open Sorgu, Con, 1, 1
Range("A1").CopyFromRecordset rs
rs.Close: Con.Close
Set Con = Nothing: Set rs = Nothing: Sorgu = ""


[COLOR="Red"]Dim wkbk As Workbook
For Each wkbk In Application.Workbooks
If wkbk.Name = Dosya Then
Application.DisplayAlerts = False
wkbk.Close

End If
Next[/COLOR]

End Sub

halit3 · 18 Ağustos 2016

11 nolu mesajınızla ilgili kod

Kod:

Private Sub CommandButton1_Click()

Dim Con As Object, rs As Object, Sorgu As String, Yol As String, dosya As String, K1 As Workbook


Yol = "\\okan\d\"
dosya = "ana.xlsm"

Dim Kayıt_Yeri As String

Application.DisplayAlerts = False
Kayıt_Yeri = ThisWorkbook.Path & "\" & dosya
CreateObject("Scripting.FileSystemObject").CopyFile Yol & dosya, Kayıt_Yeri
Application.DisplayAlerts = True


Set Con = CreateObject("Adodb.Connection")
Set rs = CreateObject("Adodb.RecordSet")
Con.Open "provider=microsoft.ace.oledb.12.0;data source=" & Kayıt_Yeri & ";extended properties=""excel 12.0;hdr=no"""
Sorgu = "Select * from [database$] "
rs.Open Sorgu, Con, 1, 1
Range("A1").CopyFromRecordset rs
rs.Close: Con.Close
Set Con = Nothing: Set rs = Nothing: Sorgu = ""
atla:


End Sub

Barons · 18 Ağustos 2016

Son kod hariç hepsinde hata ve ana dosyayı salt okunur açma eylemi gerçekleşti.
Halit bey en son yazılan kod sorunsuz çalıştı..zaman ayırdığınız için çok teşekkürler..Korhan hocam sizede çok teşekkür ederim.

iyi çalışmalar

ADO dosya açık ise

Barons

Barons

Korhan Ayhan

Administrator

Barons

Barons

halit3

Uzman

Barons

Korhan Ayhan

Administrator

Barons

Korhan Ayhan

Administrator

Barons

halit3

Uzman

halit3

Uzman

halit3

Uzman

Barons