AccessTr.neT

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

sn ozanakkaya doğrusu nasıl yapabileceğimi tam bilmiyorum 
29 nolu gönderdiğim dosya üzerinde düzenleme yaparsanız sevinirim.

Biraz daha çalıştım ama .Kod çaışmadı..İncelemenizdileğiyle saygılar

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

Kodda Dlookup dan sonraki "il_id" yerine tablodaki iladi yazmanız gerekiyordu.

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

Sn ozanakkaya
Teşekkür ederim...İşlem tamam. Konuyu kapatabiliriz