Je développe une base de données sous Filemaker, et dans ce cadre je dois convertir des Vcards (.vcf) dans un tableur (via une macro).
Problème n°1... Je ne suis pas vraiment une bête en macros...
J'ai trouvé sur Sourceforge une macro Excel qui faisait le boulot (http://sourceforge.net/projects/vcf-to-xls, merci Matt Maltarich !)
Problème n°2... Je voudrais fait tourner cette macro sur Calc...
Le code ci-dessous fonctionne sous Excel 2007 mais plante dès le début sous OpenOffice 4 (j'ai pourtant bien coché dans les préférences les Propriétés VBA)...
Savez-vous où je pourrais trouver les quelques infos qui me permettraient de modifier ce code pour le faire tourner sous OpenOffice 4 ?... sans reprendre à la base tout l'apprentissage de Basic
Ou encore mieux savez-vous quelles seraient les lignes à modifier ?
(pour info, à terme cette macro devra appeler automatiquement un fichier .vcf bien localisé dans un dossier, sans intervention utilisateur...)
Merci pour votre aide,
Arthos
Code : Tout sélectionner
Public thisname
Public myname
Sub auto_open()
Call Macro1
End Sub
Sub Macro1()
thisname = ActiveWorkbook.Name
Message = MsgBox("The 'FILE OPEN' window will now appear. Please open the VCard that contains your contact info.", vbOKOnly)
FileToOpen = Application.GetOpenFilename("Vcard (*.vcf), *.vcf")
Application.ScreenUpdating = False
Workbooks.OpenText Filename:= _
FileToOpen, Origin:=437, _
StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=True, Comma:=False _
, Space:=False, Other:=True, OtherChar:=":", FieldInfo:=Array(Array(1, 1 _
), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1)) _
, TrailingMinusNumbers:=True
myname = ActiveWorkbook.Name
'
' Macro1 Macro
' Macro recorded 3/14/2005 by Matt Maltarich
'
'
'count number of "Begin" for progress bar
UserForm1.Show
End Sub
Sub macro2()
On Error GoTo 18
Cells(1, 1).Select
Do
Cells.Find(What:="#name", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
myval = ActiveCell.FormulaR1C1
myvallen = Len(myval)
newmyval = Right(myval, myvallen - 1)
ActiveCell.FormulaR1C1 = "'" & newmyval & ""
Loop
18 On Error Resume Next
Dim PctDone As Single
begin_counter = 0
With Columns("A:A")
Set begin_var = .Find("BEGIN", LookIn:=xlValues)
If Not begin_var Is Nothing Then
firstAddress = begin_var.Address
Do
begin_counter = begin_counter + 1
Set begin_var = .FindNext(begin_var)
Loop While Not begin_var Is Nothing And begin_var.Address <> firstAddress
End If
End With
Application.ScreenUpdating = False
ReDim firstname(1 To begin_counter + 1) As String
ReDim middlename(1 To begin_counter + 1) As String
ReDim lastname(1 To begin_counter + 1) As String
ReDim work_phone(1 To begin_counter + 1) As String
ReDim pager(1 To begin_counter + 1) As String
ReDim cell_phone(1 To begin_counter + 1) As String
ReDim fax(1 To begin_counter + 1) As String
ReDim modem(1 To begin_counter + 1) As String
ReDim email_bus(1 To begin_counter + 1) As String
ReDim email_home(1 To begin_counter + 1) As String
ReDim home(1 To begin_counter + 1) As String
ReDim street1_bus(1 To begin_counter + 1) As String
ReDim street1_home(1 To begin_counter + 1) As String
ReDim street2_bus(1 To begin_counter + 1) As String
ReDim street2_home(1 To begin_counter + 1) As String
ReDim city_bus(1 To begin_counter + 1) As String
ReDim city_home(1 To begin_counter + 1) As String
ReDim state_bus(1 To begin_counter + 1) As String
ReDim state_home(1 To begin_counter + 1) As String
ReDim zip_bus(1 To begin_counter + 1) As String
ReDim zip_home(1 To begin_counter + 1) As String
ReDim country_bus(1 To begin_counter + 1) As String
ReDim country_home(1 To begin_counter + 1) As String
ReDim url_bus(1 To begin_counter + 1) As String
ReDim url_home(1 To begin_counter + 1) As String
ReDim org(1 To begin_counter + 1) As String
ReDim title(1 To begin_counter + 1) As String
ReDim note(1 To begin_counter + 1) As String
'initialize all variables
j = 0
i = 1
flag = 0
Counter = 0
counter2 = 0
'Start looking for vcards. If none found in 3 lines, consider it the end of the string of vcards.
Do While Not Counter = 3
entry = Cells(i, 1)
If entry = "BEGIN" Then
counter2 = counter2 + 1
End If
Select Case entry ' Evaluate Entry.
Case "BEGIN"
j = j + 1
Counter = 0
'name case
Case "N"
Dim name_cell As String
a = 1
namecell = Cells(i, 2)
If namecell Like "*ENCODING*" Then '= "ENCODING=QUOTED-PRINTABLE" Then
a = a + 1
End If
firstname(j) = Cells(i, a + 2)
middlename(j) = Cells(i, a + 3)
lastname(j) = Cells(i, a + 1)
'address case
Case "ADR"
b = 1
address_type = Cells(i, b + 1)
encoding_cell = Cells(i, b + 2)
If address_type = "" And Not encoding_cell Like "*ENCODING*" Then
flag = 1
b = b - 1
End If
If encoding_cell Like "*ENCODING*" And Not flag = 1 Then
flag = 2
b = b + 1
End If
If address_type Like "*HOME*" Or flag = 1 Then '"TYPE=HOME,PREF" Or address_type = "TYPE=HOME" Or address_type = "HOME" Then
street2_home(j) = Cells(i, b + 3)
street1_home(j) = Cells(i, b + 4)
city_home(j) = Cells(i, b + 5)
state_home(j) = Cells(i, b + 6)
zip_home(j) = Cells(i, b + 7)
country_home(j) = Cells(i, b + 8)
End If
If address_type Like "*WORK*" Then '"TYPE=WORK,PREF" Or address_type = "TYPE=WORK" Or address_type = "WORK" Then
street2_bus(j) = Cells(i, b + 3)
street1_bus(j) = Cells(i, b + 4)
city_bus(j) = Cells(i, b + 5)
state_bus(j) = Cells(i, b + 6)
zip_bus(j) = Cells(i, b + 7)
country_bus(j) = Cells(i, b + 8)
End If
'organization case
Case "ORG"
org_cell = Cells(i, 2)
If org_cell Like "*ENCODING*" Then
org(j) = Cells(i, 3)
Else
org(j) = Cells(i, 2)
End If
'telephone number case
Case "TEL"
c = 1
phone = Cells(i, c + 1)
If phone Like "*ENCODING*" Then
c = c + 1
End If
If Cells(i, c + 2) Like "*VOICE*" Or Cells(i, c + 2) Like "*FAX*" Then
flag2 = 1
c = c + 1
End If
If phone Like "*WORK*" Then '"TYPE=WORK,PREF" Or phone = "TYPE=WORK" Or phone = "WORK" Then
work_phone(j) = Cells(i, c + 2)
End If
If phone Like "*PAGER*" Then '"TYPE=PAGER,PREF" Or phone = "TYPE=PAGER" Or phone = "PAGER" Then
pager(j) = Cells(i, c + 2)
End If
If phone Like "*CELL*" Then '"TYPE=CELL,PREF" Or phone = "TYPE=CELL" Or phone = "CELL" Then
cell_phone(j) = Cells(i, c + 2)
End If
If phone Like "*HOME*" Then '"TYPE=HOME,PREF" Or phone = "TYPE=HOME" Or phone = "HOME" Then
home(j) = Cells(i, c + 2)
End If
If phone Like "*FAX*" Or Cells(i, c + 1) Like "*FAX*" Then '"TYPE=FAX,PREF" Or phone = "TYPE=FAX" Or phone = "FAX" Then
fax(j) = Cells(i, c + 2)
End If
If phone Like "*MODEM*" Then '"TYPE=MODEM,PREF" Or phone = "TYPE=MODEM" Or phone = "MODEM" Then
modem(j) = Cells(i, c + 2)
End If
'email case
Case "EMAIL"
d = 1
email_addr = Cells(i, d + 1)
If email_addr Like "*ENCODING*" Then
d = d + 1
End If
If email_addr Like "*HOME*" Then '"TYPE=HOME,PREF,INTERNET" Or email_addr = "TYPE=HOME,INTERNET" Or email_addr = "HOME" Or email_addr = "TYPE=PREF,INTERNET" Then
email_home(j) = Cells(i, d + 2)
Else
If email_addr Like "*WORK*" Or email_addr Like "*INTERNET*" Then '"TYPE=WORK,PREF,INTERNET" Or email_addr = "TYPE=WORK,INTERNET" Or email_addr = "WORK" Then
email_bus(j) = Cells(i, d + 2)
Else
If Cells(i, d + 2) Like "*INTERNET*" Then
email_bus(j) = Cells(i, d + 3)
Else
email_home(j) = Cells(i, d + 1)
End If
End If
End If
'website url case
Case "URL"
e = 1
url_type = Cells(i, e + 1)
If url_type Like "*ENCODING*" Then
e = e + 1
End If
If Cells(i, e + 2) Like "*http*" Then
e = e + 1
End If
If url_type Like "*HOME*" Then '"TYPE=HOME,PREF" Or url_type = "TYPE=HOME" Or url_type = "HOME" Then
url_home(j) = Cells(i, e + 2)
End If
If url_type Like "*WORK*" Then '"TYPE=WORK,PREF" Or url_type = "TYPE=WORK" Or url_type = "WORK" Then
url_bus(j) = Cells(i, e + 2)
End If
'title case
Case "TITLE"
title_cell = Cells(i, 2)
If title_cell Like "*ENCODING*" Then
title(j) = Cells(i, 3)
Else
title(j) = Cells(i, 2)
End If
'notes case
Case "NOTE"
note_cell = Cells(i, 2)
If note_cell Like "*ENCODING*" Then
note(j) = Cells(i, 3)
Else
note(j) = Cells(i, 2)
End If
'case that line is blank
Case ""
Counter = Counter + 1
End Select
i = i + 1
' Update the percentage completed.
PctDone = (counter2 / 2) / begin_counter
' Call subroutine that updates the progress bar.
UpdateProgressBar PctDone
Loop
' The task is finished, so unload the UserForm.
'Unload UserForm1
ending_i = i
Application.DisplayAlerts = False
ActiveWorkbook.Close
Application.DisplayAlerts = True
Windows(thisname).Activate
Sheets("Contacts").Select
For j = 1 To begin_counter + 1
Cells(j + 1, 1) = firstname(j)
Cells(j + 1, 2) = middlename(j)
Cells(j + 1, 3) = lastname(j)
Cells(j + 1, 4) = home(j)
Cells(j + 1, 5) = work_phone(j)
Cells(j + 1, 6) = cell_phone(j)
Cells(j + 1, 7) = pager(j)
Cells(j + 1, 8) = fax(j)
Cells(j + 1, 9) = modem(j)
Cells(j + 1, 10) = email_bus(j)
Cells(j + 1, 11) = email_home(j)
Cells(j + 1, 12) = street1_home(j)
Cells(j + 1, 13) = street2_home(j)
Cells(j + 1, 14) = city_home(j)
Cells(j + 1, 15) = state_home(j)
Cells(j + 1, 16) = zip_home(j)
Cells(j + 1, 17) = country_home(j)
Cells(j + 1, 18) = street1_bus(j)
Cells(j + 1, 19) = street2_bus(j)
Cells(j + 1, 20) = city_bus(j)
Cells(j + 1, 21) = state_bus(j)
Cells(j + 1, 22) = zip_bus(j)
Cells(j + 1, 23) = country_bus(j)
Cells(j + 1, 24) = url_bus(j)
Cells(j + 1, 25) = url_home(j)
Cells(j + 1, 26) = org(j)
Cells(j + 1, 27) = title(j)
Cells(j + 1, 28) = note(j)
' Update the percentage completed.
PctDone = ((begin_counter / 2) + (j / 2)) / begin_counter
' Call subroutine that updates the progress bar.
UpdateProgressBar PctDone
Next
' The task is finished, so unload the UserForm.
Unload UserForm1
Sheets("VCF to XLS").Visible = False
ActiveWindow.DisplayWorkbookTabs = True
ActiveWindow.DisplayHorizontalScrollBar = True
ActiveWindow.DisplayVerticalScrollBar = True
'save copy of contacts to new book
Cells.Select
Selection.Copy
Workbooks.Add
Cells.Select
ActiveSheet.Paste
Application.CutCopyMode = False
Cells(1, 1).Select
Windows(thisname).Activate
ActiveWorkbook.Close False
Application.ScreenUpdating = True
End Sub
Sub UpdateProgressBar(PctDone As Single)
With UserForm1
' Update the Caption property of the Frame control.
.FrameProgress.Caption = Format(PctDone, "0%")
' Widen the Label control.
.LabelProgress.Width = PctDone * _
(.FrameProgress.Width - 10)
End With
' The DoEvents allows the UserForm to update.
DoEvents
End Sub
… Pour l'instant je galère donc pas mal, je cherche partout comment faire tourner cette macro sur OpenOffice… pour commencer ! (sur OpenOffice parce que tout ça doit tourner sur des ordinateurs en OpenOffice)
