使用 vba 中的图片创建 VCF 卡
Create VCF card with picture in vba
我在 MS Access 中有一个包含联系人信息的数据库和一个包含所有图片的单独文件夹。我想创建带有嵌入式图片的 vcf 卡。从数据库中提取信息和读取图片的代码有效,但创建卡片的代码无效(可能是因为 base64)。你能帮帮我吗?
Private Function encodeBase64(ByRef arrData() As Byte) As String
Dim objXML As Object
Dim objNode As Object
Set objXML = CreateObject("MSXML2.DOMDocument")
Set objNode = objXML.createElement("Base64Data")
objNode.DataType = "bin.base64"
objNode.nodeTypedValue = arrData
encodeBase64 = objNode.text
Set objNode = Nothing
Set objXML = Nothing
End Function
Private Sub createVCF()
Dim objXML As Object
Dim objNode As Object
Dim encode As String
Dim image_bin() As Byte
'read image
file = CurrentProject.Path & "\" & "photo.jpg"
Open file For Binary Access Read As #1
ReDim image_bin(LOF(1) - 1)
Get #1, , image_bin
Close #1
'encode
encode = encodeBase64(image_bin)
'create vcf
Open CurrentProject.Path & "\" & "card_test.vcf" For Append Access Write As 2
Print #2, "BEGIN:VCARD"
Print #2, "VERSION:3.0"
Print #2, "N;CHARSET=WINDOWS-1252;ENCODING=QUOTED-PRINTABLE:;" & "Doe" & ";" & "John" & ";;;;;"
Print #2, "NAME;CHARSET=WINDOWS-1252;ENCODING=QUOTED-PRINTABLE:" & "John" & " " & "Doe"
Print #2, "NOTE;CHARSET=WINDOWS-1252;ENCODING=QUOTED-PRINTABLE:" & "From MS Access"
Print #2, "TEL;Work:" & "1234"
Print #2, "TEL;Cell:" & "4321"
Print #2, "EMAIL;Work:" & "john.doe@doe.com"
Print #2, "ADR;WORK:;;" & "Building A" & " - " & "2B" & ";;;;"
Print #2, "PHOTO;ENCODING=BASE64:" & encode
Print #2, "END:VCARD"
Close #2
Set objNode = Nothing
Set objXML = Nothing
End Sub
谢谢你,亚诺
如 VCard 规范中所述,您需要向 VCard 文件中的每个折叠(换行)行添加前导 space。
https://www.rfc-editor.org/rfc/rfc6350#section-3.2
在这种情况下,这适用于您的 Base64 图像数据。
要实现这一点,请将 Base64 数据中的所有 LF(换行符)替换为 LF 后跟 space。
'encode
encode = Replace(encodeBase64(image_bin), vbLf, vbCrLf & Space(1))
当我们这样做时,代码也将 LF 替换为 CRLF,因为这是规范要求的。 - 虽然它对 Outlook 没有任何影响。
我在 MS Access 中有一个包含联系人信息的数据库和一个包含所有图片的单独文件夹。我想创建带有嵌入式图片的 vcf 卡。从数据库中提取信息和读取图片的代码有效,但创建卡片的代码无效(可能是因为 base64)。你能帮帮我吗?
Private Function encodeBase64(ByRef arrData() As Byte) As String
Dim objXML As Object
Dim objNode As Object
Set objXML = CreateObject("MSXML2.DOMDocument")
Set objNode = objXML.createElement("Base64Data")
objNode.DataType = "bin.base64"
objNode.nodeTypedValue = arrData
encodeBase64 = objNode.text
Set objNode = Nothing
Set objXML = Nothing
End Function
Private Sub createVCF()
Dim objXML As Object
Dim objNode As Object
Dim encode As String
Dim image_bin() As Byte
'read image
file = CurrentProject.Path & "\" & "photo.jpg"
Open file For Binary Access Read As #1
ReDim image_bin(LOF(1) - 1)
Get #1, , image_bin
Close #1
'encode
encode = encodeBase64(image_bin)
'create vcf
Open CurrentProject.Path & "\" & "card_test.vcf" For Append Access Write As 2
Print #2, "BEGIN:VCARD"
Print #2, "VERSION:3.0"
Print #2, "N;CHARSET=WINDOWS-1252;ENCODING=QUOTED-PRINTABLE:;" & "Doe" & ";" & "John" & ";;;;;"
Print #2, "NAME;CHARSET=WINDOWS-1252;ENCODING=QUOTED-PRINTABLE:" & "John" & " " & "Doe"
Print #2, "NOTE;CHARSET=WINDOWS-1252;ENCODING=QUOTED-PRINTABLE:" & "From MS Access"
Print #2, "TEL;Work:" & "1234"
Print #2, "TEL;Cell:" & "4321"
Print #2, "EMAIL;Work:" & "john.doe@doe.com"
Print #2, "ADR;WORK:;;" & "Building A" & " - " & "2B" & ";;;;"
Print #2, "PHOTO;ENCODING=BASE64:" & encode
Print #2, "END:VCARD"
Close #2
Set objNode = Nothing
Set objXML = Nothing
End Sub
谢谢你,亚诺
如 VCard 规范中所述,您需要向 VCard 文件中的每个折叠(换行)行添加前导 space。 https://www.rfc-editor.org/rfc/rfc6350#section-3.2
在这种情况下,这适用于您的 Base64 图像数据。
要实现这一点,请将 Base64 数据中的所有 LF(换行符)替换为 LF 后跟 space。
'encode
encode = Replace(encodeBase64(image_bin), vbLf, vbCrLf & Space(1))
当我们这样做时,代码也将 LF 替换为 CRLF,因为这是规范要求的。 - 虽然它对 Outlook 没有任何影响。