AccessTr.neT

Evet Atoz hocamın da talebiyle, konuyu devam ettirerek sizlerinde katılımlarıyla daha güzel bir online güncelleme sistemi yapmayı düşündüm. Dün yukarıdaki yazıyı yazdıktan sonra bir iki deneme daha yaptım ve sistemin stabil çalışmasını başardım. 

Öncelikle kodlarda hata yok. Sorun oluşturduğumuz online xml ve yeni sürüm dosyasının linkinde. Bazı arkadaşlar bu işi kendi web sitelerine veya benzer sistemlere koyarak direct link almışlar. Ama herkesin böyle bir imkanı olmayabilir. Daha önceki konularda GoogleDrive veya Dropbox üzerinden bu sürüm güncelleme işlemi yapılabiliyormuş. Ama son güncellemelerle bazı değişiklikler var. Direk googledrive a koyarak paylaşım linkiyle bu işlemi olmuyor Access xml dosyasını okumuyordu. 

GENEL ÇALIŞMA PRENSİBİ:
Şimdi nasıl çalıştığına kısaca değineceğim. Aşağıdaki ekte trz-dosya-guncelleme veritabanında bir form ve iki modülü sisteminize aktarın. Yine ekte sürüm kontol.xml adlı dosyayıda indirin. Bu dosya Drive üzerinde duracak ve siz bunun içerisine yeni sürümün linkini ve versyon bilgilerini felan gireceksiniz.

XML DOSYASINI ONLINE YAPMAK

Ben bu işlem için Google Drive kullanıyorum. Ama farklı bir şekilde link alınıyor. Bunun için aşağıdaki videoyu izleyiniz.




XML Dosyasının içerik bilgisi aşağıdaki gibidir. Kırmızılı alanları istediğiniz gibi ayarlayabilirsiniz. Bu yazdıklarınız diğer kullanıcılar güncelleme sayfasını açınca görülecektir.


"Yeni Sürümün Linki" kısmına upload edeceğimiz yeni veritabanımızın linkini koyacağız. Bu linkide aynı yukarıdaki videoda anlatılan upload yapmalıyız. Aksi halde hata verir. Ayrıca upload ettiğimiz veritabanımızın adı ile mevcut veritabanlarının adları aynı olmalı.


Bu işlemi de yaptıktan sonra sıra XML linkinin adresini mevcut veritabanımıza yerleştirelim.
Veritabanımızda FtrzSurumKontrol formunun kod satırlarına aşağıdaki gibi XML dosyamızın linkini giriyoruz.





Artık formu açtığınızda size xml dosyasına girdiğiniz bilgileri verecek ve güncelleme olduğunu söyleyecek. İndir derseniz yeni sürümü indirecek ve Access i yeniden başlattığınızda yeni sürümü kullanıyor olacaksınız. Yeniden uyarayım tablolarınız bağlı tablo olmalı aksi halde hata veriyor.


XML DOSYASINI DRİVE DAN GÜNCELLEME

Her yeni güncellemede drivedaki xml dosyasının içeriğini değiştirerek herkesin aynı güncellemeye erişmesini sağlayabilirsiniz. Bunun için drive daki dosyayı iki der silip yenisi yüklerseniz muhtemelen dosyanızın linki değişir. Uzaktaki diğer veritabanlarındaki linkler yeni link olmayacağı için sistem bir işe yaramaz. Google Drive da xml dosyasının online düzelnleme şansımız var. Bunun için Drive da xml edity adlı bir eklenti indirmemiz gerekli. Driveda xml dosyanızı açın ve yukarıdaki menüden daha fazla uygulama bağla ile XML Editey i Drive a bağlayın.






Şimdi XML dosyasını açınca yukarıdaki menüden XML Editey ile açın.




Artık linkinizi ve diğer bilgileri değiştirebilirsiniz. Değişiklikler otomatik olarak drive üzerindeki xml dosyanıza kaydedilecektir.



Evet ben bu şekilde sorunsuz olarak çalıştırdım. Yorum görüş ve önerilerinizi bekliyorum. Anlatımım çok iyi değil kusuruma bakmayın. Saygılarımla...




Not: Kullanım sırasında eksik referans hatası "Can't find project or library" alıyorsanız aşağıdaki referanslar eksik olabilir.

sayın Akifff,

eklediğiniz çalışmanızı kendi adıma inceleme ve deneme imkanım ve zamanım olmadı fakat,
ekran görsellerini de dahil etmek sureti ile anlaşılabilir bir anlatım ile açıklamalar sağladığınız ve paylaşımınız için teşekkür ederiz.emeğinize sağlık.

