Skip to main content

AccessTr.neT


Vcard Paylaşımı Nasıl Yapabiliriz

Vcard Paylaşımı Nasıl Yapabiliriz

Çözüldü #1
Şurda güzel bir paylaşım var
******************

İlgilenenler şurayada bakabilir
******************

Option Compare Database
Option Explicit

Private Sub Command0_Click()
    Dim rs As Recordset: Set rs = CurrentDb.OpenRecordset("table_name")
    Dim line As Variant
   
    For Each line In GetFileLines("file_address", True, True, False)
        ' Code depends on format of file.
        ' Example
        rs.AddNew
            rs!Field = Split(line, ",")(0)
            rs!Field = Split(line, ",")(1)
            rs!Field = Split(line, ",")(2)
            rs!Field = Split(line, ",")(3)
        rs.Update
    Next
    rs.Close
End Sub

' Reference Microsoft Scriping Runtime
  
Public Function GetFileLines(ByVal address As String, _
                             ByVal remove_blank_lines As Boolean, _
                             ByVal trim_lines As Boolean, _
                             ByVal keep_newline_char)
   
    ' keep_newline_char represents the Chr(byte) value of 10 and 13. These Bytes represent a NewLine.
    ' passing a true value to this parameter will cause returned lines to contain the new line value at the end of them.
    ' Use: True - Displaying data in a message
    '      False - Parsing the data line by line.
   
                            
    Dim fs As New FileSystemObject
   
    Dim arr_bytes() As Byte
    Dim file_node As Long

    Dim lines() As String
    Dim line_count As Long: line_count = 0
   
    Dim var_byte As Variant
   
    ReDim lines(line_count)
       
    If fs.FileExists(address) Then
   
        ReDim arr_bytes(FileLen(address))
        file_node = FreeFile
       
        Open address For Binary Access Read As file_node
            Get 1, , arr_bytes
        Close file_node
       
        For Each var_byte In arr_bytes
           
            If var_byte = 10 Or var_byte = 13 Then
                If trim_lines Then: lines(line_count) = Trim(lines(line_count))
               
                If remove_blank_lines And Trim(lines(line_count)) = "" Then
                    lines(line_count) = ""
                Else
                    If keep_newline_char Then: lines(line_count) = lines(line_count) & Chr(var_byte)
                    line_count = line_count + 1
                    ReDim Preserve lines(line_count)
                End If
               
            Else
                lines(line_count) = lines(line_count) & Chr(var_byte)
            End If
           
            var_byte = Empty
           
        Next
       
    End If
   
    ' If your last result is wonky, focus on the following line. It was a quick fix for me Img-grin
    lines(line_count) = Left(lines(line_count), Len(lines(line_count)) - 1)

    ReDim arr_bytes(0)
    Set fs = Nothing
    file_node = Empty
    line_count = Empty
   
    GetFileLines = lines
   
    ReDim lines(0)
   
End Function


burada örnek vcf dosyasını csv ve xlsx e dönüştüren örnek var

buradada Excel dosyasını vcf ye dönüştüren uygulama var
.rar vcf2xlsx.rar (Dosya Boyutu: 591,67 KB | İndirme Sayısı: 5)
.rar excel-to-vcard.rar (Dosya Boyutu: 2,99 MB | İndirme Sayısı: 6)
@benbendedeilem
Son Düzenleme: 31/05/2020, 11:13, Düzenleyen: accessman.
Cevapla
#2
Soru mu sordunuz? Örnek Uygulama mı eklediniz?
Gelişmemiş Vcard Oluşturma Uygulaması
Vcard (Outlook Veya Gmail) Oluşturma Uygulaması Versiyon 2
Cevapla
#3
"Vcard Paylaşımı Nasıl Yapabiliriz" diye soru sordum
un, şeker, yağ bulduklarımı ekleyip helva yapmaya çalışıyorum
Create a Contact item from a vCard file and save the item in a folder
Private Sub ImportContacts( _
    ByVal path As String, ByVal targetFolder As Outlook.Folder)
    Dim contact As Outlook.ContactItem
    Dim moveContact As Outlook.ContactItem
    If (Directory.Exists(path)) Then
        Dim files As String() = Directory.GetFiles(path, "*.vcf")
        For Each file As String In files
            contact = CType(Application.Session.OpenSharedItem(file), _
                Outlook.ContactItem)
            If (targetFolder Is _
                CType(Application.Session.GetDefaultFolder( _
                    Outlook.OlDefaultFolders.olFolderContacts) _
                    , Outlook.Folder)) Then
                contact.Save()
            Else
                moveContact = CType(contact.Move(targetFolder), _
                    Outlook.ContactItem)
                moveContact.Save()
            End If
        Next
    End If
