(20/09/2018, 16:08)ozanakkaya yazdı: rst!sehir yerine Dlookup  ile il tablosundan ilgili kaydı almanız gerekli.

objStream.WriteText "CATEGORIES:" & DLookup("il_id", "il", "[il_id]= " & rst!sehir) & vbCrLf

Dim objStream

Dim VcardAdi, FileName, File, encode As String

Dim rst As DAO.Recordset

Dim image_bin() As Byte

Dim GSayi As Integer

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



GSayi = 0



Do Until rst.EOF



    If rst!secenek = Me.secenek Then

   

    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 & ";" & Dlookup ("iladi", "il", "[id_il]= " & rst!sehir) & ";" & 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:" & Dlookup ("iladi", "il", "[id_il]= " & rst!sehir) & vbCrLf

    objStream.WriteText "CATEGORIES:" & Dlookup ("grupadi", "grup", "[id_grup]= " & rst!secenek) & vbCrLf

    objStream.WriteText "END:VCARD" & vbCrLf

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

    GSayi = GSayi + 1

    End If

    

    rst.MoveNext

    Pause 0.5

Loop

Me.etk_ilerle.Visible = False

objStream.SaveToFile FileName, 2



Me.etk_ilerle.Visible = False



MsgBox (GSayi & " adet veri " & VcardAdi & " isimli dosyaya kaydedildi")

rst.Close

objStream.Close