1 
  2 
  3 **************************************
  4 '                              '
  5 '                               '
  6 '    for Microsoft Excel(tm)97/2000   '
  7 '    Symantec (Canada) Corporation    '
  8 '             EC 11/19/99             '
  9 '**************************************
 10 
 11 ' ** Version Information **
 12 
 13 Public Const VER_PLATFORM_WIN32s = 0   ' Not used
 14 Public Const VER_PLATFORM_WIN32_WINDOWS = 1  ' Win 95/98
 15 Public Const VER_PLATFORM_WIN32_NT = 2 ' Win NT/2000
 16  
 17 Type OSVERSIONINFO
 18          dwOSVersionInfoSize As Long
 19          dwMajorVersion As Long
 20          dwMinorVersion As Long
 21          dwBuildNumber As Long
 22          dwPlatformId As Long
 23          szCSDVersion As String * 128   ' Maintenance string for PSS usage.
 24 End Type
 25 
 26 ' Define International strings
 27 Global sError1, sError2, sError3, sError4
 28 Global sPrinterName, sCommandBar, sCommandBarCaption
 29 Global sDriverName
 30 Global sErrLoading
 31 Global sErrReg
 32 Global sMacroDirectory
 33 Global WfxPath$
 34 
 35 Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
 36 
 37 Public Declare Function FindWindowA Lib "User32" (ByVal lpClassName As Any, ByVal lpWindowName As Any) As Integer
 38 Public Declare Function GetPrivateProfileStringA Lib "kernel32" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Integer, ByVal lpFileName As String) As Integer
 39 
 40 Public Declare Function RegOpenKey& Lib "ADVAPI32" Alias "RegOpenKeyA" (ByVal hkeyOpen&, ByVal szSubKey$, ByRef hkeyResult&)
 41 Public Declare Function RegQueryValue& Lib "ADVAPI32" Alias "RegQueryValueExA" (ByVal hkey&, ByVal szValueName$, ByVal lReserved&, ByRef lType&, sValue As Any, ByRef lcbData&)
 42 Public Const HCU As Long = &H80000001
 43 Public Const HLM As Long = &H80000002
 44 
 45 Public Sub CheckIfWinFaxIsActive()
 46     
 47      On Error GoTo ErrLoading
 48      
 49      If FindWindowA("cFaxMng", 0&) = 0 Then
 50 
 51 '        lResult& = RegOpenKey&(HCU, "Software\Delrina\WinFax\7.0\Printer Driver", hkeyWfx&)
 52 '        lResult& = RegQueryValue&(hkeyWfx&, "AlwaysPrintToFaxmng", 0&, lType&, ByVal 0&, lcbValue&)
 53 '        lResult& = RegQueryValue&(hkeyWfx&, "AlwaysPrintToFaxmng", 0&, lType&, PrintToFaxmng&, lcbValue&)
 54         
 55         WfxPath$ = Space(256)
 56         
 57         lResult& = RegOpenKey&(HLM, "Software\Delrina\WinFax\7.0\WinFax", hkeyWfx&)
 58         lResult& = RegQueryValue&(hkeyWfx&, "ExePath", 0&, lType&, ByVal 0&, lcbValue&)
 59         lResult& = RegQueryValue&(hkeyWfx&, "Exepath", 0&, lType&, ByVal WfxPath$, lcbValue&)
 60                 
 61 '        If PrintToFaxmng& = 0 Then
 62         WfxPath$ = Left$(WfxPath$, lcbValue& - 1) & "wfxctl32.exe"
 63 '        Else
 64 '            WfxPath$ = Left$(WfxPath$, lcbValue& - 1) & "faxmng32.exe"
 65 '        End If
 66         
 67         X = Shell(WfxPath$, 6)
 68         newHour = Hour(Now())
 69         newMinute = Minute(Now())
 70         newSecond = Second(Now()) + 10
 71         waitTime = TimeSerial(newHour, newMinute, newSecond)
 72         Application.Wait waitTime
 73     End If
 74 ErrLoading:
 75      If Err <> 0 Then
 76        
 77        ErrMsg = sErrLoading & Chr$(13)
 78        
 79        If WfxPath$ = "" Then
 80          ErrMsg = ErrMsg & sErrReg & Chr$(13)
 81        Else
 82          ErrMsg = ErrMsg & WfxPath$ & Chr$(13)
 83        End If
 84        
 85        ErrMsg = ErrMsg & Chr$(13) & Err.Number & " - " & Err.Description
 86        MsgBox ErrMsg
 87        End
 88      
 89      End If
 90 End Sub
 91 Public Sub GetLanguage()
 92     
 93     ' Determine the Excel language used.
 94     
 95     ' Define the default macro directory name.
 96     ' for German, use MAKROS
 97     sMacroDirectory = "MACROS"   ' North American/English versions
 98     
 99     Select Case Application.International(xlCountryCode)
