Option Compare Database

Option Explicit



Private Sub Command0_Click()

    Dim rs As Recordset: Set rs = CurrentDb.OpenRecordset("table_name")

    Dim line As Variant

    

    For Each line In GetFileLines("file_address", True, True, False)

        ' Code depends on format of file.

        ' Example

        rs.AddNew

            rs!Field = Split(line, ",")(0)

            rs!Field = Split(line, ",")(1)

            rs!Field = Split(line, ",")(2)

            rs!Field = Split(line, ",")(3)

        rs.Update

    Next

    rs.Close

End Sub



' Reference Microsoft Scriping Runtime

   

Public Function GetFileLines(ByVal address As String, _

                             ByVal remove_blank_lines As Boolean, _

                             ByVal trim_lines As Boolean, _

                             ByVal keep_newline_char)

    

    ' keep_newline_char represents the Chr(byte) value of 10 and 13. These Bytes represent a NewLine.

    ' passing a true value to this parameter will cause returned lines to contain the new line value at the end of them.

    ' Use: True - Displaying data in a message

    '      False - Parsing the data line by line.

    

                             

    Dim fs As New FileSystemObject

    

    Dim arr_bytes() As Byte

    Dim file_node As Long



    Dim lines() As String

    Dim line_count As Long: line_count = 0

    

    Dim var_byte As Variant

    

    ReDim lines(line_count)

        

    If fs.FileExists(address) Then

    

        ReDim arr_bytes(FileLen(address))

        file_node = FreeFile

        

        Open address For Binary Access Read As file_node

            Get 1, , arr_bytes

        Close file_node

        

        For Each var_byte In arr_bytes

            

            If var_byte = 10 Or var_byte = 13 Then

                If trim_lines Then: lines(line_count) = Trim(lines(line_count))

                

                If remove_blank_lines And Trim(lines(line_count)) = "" Then

                    lines(line_count) = ""

                Else

                    If keep_newline_char Then: lines(line_count) = lines(line_count) & Chr(var_byte)

                    line_count = line_count + 1

                    ReDim Preserve lines(line_count)

                End If

                

            Else

                lines(line_count) = lines(line_count) & Chr(var_byte)

            End If

            

            var_byte = Empty

            

        Next

        

    End If

    

    ' If your last result is wonky, focus on the following line. It was a quick fix for me 

    lines(line_count) = Left(lines(line_count), Len(lines(line_count)) - 1)



    ReDim arr_bytes(0)

    Set fs = Nothing

    file_node = Empty

    line_count = Empty

    

    GetFileLines = lines

    

    ReDim lines(0)

    

End Function

Private Sub ImportContacts( _

    ByVal path As String, ByVal targetFolder As Outlook.Folder)

    Dim contact As Outlook.ContactItem

    Dim moveContact As Outlook.ContactItem

    If (Directory.Exists(path)) Then

        Dim files As String() = Directory.GetFiles(path, "*.vcf")

        For Each file As String In files

            contact = CType(Application.Session.OpenSharedItem(file), _

                Outlook.ContactItem)

            If (targetFolder Is _

                CType(Application.Session.GetDefaultFolder( _

                    Outlook.OlDefaultFolders.olFolderContacts) _

                    , Outlook.Folder)) Then

                contact.Save()

            Else

                moveContact = CType(contact.Move(targetFolder), _

                    Outlook.ContactItem)

                moveContact.Save()

            End If

        Next

    End If

End Sub

Sub CreateTextFileBasic()

    'Must add reference to Tools > References > Microsoft Scripting Runtime

    Dim fso As Scripting.FileSystemObject

    Dim Satir As Scripting.TextStream

    

    Set fso = New Scripting.FileSystemObject

    Set Satir = fso.CreateTextFile("C:\test\test.vcf", True)

    

        Satir.WriteLine "begin:vcard"

        Satir.WriteLine "BDAY;VALUE=DATE:" & "1957-09-21"

        Satir.WriteLine "N:" & "Stenerson;Derik"

        Satir.WriteLine "fn:" & "ramazan"

        Satir.WriteLine "TITLE:" & "vcf yaz"

        Satir.WriteLine "org:" & "accessmania"

        Satir.WriteLine "tel;TYPE=FAX:" & "5050801711"

        Satir.WriteLine "TEL;TYPE=WORK,FAX:" & "+1-425-936-7329"

        Satir.WriteLine "TEL;TYPE=WORK,MSG:" & "+1-425-936-5522"

        Satir.WriteLine "tel;cell;voice:" & "9999999999"

        Satir.WriteLine "tel;work;voice:" & "8888888888" '& (IIf(Not IsNull(Me!Dahili), " Dahili:" & Me![Dahili], ""))

        'Satir.WriteLine "adr;type=work:;;" & "Denizli" ' & ";" & Me![?ehir] & ";" & Me![Ylçe] & ";" & Me![Posta Kodu]

        Satir.WriteLine "ADR;TYPE=WORK,POSTAL,PARCEL:" & ";;One Microsoft Way;Redmond;WA;98052-6399;USA"

        Satir.WriteLine "email;internet:" & "eeeeeeee"

        Satir.WriteLine "EMAIL;TYPE=INTERNET:" & "deriks@microsoft.com"

        Satir.WriteLine "version:" & "2.1" '"3.0"

        Satir.WriteLine "End: vcard"



    Satir.Close



End Sub

(31/05/2020, 10:03)ozanakkaya yazdı: Soru mu sordunuz? Örnek Uygulama mı eklediniz?

---

Gelişmemiş Vcard Oluşturma Uygulaması
Vcard (Outlook Veya Gmail) Oluşturma Uygulaması Versiyon 2