(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