[转]Send Fax VBA's Code
我这有一个发传真的VBA代码供大家学习
学习这段代码时, 建议装一下 WINFAX 9.0/10. 会有助于理解.
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
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 reference110 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 reference125 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 reference139 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 reference153 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
