cmd_tumkayitlar_iki_click kodunuzu aşağıdakiyle değiştirin.
Kod:
Private Sub cmd_tumkayitlar_iki_Click()
If Me.chk_allgroups = 0 Then
GoTo vcardpublish
Else
Dim RecordFound As Boolean
RecordFound = False
For i = 1 To 7
Me.secenek = i
vcardpublish:
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
GSorgum = "SELECT tbl_kisiler.secenek_bir, * FROM tbl_kisiler WHERE (((tbl_kisiler.secenek_bir)='" & Me.secenek & "'));"
Set rst = CurrentDb.OpenRecordset(GSorgum)
If Not rst.EOF Then
rst.MoveFirst
Me.etk_ilerle.Visible = True
GSayi = 0
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!sehir & ";" & rst!evpostakodu & ";" & rst!evulke & vbCrLf
objStream.WriteText "CATEGORIES:" & DLookup("id_il", "il", "[id_il]= " & Nz(rst!sehir, 0)) & 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!notbir & vbCrLf
objStream.WriteText "NOTE:" & rst!notiki & vbCrLf
objStream.WriteText "NOTE:" & rst!notuc & vbCrLf
objStream.WriteText "REV:" & Format(Date, "yyyymmdd") & "T" & Format(Now(), "hhnnss") & "Z" & vbCrLf
objStream.WriteText "CATEGORIES:" & DLookup("grupadi", "grup", "[id_grup]= " & Nz(rst!secenek_bir, 0)) & vbCrLf
objStream.WriteText "END:VCARD" & vbCrLf
Me.etk_ilerle.Caption = rst!adisoyadi & " " & rst!soyadi
GSayi = GSayi + 1
rst.MoveNext
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
End If
Next i
If Not RecordFound Then
MsgBox UCase(DLookup("grupadi", "grup", "id_grup=" & Me.secenek.Value)) & _
" grubu için kayıt bulunamamıştır!", vbInformation + vbOKOnly, "Bulunmayan Kayıt"
End If
End If
End Subkodunuzda gerekli for - next döngüsü ile tüm gruplar için vcard oluşturma işlemi tanımlanmış durumdadır (sadece checkbox tikini açmanız yeterlidir seçeneklerden grup seçmeye gerek yoktur) , ayrıca kodunuzda recordsette kayıt yoksa hata verir buna ilişkin denetim de yoktu, onu da ekledim; hangi grupta kayıt oluşturulamadı uyarı verir.
Sizin konularınıza şahsen verdiğim son cevaptır, sadece ilgilenen başka insanlar fayda sağlasınlar diye kodu düzenledim. Sizin amacınız öğrenmek falan değil işinizi gördürmek; bu sebeple bir daha herhangi bir sorunuza şahsen ben cevap vermeyeceğim, bilginiz olsun.
