Skip to main content

AccessTr.neT


SQL üzerinden Access Sürüm Güncelleme

SQL üzerinden Access Sürüm Güncelleme

Question #1
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.
.rar pbifsurumkontroldeneme.rar (Dosya Boyutu: 926,3 KB | İndirme Sayısı: 12)
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da

Bu Konudaki Yorumlar
SQL üzerinden Access Sürüm Güncelleme - Yazar: Akifff - 27/02/2016, 10:56
Task