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