/[cvs]/joko/ToolBox/Windows/HylaPrintMon_MapiContactsDumper/ModuleMain.bas
ViewVC logotype

Diff of /joko/ToolBox/Windows/HylaPrintMon_MapiContactsDumper/ModuleMain.bas

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by joko, Sat Sep 1 12:40:38 2007 UTC revision 1.2 by joko, Sat Sep 1 15:18:39 2007 UTC
# Line 1  Line 1 
1  Attribute VB_Name = "ModuleMain"  Attribute VB_Name = "ModuleMain"
2  Sub Main()  ' (c) Andreas Motl <andreas.motl@ilo.de>, 2007-09-01
3      MsgBox ("hello world!")  
4    Option Explicit
5    
6    Public Sub Main()
7        
8        ' get port name from command line
9        Dim hfax_port As String
10        'hfax_port = "HFAX1:"
11        hfax_port = getCmdArg("--port")
12        
13        ' sanity checks
14        If hfax_port = "" Then
15            MsgBox "Command line argument '--port' is missing.", vbOKOnly, "ERROR"
16            End
17        End If
18        
19        ' read essential information from registry settings of Winprint HylaFAX Port
20        Dim MapiFolderPath As String, AddressBookPath As String, AddressBookType As String
21        MapiFolderPath = getRegistrySetting(hfax_port, "MapiFolderPath")
22        AddressBookPath = getRegistrySetting(hfax_port, "AddressBookPath")
23        AddressBookType = getRegistrySetting(hfax_port, "AddressBookType")
24        
25        ' sanity checks
26        If Not DirectoryExists(AddressBookPath) Then
27            MsgBox "AddressBookPath '" & AddressBookPath & "' does not exist.", vbCritical + vbOKOnly, "ERROR"
28            End
29        End If
30        
31        If AddressBookType = "" Then
32            MsgBox "AddressBookType is empty.", vbCritical + vbOKOnly, "ERROR"
33            End
34        End If
35        
36        
37        ' open MAPI folder
38        mailerStart
39        Dim contactsFolder As Outlook.MAPIFolder
40        
41        If MapiFolderPath = "" Then
42            Set contactsFolder = mailer.Session.GetDefaultFolder(olFolderContacts)
43        Else
44            'Set contactsFolder = getFolderByPath(mailer.Session.Folders, "/Öffentliche Ordner/Alle Öffentlichen Ordner/EDV/plugin_test", 0)
45            Set contactsFolder = getFolderByPath(mailer.Session.Folders, MapiFolderPath, 0)
46            If contactsFolder Is Nothing Then
47                MsgBox _
48                    "Problem: Could not open MAPI folder '" & MapiFolderPath & "'." & vbCrLf & _
49                    "Please configure properly in port settings dialog or registry:" & vbCrLf & vbCrLf & _
50                    "HKEY_LOCAL_MACHINE\SYSTEM\ControlSet001\Control\Print\Monitors\Winprint Hylafax\Ports\" & hfax_port & "\MapiFolderPath", _
51                    vbOKOnly, "ERROR"
52                End
53            End If
54        End If
55        
56        ' read contacts from MAPI folder into array of dictionaries
57        Dim entries As Variant, entry As Variant
58        entries = readMapiFolderToArray(contactsFolder)
59        
60    '    ' debugging: output results to gui
61    '    For Each entry In entries
62    '        MsgBox entry("label") & ": " & entry("faxnumber"), vbOKOnly, "Fax-Contact"
63    '    Next
64        
65        ' write results to addressbook files
66        Dim count As Integer
67        If writeAddressbook(entries, AddressBookType, AddressBookPath, count) = True Then
68            MsgBox "Addressbook refreshed successfully (" & count & " entries).", vbInformation + vbOKOnly, "OK"
69        Else
70            MsgBox "Addressbook refresh failed.", vbExclamation + vbOKOnly, "ERROR"
71        End If
72        
73  End Sub  End Sub
74    
75    Private Function getFolderByPath(ByVal rootFolders As Outlook.Folders, folderPath As String, partsIndex As Integer) As Outlook.MAPIFolder
76        
77        ' split path into parts
78        Dim parts As Variant, part As Variant
79        parts = Split(folderPath, "/")
80        
81        partsIndex = partsIndex + 1
82        Dim entry As Outlook.MAPIFolder
83    
84        For Each part In parts
85            If part <> "" Then
86                'MsgBox "part: " & part
87                On Error Resume Next
88                Set entry = rootFolders.Item(part)
89                If Err.Number <> 0 Then
90                    MsgBox Err.Description & vbCrLf & vbCrLf & "Problem bei der Verwendung des Ordners '" & part & "', " & vbCrLf & "kompletter Pfad war '" & folderPath & "'.", vbOKOnly, "Error"
91                    Exit Function
92                End If
93                On Error GoTo 0
94                'MsgBox "name: " & entry.Name
95                Set rootFolders = entry.Folders
96            End If
97        Next
98    
99        Set getFolderByPath = entry
100        
101    End Function
102    
103    Private Function readMapiFolderToBuffer(myFolder As Outlook.MAPIFolder) As Variant
104        Dim contactItem As Outlook.contactItem
105        Dim objAttribute As Variant
106        'myfolder.Items.Item(
107        Dim buffer As String
108        For Each contactItem In myFolder.Items
109            'MsgBox contactItem.NickName
110            'contactItem.us
111            'MsgBox contactItem.l
112            'Text1.Text = Text1.Text & contactItem.LastName & vbCrLf
113            buffer = buffer & _
114                "firstname: " & contactItem.FirstName & vbCrLf & _
115                "lastname: " & contactItem.LastName & vbCrLf & _
116                "business fax: " & contactItem.BusinessFaxNumber & vbCrLf & _
117                "email: " & contactItem.Email1DisplayName & " <" & contactItem.Email1Address & ">" & vbCrLf
118        Next
119        readMapiFolderToBuffer = buffer
120    End Function
121    
122    Private Function readMapiFolderToArray(myFolder As Outlook.MAPIFolder) As Variant
123        
124        Dim buffer() As Dictionary
125        Dim x As Integer
126        
127        Dim contactItem As Outlook.contactItem
128        For Each contactItem In myFolder.Items
129            
130            ' just use contacts with fax number
131            If contactItem.BusinessFaxNumber <> "" Then
132                
133                ' create new dictionary and append to dynamic array
134                ReDim Preserve buffer(x)
135                Set buffer(x) = New Dictionary
136                buffer(x)("label") = contactItem.LastName & " " & contactItem.FirstName
137                buffer(x)("faxnumber") = contactItem.BusinessFaxNumber
138                x = x + 1
139                
140            End If
141            
142        Next
143        readMapiFolderToArray = buffer
144        
145    End Function
146    
147    Private Function getRegistrySetting(portName As String, subKey As String) As String
148        getRegistrySetting = regQuery_A_Key(HKEY_LOCAL_MACHINE, "SYSTEM\ControlSet001\Control\Print\Monitors\Winprint Hylafax\Ports\" & portName, subKey)
149    End Function
150    
151    Private Function writeAddressbook(ByRef entries As Variant, abFormat As String, abPath As String, ByRef count As Integer) As Boolean
152        
153        writeAddressbook = False
154        
155        If abFormat = "Two Text Files" Then
156        
157            If MsgBox("names.txt and numbers.txt in '" & abPath & "' will be overwritten. Continue?", vbQuestion + vbYesNo, "Overwrite files?") = vbYes Then
158        
159                Dim fh_names As Integer, fh_numbers As Integer
160                
161                fh_names = FreeFile
162                Open abPath & "\" & "names.txt" For Output As #fh_names
163                
164                fh_numbers = FreeFile
165                Open abPath & "\" & "numbers.txt" For Output As #fh_numbers
166                
167                Dim entry As Variant
168                For Each entry In entries
169                    'MsgBox entry("label") & ": " & entry("faxnumber"), vbOKOnly, "Fax-Contact"
170                    Print #fh_names, entry("label")
171                    Print #fh_numbers, entry("faxnumber")
172                    count = count + 1
173                Next
174                
175                Close #fh_names
176                Close #fh_numbers
177                
178                writeAddressbook = True
179            
180            End If
181            
182        ElseIf abFormat = "CSV" Then
183            MsgBox "Addressbook format 'CSV' not supported yet.", vbExclamation + vbOKOnly, "ERROR"
184        
185        Else
186            MsgBox "Unknown addressbook format '" & abFormat & "'.", vbExclamation + vbOKOnly, "ERROR"
187        End If
188        
189    End Function
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2
MailToCvsAdmin">MailToCvsAdmin
 ViewVC Help
Powered by ViewVC 1.1.26 RSS 2.0 feed