kendinizi geliştirme hususunda başarı grafiğinizin artması,paylaşımlarınızın ve konulara katılımlarınızın daim olması temennisi ile.

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

Arkadaşlar bu modülle ilgili bir sorun yaşıyorum. Bilgisi olan arkadaşlardan yardım bekliyorum....

Sn.Trz hocamın FTrzSurumKontrol ve FYedekleme projelerini kendi projeme dahil ettim. Ancak FYedekleme içinde olan bir modülde Split() fonksiyonu kullanılmış dolayısı ile sürümkontrol içindede aynı komut olduğundanmıdır nedir URL yi işaretleyip sorun çıkartıyor. Bir türlü düzeltemedim.

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üncelleme başarılı şekilde alındı." & vbNewLine & _

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

       TrzYenidenBaslat

sorun çıkardığını tahmin ettiğim modüle ait kodlar:

Option Compare Database

Option Explicit

Private Type Size

        cx As Long

        cy As Long

End Type



Private Const LF_FACESIZE = 32



Private Type LOGFONT

        lfHeight As Long

        lfWidth As Long

        lfEscapement As Long

        lfOrientation As Long

        lfWeight As Long

        lfItalic As Byte

        lfUnderline As Byte

        lfStrikeOut As Byte

        lfCharSet As Byte

        lfOutPrecision As Byte

        lfClipPrecision As Byte

        lfQuality As Byte

        lfPitchAndFamily As Byte

        lfFaceName As String * LF_FACESIZE

End Type



Private Declare Function apiCreateFontIndirect Lib "gdi32" Alias _

        "CreateFontIndirectA" (lplogfont As LOGFONT) As Long



Private Declare Function apiSelectObject Lib "gdi32" _

 Alias "SelectObject" (ByVal hDC As Long, ByVal hObject As Long) As Long



Private Declare Function apiGetDC Lib "user32" _

  Alias "GetDC" (ByVal hwnd As Long) As Long



Private Declare Function apiReleaseDC Lib "user32" _

  Alias "ReleaseDC" (ByVal hwnd As Long, _

  ByVal hDC As Long) As Long



Private Declare Function apiDeleteObject Lib "gdi32" _

  Alias "DeleteObject" (ByVal hObject As Long) As Long



Private Declare Function apiGetTextExtentPoint32 Lib "gdi32" _

Alias "GetTextExtentPoint32A" _

(ByVal hDC As Long, ByVal lpsz As String, ByVal cbString As Long, _

lpSize As Size) As Long



 Declare Function apiCreateIC Lib "gdi32" Alias "CreateICA" _

  (ByVal lpDriverName As String, ByVal lpDeviceName As String, _

  ByVal lpOutput As String, lpInitData As Any) As Long

  

 Declare Function apiDeleteDC Lib "gdi32" Alias "DeleteDC" _

  (ByVal hDC As Long) As Long



 Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long

 

 Private Declare Function GetDeviceCaps Lib "gdi32" _

 (ByVal hDC As Long, ByVal nIndex As Long) As Long

 

 Private Const SM_CXVSCROLL = 2

 Private Const LOGPIXELSX = 88

 



Function JustifyString(myctl As String, myfield As Variant, _

 col As Integer, RightOrCenter As Integer, Optional Sform As String = "") As Variant

 Dim UserControl As Control

 Dim UserForm As Form

 Dim lngWidth As Long



 Dim intSize As Integer

 Dim strText As String

 Dim lngL As Long

 Dim strColumnWidths As String

 Dim lngColumnWidth As Long

 Dim lngScrollBarWidth As Long

 Dim lngOneSpace As Long

 Dim lngFudge As Long

 Dim arrCols() As String

 Dim lngRet As Long





 On Error Resume Next

 lngFudge = 60



If Len(Sform & vbNullString) > 0 Then

    Set UserForm = Forms.FYedekleme.Controls(Sform).Form

Else

    Set UserForm = Forms.FYedekleme

