AccessTr.neT

Sayfalar: 1 2

Merhaba arkadaşlar,

Ekteki sistemde Sayın Taruz un yaptığı güncelleme sistemini kullanıyorum. Bu sistem bir XML dosyasını internet üzerinden kontrol edilerek içerisindeki link ile yeni access.mdb dosyası ile güncelleme yapıyor. Yalnız bunun için internet alanına bir hosting e ihtiyaç var. Dropbox veya Google ın drive sisteminde yeni güncellemelerle bu işlemi yaptıramadım. Benimde aklıma şu geldi, benim tablolarım zaten Sql üzerinden çalışıyor. Sistemin XML üzerinden alacağı bilgileri ben Sql üzerinden tabloya girsem bu işlemi yaptırabilirim diye düşündüm. Bu kodlar üzerinde ne türlü değişiklikler yapmam gerekli. Fikir verebilecek olan arkadaşlar varsa çok sevinirim.

Kod aşağıdaki gibidir. Ayrıca ekteki dosyada FTrzSurumKontrol formunun kodlarıdır.

Kod:
Option Compare Database

#If VBA7 Then

Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias _

  "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal _

    szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

#Else

Private Declare Function URLDownloadToFile Lib "urlmon" Alias _

  "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal _

    szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

    #End If

Sub LinkTazele()

Open CurrentProject.Path & "\trz.txt" For Input As #1

Input #1, Text

Close #1

