Birleşik Değer Kutusuna Göre Vcard

(12/09/2018, 22:17)ozguryasin yazdı: Merhaba; dediğim türde örneğinizi değiştirmeniz gerekmekte. 

Sn ozguryasin
Siz deneme yaptınız mı? Çalışıyor mu.? tabloda 6 kayıt var yine 6 kayıtı Gmaile gönderiyor.
Nasıl çalıştıracağız..Saygılar

gmail butonundaki kodları şağıdaki kodlar ile değiştirip dener misiniz?

Const ForReading = 1, ForWriting = 2, ForAppending = 3

Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0

Dim rst As DAO.Recordset

Dim encode As String

Dim fs, f, ts, s

Dim image_bin() As Byte

Dim VcardAdi, SoRgU As String



SoRgU = "SELECT tbl_kisiler.kisi_id, tbl_kisiler.adisoyadi, tbl_kisiler.ikinciadi, tbl_kisiler.soyadi, tbl_kisiler.sirketbilgisi, tbl_kisiler.unvani, tbl_kisiler.isunvani, tbl_kisiler.dogumtarihi, tbl_kisiler.evadresi, tbl_kisiler.evtamadres, tbl_kisiler.yer_tanimlama, tbl_kisiler.evsehir, tbl_kisiler.evbolge, tbl_kisiler.evpostakodu, tbl_kisiler.evulke, tbl_kisiler.isadresi, tbl_kisiler.issehir, tbl_kisiler.isbolge, tbl_kisiler.ispostakodu, tbl_kisiler.isulke, tbl_kisiler.evtelefonu, tbl_kisiler.Notlar, tbl_kisiler.istelefonu, tbl_kisiler.websayfasi, tbl_kisiler.ceptelefonu, tbl_kisiler.ceptelefonuiki, tbl_kisiler.ceptelesi, tbl_kisiler.telfarkli, tbl_kisiler.fax, tbl_kisiler.fotograf, tbl_kisiler.epostaadresi, tbl_kisiler.secenek, tbl_kisiler.gonderilecekler " & _

"FROM tbl_kisiler " & _

"WHERE (((tbl_kisiler.gonderilecekler)=True));"