End If

 Set UserControl = UserForm.Controls.Item(myctl)



 With UserControl

   If col > Split(arrCols(), .ColumnWidths, ";") Then Exit Function

   If col = .ColumnCount - 1 Then



     lngScrollBarWidth = GetSystemMetrics(SM_CXVSCROLL)

     lngScrollBarWidth = lngScrollBarWidth * (1440 / GetTwipsPerPixel())

   End If

   lngColumnWidth = Nz(Val(arrCols(col)), 1)

   lngColumnWidth = lngColumnWidth - (lngScrollBarWidth + lngFudge)

 End With



 strText = " "



 lngWidth = StringToTwips(UserControl, strText)



 If lngWidth > 0 Then

       lngOneSpace = Nz(lngWidth, 0)



       lngWidth = 0

 

     Select Case varType(myfield)

    

     Case 1 To 6, 7

     strText = str$(myfield)

    

     Case 8



     strText = myfield

    

     Case Else



        Call MsgBox("Field type must be Numeric, Date or String", vbOKOnly)

    

     End Select

    



     strText = Trim$(strText)



     lngWidth = StringToTwips(UserControl, strText)



     If lngWidth > 0 Then



         Select Case RightOrCenter

            Case -1



            strText = String(Int((lngColumnWidth - lngWidth) / lngOneSpace), " ") & strText

           

            Case 0



            strText = String((Int((lngColumnWidth - lngWidth) / lngOneSpace) / 2), " ") & strText _

               & String((Int((lngColumnWidth - lngWidth) / lngOneSpace) / 2), " ")

           

             Case 1



            strText = strText

           

             Case Else

        End Select

          JustifyString = strText

    End If

 End If



 Set UserControl = Nothing

 Set UserForm = Nothing

 

 End Function







 Function Split(ArrayReturn() As String, ByVal StringToSplit As String, _

 SplitAt As String) As Integer

   Dim intInstr As Integer

   Dim intCount As Integer

   Dim strTemp As String



   intCount = -1

   intInstr = InStr(StringToSplit, SplitAt)

   Do While intInstr > 0

     intCount = intCount + 1

     ReDim Preserve ArrayReturn(0 To intCount)

     ArrayReturn(intCount) = Left(StringToSplit, intInstr - 1)

     StringToSplit = Mid(StringToSplit, intInstr + 1)

     intInstr = InStr(StringToSplit, SplitAt)

   Loop

   If Len(StringToSplit) > 0 Then

     intCount = intCount + 1

     ReDim Preserve ArrayReturn(0 To intCount)

     ArrayReturn(intCount) = StringToSplit

   End If

   Split = intCount

 End Function





Private Function StringToTwips(ctl As Control, strText As String) As Long

    Dim myfont As LOGFONT

    Dim stfSize As Size

    Dim lngLength As Long

    Dim lngRet As Long

    Dim hDC As Long

    Dim lngscreenXdpi As Long

    Dim fontsize As Long

    Dim hfont As Long, prevhfont As Long

    

    hDC = apiGetDC(0&)

    

    lngscreenXdpi = GetTwipsPerPixel()

    



    With myfont

        .lfFaceName = ctl.FontName & Chr$(0)  'Terminate with Null

        fontsize = ctl.fontsize

        .lfWeight = ctl.FontWeight

        .lfItalic = ctl.FontItalic

        .lfUnderline = ctl.FontUnderline

    

        .lfHeight = (fontsize / 72) * -lngscreenXdpi

    End With

                                     

    hfont = apiCreateFontIndirect(myfont)

    prevhfont = apiSelectObject(hDC, hfont)

                

    lngLength = Len(strText)

    lngRet = apiGetTextExtentPoint32(hDC, strText, lngLength, stfSize)

    

    hfont = apiSelectObject(hDC, prevhfont)

    

    lngRet = apiDeleteObject(hfont)

        

    lngRet = apiReleaseDC(0&, hDC)

        

    StringToTwips = stfSize.cx * (1440 / GetTwipsPerPixel())

        

End Function





Private Function GetTwipsPerPixel() As Integer



    Dim lngIC As Long

    lngIC = apiCreateIC("DISPLAY", vbNullString, _

     vbNullString, vbNullString)

    

    If lngIC <> 0 Then

        GetTwipsPerPixel = GetDeviceCaps(lngIC, LOGPIXELSX)

        apiDeleteDC lngIC

    Else

        GetTwipsPerPixel = 120

    End If

 End Function

Arkadaşlar flood oluyor kusura bakmayınız ama sorunu aşağıdaki gibi çözdüm lakin bunların işlevleri aynı mı? şuana kadar bir hata vermedi ama....

ESKİ:

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

    buf = Split(URL, ".")

    ext = buf(UBound(buf))

YENİ:

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



    buf = StrConv(URL, ".")

    '////////////////////////buf = Split(URL, ".")

    ext = buf(UBound(buf))