100         
101     Case 1:   'English (USA/UK)
102     
103     sError1 = "No active document to fax."
104     sError2 = "WinFax Error: "
105     sError3 = "The WinFax/Talkworks Printer Driver does not appear to be installed"
106     sError4 = "You must re-install the printer driver for WinFax/Talkworks."
107 
108     sPrinterName = "WinFax on "  ' printer name with "on" reference
109     sCommandBar = "Win&Fax"  ' command bar option with hot key reference
110     sCommandBarCaption = "Print To WinFax" ' caption for macro icon
111     sDriverName = "WinFax" ' ie: driver name, DelFax or WinFax
112     sErrLoading = "Error loading Controller."
113     sErrReg = "Cannot find reference to controller in registry."
114     
115     
116     Case 33:  'French
117 
118     sError1 = "No active document to fax."
119     sError2 = "WinFax Error: "
120     sError3 = "The WinFax/Talkworks Printer Driver does not appear to be installed"
121     sError4 = "You must re-install the printer driver for WinFax/Talkworks."
122 
123     sPrinterName = "WinFax on "  ' printer name with "on" reference
124     sCommandBar = "Del&Fax"  ' command bar option with hot key reference
125     sCommandBarCaption = "Print To DelFax" ' caption for macro icon
126     sDriverName = "DelFax" ' ie: driver name, DelFax or WinFax
127 
128     Case 49:   'German
129     
130     ' Italian, spanish, dutch, portugese goes here
131     
132     sError1 = "Kein aktives Dokument zum Faxen."
133     sError2 = "WinFax-Fehler: "
134     sError3 = "Der WinFax/Talkworks-Druckertreiber ist offensichtlich nicht installiert."
135     sError4 = "Sie m黶sen den Druckertreiber f黵 WinFax/Talkworks erneut installieren."
136 
137     sPrinterName = "WinFax auf "  ' printer name with "on" reference
138     sCommandBar = "Win&Fax"  ' command bar option with hot key reference
139     sCommandBarCaption = "Drucken an WinFax" ' caption for macro icon
140     sDriverName = "WinFax" ' ie: driver name, DelFax or WinFax
141     sErrLoading = "Fehler beim Laden des Controllers."
142     sErrReg = "In der Registrierung wurde kein Verweis auf den Controller gefunden."
143             
144     Case Else    ' English default.
145      
146     sError1 = "No active document to fax."
147     sError2 = "WinFax Error: "
148     sError3 = "The WinFax/Talkworks Printer Driver does not appear to be installed"
149     sError4 = "You must re-install the printer driver for WinFax/Talkworks."
150 
151     sPrinterName = "WinFax on "  ' printer name with "on" reference
152     sCommandBar = "Win&Fax"  ' command bar option with hot key reference
153     sCommandBarCaption = "Print To WinFax" ' caption for macro icon
154     sDriverName = "WinFax" ' ie: driver name, DelFax or WinFax
155       
156     End Select
157        
158 
159 End Sub
160 
161 Sub WinFaxMacro()
162    
163     On Error GoTo MainErrHandler
164 
165     ' Get the language strings
166     GetLanguage
167    
168     ' check to see if any documents are active.
169     If Windows.Count <= 0 Then
170        MsgBox sError1  ' no active document to fax
171        Exit Sub
172     End If
173     
174     ' Define Winfax object and create instance of WinFax
175     
176     CheckIfWinFaxIsActive
177     
178     Dim objWfx As Object
179     Set objWfx = CreateObject("WinFax.SDKSend8.0")
180     objWfx.SetClientID ("Client Name")
181           
182     Dim RName(25)
183     
184     RName(0) = "wfxFaxNum"
185     RName(1) = "wfxTime"
186     RName(2) = "wfxDate"
187     RName(3) = "wfxRecipient"
188     RName(4) = "wfxCompany"
189     RName(5) = "wfxSubject"
190     RName(6) = "wfxBillCode"
191     RName(7) = "wfxKeyword"
192     
193     RName(8) = "wfxSetHold"
194     RName(9) = "wfxResolution"
195     RName(10) = "wfxDeleteAfterSend"
196     RName(11) = "wfxUseCreditCard"
197     RName(12) = "wfxShowSendScreen"
198     RName(13) = "wfxCoverPageCVP"
199     RName(14) = "wfxAttachmentFile"
200     RName(15) = "wfxShowCallProgress"
201     RName(16) = "wfxSetOffPeak"
202     RName(17) = "wfxPriority"
203     RName(18) = "wfxSetTypeByName"
204     RName(19) = "wfxSetCoverText"
205     RName(20) = "wfxAreaCode"
206     RName(21) = "wfxCountryCode"
207     
208     CurPrinter$ = Application.ActivePrinter
209     
210     Port$ = GetWfxPort$
211     
212     Application.ActivePrinter = sPrinterName & Port$
213     
214     Dim PrintRange As Range
215     
216     Set PrintRange = ActiveWindow.RangeSelection
217       
218     ' Recipient Properties
219     sWfxFaxNum = " "
220     sWfxRecipient = " "
221     sWfxTime = ""
222     sWfxDate = ""
223     sWfxCompany = ""
224     sWfxSubject = ""
225     sWfxKeyword = ""
226     sWfxBillingCode = ""
227     
228     ' Send Properties
229     sWfxShowSendscreen = "1"  ' default ON
230     sWfxSetHold = "0"  ' default OFF
231     sWfxResolution = "1" ' default FINE/HIGH
232     sWfxDeleteAfterSend = "0" ' default is NO
233     sWfxUseCreditCard = "0" ' default is NO
234     sWfxCoverPageCVP = "" ' default is none specified
235     sWfxAttachmentFile = "" ' default is none specified
236     sWfxShowCallProgress = "" ' default is program setup
237     sWfxSetOffPeak = "" ' default is no
238     sWfxPriority = "" ' default is none
239     sWfxSetTypeByName = "" ' default is by fax.
240     
241     X = FindRange(RName(0))  ' Search for "wfxFaxNumber"
242      
243     ' X returns non zero value if the named cell "wfxFaxNumber" is found
244      If X <> 0 Then
245          
246         ' search for all the named cells
247         For Counter = 0 To 21
248    
249         X = FindRange(RName(Counter))
250         
251         If X <> 0 Then    ' found named range
252          Select Case Counter
253          Case 0: sWfxFaxNum = Range(RName(0))
254          Case 3: sWfxRecipient = Range(RName(3))
255          Case 1: sWfxTime = Range(RName(1))
256          Case 2: sWfxDate = Range(RName(2))
257          Case 4: sWfxCompany = Range(RName(4))
258          Case 5: sWfxSubject = Range(RName(5))
259          Case 6: sWfxKeyword = Range(RName(6))
260          Case 7: sWfxBillingCode = Range(RName(7))
261          Case 8: sWfxSetHold = Range(RName(8))
262          Case 9: sWfxResolution = Range(RName(9))
263          Case 10: sWfxDeleteAfterSend = Range(RName(10))
264          Case 11: sWfxUseCreditCard = Range(RName(11))
265          Case 12: sWfxShowSendscreen = Range(RName(12))
266          Case 13: sWfxCoverPageCVP = Range(RName(13))
267          Case 14: sWfxAttachmentFile = Range(RName(14))
268          Case 15: sWfxShowCallProgress = Range(RName(15))
269          Case 16: sWfxSetOffPeak = Range(RName(16))
270          Case 17: sWfxPriority = Range(RName(17))
271          Case 18: sWfxSetTypeByName = Range(RName(18))
272          Case 21: sWfxCountryCode = Range(RName(21))
273          Case 20: sWfxAreaCode = Range(RName(20))
274          
275          End Select
276         
277         End If
278     
279     Next Counter
280     
281     End If
282         
283     ' FindRange returns 0 or 1 if "style" is found.
284     ' look for fax number (wfxfaxnum named range)
285     
286     X = FindRange(RName(0))
287         
288     If X <> 0 Then   ' wfxfaxnum named cell has been found.
289          
290          ' set recipient methods for WinFax
291          With objWfx
292          
293          .SetTo (sWfxRecipient)
294          .SetNumber (sWfxFaxNum)
295          
296          If sWfxAreaCode <> "" Then
297            .SetAreaCode (sWfxAreaCode)
298          End If
299          
300          If sWfxCountryCode <> "" Then
301            .SetCountryCode (sWfxCountryCode)
302          End If
303          
304          If sWfxTime <> "" Then
305            Call VerifyTimeFormat(sWfxTime)
306            .SetTime (sWfxTime)
307          End If
308          
309          If sWfxDate <> "" Then
310            Call VerifyDateFormat(sWfxDate)
311            .SetDate (sWfxDate)
312          End If
313          
314          .SetCompany (sWfxCompany)
315          .SetSubject (sWfxSubject)
316          
317          ' check if you need to hold the fax
318          If sWfxSetHold = "1" Then
319             .SetHold (1)
320          End If
321                  
322          ' check if off peak selected
323          If sWfxSetOffPeak = "1" Then
324             .SetOffPeak (1)
325          End If
326                   
327          ' check if priority is selected
328         ' If sWfxPriority <> "" Then
329         '     Select Case UCase$(sWfxPriority)
330         '     Case "HIGH", "1"
331         '     .SetPriority (1)
332         '     Case "LOW", "3"
333         '     .SetPriority (3)
334         '     Case "MED", "2", "MEDIUM", "NORMAL"
335         '     .SetPriority (2)
336         '     Case Else  ' High default
337         '     .SetPriority (1)
338         '     End Select
339         ' End If
340          
341          ' check if billing or keywords are selected
342          If sWfxKeyword <> "" Or sWfxBillingCode <> "" Then
343              .EnableBillingCodeKeywords (1)
344              .SetKeywords (sWfxKeyword)
345              .SetBillingCode (sWfxBillingCode)
346          End If
347          
348          ' Send Job Methods
349          
350          retCode = .AddRecipient()
351                         
352          .LeaveRunning
353                  
354          .SetPrintFromApp (1)
355          
356          ' check if low resolution selected
357          If sWfxResolution = "0" Then
358              .SetResolution (0)
359          End If
360           
361           ' check if delete after send selected
362          If sWfxDeleteAfterSend = "1" Then
363              .SetDeleteAfterSend (1)
364          End If
365          
366          ' check if use credit card selected
367          If sWfxUseCreditCard = "1" Then
368              .SetUseCreditCard (1)
369          End If
370          
371          ' check if fax, internet etc.
372       '   If sWfxSetTypeByName <> "" Then
373       '
374       '      Select Case UCase$(sWfxSetTypeByName)
375       '
376       '      Case "FAX"
377       '       .SetType (0)
378       '      Case "INTERNET", "INTERNET FAX"
379       '       .SetType (1)
380       '      Case Else
381       '       .SetType (0)
382       '      End Select
383       '   End If
384                   
385          .Send (0)
386                
387          ' check if we need to turn off show call progress dialog
388          If sWfxShowCallProgress = "0" Then
389             .ShowCallProgress (0)
390            Else
391             .ShowCallProgress (1)
392          End If
393                
394          ' Display send screen to allow adding of attachments,
395          ' cover page etc.
396          ' default is showsendscreen = on "1"
397          
398          If sWfxShowSendscreen = "0" Then
399              .ShowSendScreen (0)
400          Else
401              .ShowSendScreen (1)
402          End If
403                  
404          
405          End With
406     
407          ' Print the active workbook without displaying the printer
408          ' dialog box.
409          
410          ActiveWorkbook.PrintOut
411         
412     Else
413         ' no named cells are found, so we
414         ' display the printer dialog box
415          Application.Dialogs(xlDialogPrint).Show
416     
417     End If
418         
419     ' Return printer to its original settings
420     If CurPrinter$ <> "" Then
421         Application.ActivePrinter = CurPrinter$
422     End If
423     
424     GoTo MainBye:
425 
426 MainErrHandler:
427     ' Trap errors
428     
429     Select Case Err
430         Case 1004
431             GoTo MainBye
432         Case Else
433             MsgBox sError2 & Str$(Err) & " - " & Err.Description
434     End Select
435 MainBye:
436 End Sub
437 Function VerifyDateFormat(sWfxDate)
438    ' set the date format to MM/DD/YY regardless of the original format
439   sWfxDate = Format$(sWfxDate, "MM/DD/YY")
440   VerifyDateFormat = sWfxDate
441   
442 End Function
443 Function VerifyTimeFormat(sWfxTime)
444    ' set time to HH:MM:SS format
445    sWfxTime = Format$(sWfxTime, "HH:MM:SS")
446    VerifyTimeFormat = sWfxTime
447 End Function
448 Function FindRange(RangeName)
449     On Error GoTo Errhandler
450     Application.GoTo Reference:=RangeName
451     FindRange = 1
452     GoTo Bye
453 Errhandler:
454     FindRange = 0
455 Bye:
456 End Function
457 
458 Function SysVersions32()
459     ' Function determines Windows NT/2000 or 98/95
460 
461     Dim v As OSVERSIONINFO, retval As Long
462     Dim WindowsVersion As String, BuildVersion As String
463     Dim PlatformName As String
464           
465     v.dwOSVersionInfoSize = Len(v)
466     retval = GetVersionEx(v)
467     
468     WindowsVersion = v.dwMajorVersion & "." & v.dwMinorVersion
469     BuildVersion = v.dwBuildNumber And &HFFFF&
470  
471     Select Case v.dwPlatformId
472         Case VER_PLATFORM_WIN32_WINDOWS
473             PlatformName = "Windows 95/98"
474         Case VER_PLATFORM_WIN32_NT
475             PlatformName = "Windows NT/2000"
476     End Select
477          
478     'Return the Platform ID number
479     SysVersions32 = v.dwPlatformId
480     
481 End Function
482 
483 Function GetWfxPort$()
484     On Error GoTo Errhandler
485     Dim Version
486     Version = SysVersions32()
487     
488     'If the Version is Windows 95/98 get reg entry from one location, if it is Windows NT
489     'get the key from another location
490   
491     If Version = 1 Then
492         WfxPort$ = Space(256)
493         lResult& = RegOpenKey&(HLM, "System\CurrentControlSet\Control\Print\Printers\WinFax", hkeyWfx&)
494         lResult& = RegQueryValue&(hkeyWfx&, "Port", 0&, lType&, ByVal 0&, lcbValue&)
495         lResult& = RegQueryValue&(hkeyWfx&, "Port", 0&, lType&, ByVal WfxPort$, lcbValue&)
496         WfxPort$ = Left$(WfxPort$, lcbValue& - 1)
497         GetWfxPort$ = WfxPort$
498     Else
499         ' Windows NT/2000
500         WfxPort$ = Space(256)
501         lResult& = RegOpenKey&(HCU, "Software\Microsoft\Windows NT\CurrentVersion\Devices", hkeyWfx&)
502         lResult& = RegQueryValue&(hkeyWfx&, sDriverName, 0&, lType&, ByVal 0&, lcbValue&)
503         lResult& = RegQueryValue&(hkeyWfx&, sDriverName, 0&, lType&, ByVal WfxPort$, lcbValue&)
504         WfxPort$ = Left$(WfxPort$, lcbValue& - 1)
505         ' WfxPort$ = Right$(WfxPort$, 5)
506         Position = InStr(1, WfxPort$, ",")
507         WfxPort$ = Mid$(WfxPort$, Position + 1, Len(WfxPort$))
508         GetWfxPort$ = WfxPort$
509 End If
510 Exit Function
511 
512 Errhandler:
513     'If the WinFax Printer entry is not found Stop
514     ' the Macro and inform the user to
515     ' re-install the printer driver
516     
517     MsgBox sError3 & Chr$(13) & Chr$(10) & sError4
518     ' Error message that appears,
519     ' "The printer Driver does not appear to be installed"
520     ' + CRLF + "You must re-install the printer driver")
521     End
522 
523 End Function
524 
525  
526 
527 
528 Sub Auto_Open()
529      
530    GetLanguage
531    
532    ' On Error GoTo Errhandler
533 
534  ' Added code to check for the presence of WinFax on the system
535    WfxPath$ = Space(256)
536    lResult& = RegOpenKey&(HLM, "Software\Delrina\WinFax\7.0\WinFax", hkeyWfx&)
537    lResult& = RegQueryValue&(hkeyWfx&, "Exepath", 0&, lType&, ByVal 0&, lcbValue&)
538    lResult& = RegQueryValue&(hkeyWfx&, "Exepath", 0&, lType&, ByVal WfxPath$, lcbValue&)
539    If lcbValue& > 0 Then
540      WfxPath$ = Left$(WfxPath$, lcbValue& - 1)
541    Else
542        ' no Exepath key in registry, so we exit macro.
543        End
544    
545    End If
546             
547  
548    Dim Count
549    Dim Max
550     
551     'Check to see if the WinFax PRO 7.0 Add-In for Excel 7.0 is installed and disable it.
552     'This will prevent two WinFax options from appearing unde the File Menu
553     For count_1 = 1 To AddIns.Count
554         If AddIns.Item(count_1).Name = "WFX7_XL7.XLA" Then
555             AddIns("WinFax Macro for Excel 7.0").Installed = False
556         End If
557     Next
558     
559     'Check to see if the add in wfxxl97.xla is installed.
560     For count_1 = 1 To AddIns.Count
561         If AddIns.Item(count_1).Name = "WFXXL97.XLA" Then
562             AddIns("WinFax Macro for Excel 97").Installed = False
563         End If
564     Next
565     
566     'Check to see if WinFax is already on the File Menu and remove it.
567     Max = CommandBars("File").Controls.Count
568     Count = 1
569     While Count <= Max
570         If CommandBars("File").Controls(Count).Caption = sCommandBar Then
571             CommandBars("File").Controls(sCommandBar).Delete
572             Max = Max - 1
573         End If
574         Count = Count + 1
575     Wend
576     
577     'Add WinFax to the File Menu before the Print option
578     Set filemenu = CommandBars("File")
579     Set winfaxmenu = filemenu.Controls.Add(Before:="10")
580         winfaxmenu.Caption = sCommandBar ' "Win&Fax"
581         winfaxmenu.FaceId = 1707
582         winfaxmenu.OnAction = "WinFaxMacro"
583     
584     'Check to see if there is a Print To WinFax button on the Standard ToolBar and Remove it
585     Max = CommandBars("Standard").Controls.Count
586     Count = 1
587     While Count <= Max
588         If UCase$(CommandBars("Standard").Controls(Count).Caption) = UCase$(sCommandBarCaption) Then
589             CommandBars("Standard").Controls(sCommandBarCaption).Delete
590             Max = Max - 1
591         End If
592         Count = Count + 1
593     Wend
594     
595     'Add a Print To WinFax button on the Standard ToolBar after the Print Button
596     Set standardBar = CommandBars("Standard")
597         standardBar.Visible = True
598     Set winfaxBtn = standardBar.Controls.Add(Before:=5)
599         winfaxBtn.FaceId = 1707
600         winfaxBtn.Caption = sCommandBarCaption
601         winfaxBtn.OnAction = "WinFaxMacro"
602 
603 Errhandler:
604   
605   If Err.Number = 9 Then
606      Err.Clear
607      Resume Next
608   Else
609     ' Exit from here
610     ' MsgBox sError2 & Str$(Err) & " - " & Err.Description
611      
612      Exit Sub
613   
614   End If
615   
616 End Sub
617 Sub Auto_Close()
618     
619     GetLanguage
620     
621     ' if the toolbar is modified to not include the WinFax icon
622     ' or dropdown menu option then we need to
623     ' peacefully exit this subroutine
624     On Error GoTo Errhandler
625     
626     'When Closing the Add-In remove WinFax from the File Menu
627     ' that was added in the
628     ' Auto_Open module
629     CommandBars("File").Controls(sCommandBar).Delete
630     
631     'When Closing the Add-In remove the Print to WinFax button
632     ' that was added in the
633     ' Auto_Open module
634     CommandBars("Standard").Controls(sCommandBarCaption).Delete
635     
636 Errhandler:
637      Exit Sub
638      
639 End Sub
640