VcardAdi = Format(Date, "ddmmyyyy") & "TumKayitlar.vcf"

    ActiveControl.Hyperlink.CreateNewDocument CurrentProject.path & "\" & VcardAdi, False, True



    Set fs = CreateObject("Scripting.FileSystemObject")

    Set f = fs.GetFile(CurrentProject.path & "\" & VcardAdi)

    

    Set ts = f.OpenAsTextStream(ForWriting, TristateUseDefault)



Set rst = CurrentDb.OpenRecordset(SoRgU)

rst.MoveFirst



Me.etk_ilerle.Visible = True

Do Until rst.EOF



    ts.WriteLine "BEGIN:VCARD"

    ts.WriteLine "VERSION:3.0"

    ts.WriteLine "N:" & rst!soyadi & ";" & rst!adisoyadi & ";" & rst!ikinciadi & ";" & rst!unvani

    ts.WriteLine "FN:" & rst!adisoyadi & " " & rst!soyadi

    ts.WriteLine "ORG:" & rst!sirketbilgisi

    ts.WriteLine "TITLE:" & rst!isunvani

    File = CurrentProject.path & "\resimler\" & rst!fotograf

    If FileExists(File) = True Then

    Open File For Binary Access Read As #1

    ReDim image_bin(LOF(1) - 1)

    Get #1, , image_bin

    Close #1

    encode = Replace(EncodeBase64(image_bin), vbLf, vbCrLf & Space(1))

    ts.WriteLine "PHOTO;TYPE=JPEG;ENCODING=B:" & encode

    End If

    ts.WriteLine "TEL;WORK;VOICE:" & rst!istelefonu

    ts.WriteLine "TEL;HOME;VOICE:" & rst!evtelefonu

    ts.WriteLine "TEL;CELL;VOICE:" & rst!ceptelefonu

    ts.WriteLine "ADR;WORK:" & rst!isadresi & ";" & _

               rst!issehir & ";" & rst!ispostakodu & ";" & rst!isulke

    ts.WriteLine "ADR;HOME:" & rst!evadresi & ";" & _

                rst!evsehir & ";" & rst!evpostakodu & ";" & rst!evulke

    ts.WriteLine "X-MS-OL-DEFAULT-POSTAL-ADDRESS:1"

    ts.WriteLine "EMAIL;PREF;INTERNET:" & rst!epostaadresi

    ts.WriteLine "URL;WORK:" & rst!websayfasi

    ts.WriteLine "NOTE:" & rst!Notlar

    ts.WriteLine "BDAY:" & Format(rst!dogumtarihi, "yyyy-mm-dd")

    ts.WriteLine "REV:" & Format(Date, "yyyymmdd") & "T" & Format(Now(), "hhnnss") & "Z"

    ts.WriteLine "END:VCARD"

   

    Me.etk_ilerle.Caption = rst!adisoyadi & " " & rst!soyadi

    

    rst.MoveNext

    Pause 0.5

Loop

Me.etk_ilerle.Visible = False

MsgBox (rst.RecordCount & " adet veri " & VcardAdi & " isimli dosyaya kaydedildi")

rst.Close



    ts.Close

sn ozguryasin
Tamam bu kod güzel çalıştı. Ancak daha önceleri yaşadığım Türkçe harf karakter sorunu yine oluştu. Şöyleki  Büyük harf İ v küçük harf ğ harfleri özelikle  GMailde sorun olarak gözüktü

Daha önce Sn ozanakkaya şöyle bir kod yazmıştı.Buna rağmen sorun yaşıyorum
ts.WriteLine "N:CHARSET=UTF8" & rst!soyadi & ";" & rst!adisoyadi & ";" & rst!ikinciadi & ";" & rst!unvani

Değerli üstadlarım
Bazan zaman zaman sorun yaşamakla birlikte bazan da düzgün netice almakatayım...Bir kaç denemeden sonra tekrar bilgi vereceğim Saygılar

Butonun tıklandığında olayındaki kodu aşağıdaki ile değiştirerek deneyiniz.

Dim objStream

Dim VcardAdi, FileName, File, encode As String

Dim rst As DAO.Recordset

Dim image_bin() As Byte

VcardAdi = Format(Date, "ddmmyyyy") & "TumKayitlar.vcf"

FileName = CurrentProject.path & "\" & VcardAdi





Set objStream = CreateObject("ADODB.Stream")

objStream.Charset = "utf-8"

objStream.Open





Set rst = CurrentDb.OpenRecordset("tbl_kisiler")

rst.MoveFirst



Me.etk_ilerle.Visible = True



Do Until rst.EOF

   

    objStream.WriteText "BEGIN:VCARD" & vbCrLf

    objStream.WriteText "VERSION:4.0" & vbCrLf

    objStream.WriteText "N:" & rst!soyadi & ";" & rst!adisoyadi & ";" & rst!ikinciadi & ";" & rst!unvani & vbCrLf

    objStream.WriteText "FN:" & rst!adisoyadi & " " & rst!soyadi & vbCrLf

    objStream.WriteText "ORG:" & rst!sirketbilgisi & vbCrLf

    objStream.WriteText "TITLE:" & rst!isunvani & vbCrLf

    File = CurrentProject.path & "\resimler\" & rst!fotograf

    If FileExists(File) = True Then

    Open File For Binary Access Read As #1

    ReDim image_bin(LOF(1) - 1)

    Get #1, , image_bin

    Close #1

    encode = Replace(EncodeBase64(image_bin), vbLf, vbCrLf & Space(1))

    objStream.WriteText "PHOTO;TYPE=JPEG;ENCODING=B:" & encode & vbCrLf

    End If

    objStream.WriteText "TEL;WORK;VOICE:" & rst!istelefonu & vbCrLf

    objStream.WriteText "TEL;HOME;VOICE:" & rst!evtelefonu & vbCrLf

    objStream.WriteText "TEL;CELL;VOICE:" & rst!ceptelefonu & vbCrLf

    objStream.WriteText "ADR;WORK:" & rst!isadresi & ";" & rst!issehir & ";" & rst!ispostakodu & ";" & rst!isulke & vbCrLf

    objStream.WriteText "ADR;HOME:" & rst!evadresi & ";" & rst!evsehir & ";" & rst!evpostakodu & ";" & rst!evulke & vbCrLf

    objStream.WriteText "X-MS-OL-DEFAULT-POSTAL-ADDRESS:1" & vbCrLf

    objStream.WriteText "EMAIL;PREF;INTERNET:" & rst!epostaadresi & vbCrLf

    objStream.WriteText "URL;WORK:" & rst!websayfasi & vbCrLf

    objStream.WriteText "NOTE:" & rst!Notlar & vbCrLf

    objStream.WriteText "BDAY:" & Format(rst!dogumtarihi, "yyyy-mm-dd") & vbCrLf

    objStream.WriteText "REV:" & Format(Date, "yyyymmdd") & "T" & Format(Now(), "hhnnss") & "Z" & vbCrLf

    objStream.WriteText "CATEGORIES:" & rst!secenek & vbCrLf

    objStream.WriteText "END:VCARD" & vbCrLf

    Me.etk_ilerle.Caption = rst!adisoyadi & " " & rst!soyadi

    

    rst.MoveNext

    Pause 0.5

Loop

Me.etk_ilerle.Visible = False

objStream.SaveToFile FileName, 2



Me.etk_ilerle.Visible = False



MsgBox (rst.RecordCount & " adet veri " & VcardAdi & " isimli dosyaya kaydedildi")

rst.Close

objStream.Close

Bu kod vcf dosyasını utf-8 formatında aktaracağı için sorun çıkacağını sanmıyorum. Ayrıca koda categories eklenmiştir. Aktarılan veriler gmail kişilerde çerçeve olarak eklenir.

(14/09/2018, 18:55)ozanakkaya yazdı: Butonun tıklandığında olayındaki kodu aşağıdaki ile değiştirerek deneyiniz.

Ayrıca koda categories eklenmiştir. Aktarılan veriler gmail kişilerde çerçeve olarak eklenir.

Sn ozanakkaya Evet kayıtlar çerçeve olarak eklenmiş .Güzel olmuş.

Ben tüm kişilerin kayıtlarının hepsinin gönderilmesini istemiyorum. secenek butonunda yer aldığı şekliyle örneğin arkadaşlar seçeneğine ya da dernek seçeneklerine göre gönderi yapmak istiyorum.
Bir düzenleme daha yapıverirseniz sevinirim Saygılar