End Sub

Sub CreateTextFileBasic()
    'Must add reference to Tools > References > Microsoft Scripting Runtime
    Dim fso As Scripting.FileSystemObject
    Dim Satir As Scripting.TextStream
   
    Set fso = New Scripting.FileSystemObject
    Set Satir = fso.CreateTextFile("C:\test\test.vcf", True)
   
        Satir.WriteLine "begin:vcard"
        Satir.WriteLine "BDAY;VALUE=DATE:" & "1957-09-21"
        Satir.WriteLine "N:" & "Stenerson;Derik"
        Satir.WriteLine "fn:" & "ramazan"
        Satir.WriteLine "TITLE:" & "vcf yaz"
        Satir.WriteLine "org:" & "accessmania"
        Satir.WriteLine "tel;TYPE=FAX:" & "5050801711"
        Satir.WriteLine "TEL;TYPE=WORK,FAX:" & "+1-425-936-7329"
        Satir.WriteLine "TEL;TYPE=WORK,MSG:" & "+1-425-936-5522"
        Satir.WriteLine "tel;cell;voice:" & "9999999999"
        Satir.WriteLine "tel;work;voice:" & "8888888888" '& (IIf(Not IsNull(Me!Dahili), " Dahili:" & Me![Dahili], ""))
        'Satir.WriteLine "adr;type=work:;;" & "Denizli" ' & ";" & Me![?ehir] & ";" & Me![Ylçe] & ";" & Me![Posta Kodu]
        Satir.WriteLine "ADR;TYPE=WORK,POSTAL,PARCEL:" & ";;One Microsoft Way;Redmond;WA;98052-6399;USA"
        Satir.WriteLine "email;internet:" & "eeeeeeee"
        Satir.WriteLine "EMAIL;TYPE=INTERNET:" & "deriks@microsoft.com"
        Satir.WriteLine "version:" & "2.1" '"3.0"
        Satir.WriteLine "End: vcard"

    Satir.Close

End Sub
bunun ile var olan dosya üzerine yazılıyor
dosya yok ise nasıl oluşturuyoruz
@benbendedeilem
Son Düzenleme: 31/05/2020, 11:15, Düzenleyen: accessman.
Cevapla
#4
(31/05/2020, 10:03)ozanakkaya yazdı: Soru mu sordunuz? Örnek Uygulama mı eklediniz?

Gelişmemiş Vcard Oluşturma Uygulaması
Vcard (Outlook Veya Gmail) Oluşturma Uygulaması Versiyon 2
Ozan hocam boşuna yol gösteemeye çalışıyorsunuz sayın @accessman amca bildiğinden şaşmıyor.Daha hala yabancı hayranlığı devam ediyor.Siz link vermişiniz gitmiş başka başka şeylerle uğraşıyor ve ben pes ettim Img-grin aynı durumdan dolayı.
Cevapla
#5
Bir linkte "Bu sayfaya erişim izniniz yok" diyordu 
diğerinde de "Gelişmemiş" diyordu. bende bakmamıştım.
sn. @ozanakkaya ya göre gelişmemiş
ama benim seviyemin üstünde imiş.
Hatırlattığınız için çok teşekkürler sn. @feraz 
biz ihtiyarların şu dönemde daha fazla anlayışa ihtiyacı var.
@benbendedeilem
Cevapla

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

Yorum yapmak için üye olmanız gerekiyor

ya da
Task