lnk = Mid(Text, InStr(1, Text, ":\") - 1)

lnk2 = lnk

Kill CurrentProject.Path & "\trz.txt"

If Right(lnk2, Len(lnk2) - InStrRev(lnk2, "\")) <> _

Right(lnk, Len(lnk) - InStrRev(lnk, "\")) Then

mesajtxt.Caption = "Dosyanın, veritabanı dosyanız olduğuna emin olun.."

mesajtxt.ForeColor = vbBlue

Else

Dim rst As New ADODB.Recordset

Dim sorgu As String

sorgu = "SELECT Name FROM MsysObjects WHERE Name Not Like '*" & "TMPC" & "*' AND Type=6 order by name desc"

rst.Open sorgu, CurrentProject.Connection, adOpenKeyset, adLockOptimistic

rst.MoveFirst

Do Until rst.EOF

Tablo = rst(0)

DoCmd.DeleteObject acTable, Tablo

DoCmd.TransferDatabase acLink, "Microsoft Access", lnk, acTable, Tablo, Tablo

rst.MoveNext

Loop

Set rst = Nothing

mesajtxt.Visible = True

mesajtxt.Caption = "Veritabanı dosyanız başarıyla bağlandı.."

mesajtxt.ForeColor = vbBlue

End If

End Sub

Private Sub Form_Open(Cancel As Integer)

DoCmd.MoveSize , , , 2400

If Len(Dir(CurrentProject.Path & "\trz.txt")) > 0 Then

LinkTazele

End If

On Error Resume Next

'Bağlantı adresini kopyaladığınız XML linkini burada tanımlayacaksınız..

XMLLink = "http://www.raykentlojistik.com.tr/userfiles/file/pbif.xml"

Metin1 = ""

Metin3.Caption = ""

tt = DFirst("ID", "tversiyon")

CurrentDb.Execute "delete from tversiyon where ID<>" & tt

ImportXML XMLLink, acAppendData

vv = DLast("versiyon", "tversiyon")

If vv <> DFirst("versiyon", "tversiyon") Then

Metin1 = DFirst("versiyon", "tversiyon")

Metin3.ForeColor = vbRed

Metin3.Caption = "Uygulamanın yeni bir sürümü (" & DLast("versiyon", "tversiyon") & ") mevcut.. " & Chr(10) & Chr(13) & _

"Yeni sürümü indirmek için tıklayınız.."

Komut0.Caption = "Şimdi değil.."

Else

Metin1 = DFirst("versiyon", "tversiyon")

Metin3.Caption = "Uygulamanın en son sürümünü kullanmaktasınız.." & vbNewLine & _

DFirst("mesaj", "tversiyon")

Metin3.ForeColor = vbBlack

End If

Metin7 = DLast("bilgi", "tversiyon")

End Sub

Function BagliTabloLinki(TabloAdi As String)

Dim db As DAO.Database, Ret

On Error GoTo DBNameErr

Set db = CurrentDb()

Ret = db.TableDefs(TabloAdi).Connect

BagliTabloLinki = Right(Ret, Len(Ret) - (InStr _

                                   (1, Ret, "DATABASE=") + 8))

Exit Function

DBNameErr:

BagliTabloLinki = 0

End Function

Sub BagliTabloLinkiKaydet()

Dim rs As New ADODB.Recordset

Dim sorgu As String

sorgu = "SELECT Name FROM MsysObjects WHERE Name Not Like '*" & "TMPC" & "*' AND Type=6 order by name desc"

rs.Open sorgu, CurrentProject.Connection, adOpenKeyset, adLockOptimistic

If rs.RecordCount = 0 Then Exit Sub

baglitabloyolu = Len(Dir(BagliTabloLinki(rs(0))))

If baglitabloyolu <> 0 Or Mid(rs(0), 1, 4) <> "~TMP" Then

lnk = BagliTabloLinki(rs(0))

On Error Resume Next

    Dim objStream As stream

    Set objStream = New stream

    objStream.Open

    objStream.Position = 0

    objStream.Charset = "UTF-8"

    objStream.WriteText lnk

    objStream.SaveToFile CurrentProject.Path & "\trz.txt", adSaveCreateOverWrite

End If

Set rs = Nothing

End Sub

Private Sub Komut0_Click()

DoCmd.Close

End Sub

Private Sub Metin3_Click()

If Mid(Metin3.Caption, 13, 4) = "Yeni" Then

DoCmd.MoveSize , , , 4200

WebBrowser2.Visible = -1

Komut0.Top = 2500

WebBrowser2.Navigate _

          "about:<html><body scroll='no'>" & _

          "<center><img src='http://dl.dropbox.com/u/78997398/trz-bekle.gif'></img></center></body></html>"

          On Error Resume Next

WebBrowser2.BorderThemeColorIndex = 5

mesajtxt.Visible = -1

mesajtxt.Caption = "İndiriliyor..."

Bekle 2

BagliTabloLinkiKaydet

    Set sas = CreateObject("Scripting.FileSystemObject")

Dim strSavePath As String

    Dim URL As String, ext As String

    Dim buf, Ret As Long

    URL = DLast("link", "tversiyon")

    buf = Split(URL, ".")

    ext = buf(UBound(buf))

    strSavePath = CurrentProject.Path & "\t" & CurrentProject.Name

    Ret = URLDownloadToFile(0, URL, strSavePath, 0, 0)

    If Ret = 0 Then

    WebBrowser2.Visible = 0

    mesajtxt.Visible = 0

    DoCmd.MoveSize , , , 2400

     MsgBox "Güncellediğiniz için teşekkür ederiz.." & vbNewLine & _

     "Yeni sürümün geçerli olması için uygulamayı yeniden başlatacağım..", vbInformation, "Taruz"

       TrzYenidenBaslat

    Else

        MsgBox "Hata oluştu..", vbCritical, "Taruz.."

        Quit

    End If

   Else

     MsgBox "Kullandığınız sürüm..: " & DFirst("versiyon", "tversiyon"), vbInformation, "Taruz.."

    End If

End Sub

Public Function Bekle(Sure As Single)

Dim Basla As Single

   On Error GoTo Bekle_Error

Basla = Timer

Do

DoEvents

Loop Until Basla + Sure < Timer

   On Error GoTo 0

   Exit Function

Bekle_Error:

End Function

Private Sub Metin3_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

MauseEL IDC_HAND

End Sub

Teşekkürler.

sayın Akifff,

bahsettiğiniz talebinize yönelik olarak;

İnternetten sürüm güncelleme

yukarıda bağlantısı yazılı olan ve sizin de bazı bilgilendirmeler ile katılımda bulunduğunuz konuyu hatırlatmak adına tekrar incelemeniz belki bir fikir verebilir.

bilginize...iyi çalışmalar,saygılar.

Sayın Atoz, bu konuda gelime sağladım.

Online txt dosyası yerine Sql üzerinden SürümGüncelleme tablosundaki değerleri uzaktan elle giriyorum. Yeni versyonun linkinide aynı tabloya ekliyorum. Uzaktaki bilgisayarlar güncelleme uyarısı alıyor. Fakat güncelleme yapınca dosya türü hatalı uyarısı veriyor ve veritabanı bozuluyor.

Bu durumda bu talebim aslında çözülmüş oldu. Veridiğini konuyu takip ediyorum bu konuyu kapatabilirsiniz. Saygılarımla...

sayın Akifff,

Alıntı:Bu durumda bu talebim aslında çözülmüş oldu

ifadeniz öncesinde yazdıklarınıza göre değerlendirilecek olunduğunda sanırım sorun hali hazırda devam ediyor veya bu belirttiğiniz sorunlara maruz kalıyorsunuz kullanımlar akabinde.

konunun kapatılmasını talep etmişsiniz fakat isterseniz bu sorunlarla hangi işlemi yaparken karşılaşıyorsunuz (aslında,ekran görüntülerini de konunuza dahil edebilirsiniz) veya bu işlemleri gerçekleştirirken kullandığınız uygulamanızın yeni bir hali mevcutsa bunu ekleyebilir ve bu uygulama üzerinden incelemeler söz konusu olabilir,bahsettiğiniz hatalara neden olan kod yazımları mevcutsa kontrol etmek adına.

site arama sayfasında araştırmak sureti ile uyarıları kapatma hususunda konuları inceleyebilir paylaşılan kodları deneyebilirsiniz.

dosya türü hatasını da doğru tanımlama yazmak sureti ile giderebilirsiniz.

son olarak;
eğer yine de konunuzun kapatılmasını ve Cevaplanmış Sorular kategorisi içerisine taşınmasını isterseniz elbette tercih ve takdir sizindir.bu mesaj,naçizane kendi adıma,henüz konunuzun çözüme ulaşmış olmadığı kanısı ile yazılmıştır.

bilginize...iyi çalışmalar,saygılar.

Tabiki kalsın eğer faydası olur derseniz ben yaptıklarımı paylaşmaktan memnuniyet duyarım. Hem benim sistemim hemde başka arkadaşların yaptıklarını düzeltmesi adına güzel olabilir. Teşekkürler. Ben burada sistemimden biraz bahsederim gün içerisinde.

Sayın Akifff,

Talebiniz doğrultusunda,konunuzun bu bahsini yaptığınız paylaşımları sunmanız için bir süre daha Sorular kategorisinde kalması uygun görülmüştür.

sadece çözüm bekleyen değil aynı zamanda gerek kendi ve gerekse de harici çabaları ve araştırmaları (kaldı ki,bunlar;kendinize her zaman için artı değer katan girişimler ve gelişmelerdir) nezdinde elde ettiği çözümleri paylaşıma sunma ve çözüm önerilerine alternatif öneriler de katabilmek ve aynı zamanda üreten de olmak adına bu yaklaşımınızdan dolayı teşekkür ederim.

gerektiğinde paylaşımlarınız üzerine yorum veya bilgilendirmelerin de yapılması söz konusu olacaktır,tam anlamda çözüm elde etmek ve konunun Cevaplanmış Sorular Kategorisi'ne taşınmasına geçerli zemin oluşturuncaya değin.

Bilginize…iyi çalışmalar,saygılar.

Sayfalar: 1 2

Akifff

atoz112

Akifff

atoz112

Akifff

atoz112