[转]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&Faxdot.gif "    '  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&Faxdot.gif "    '  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 heredot.gif
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&Faxdot.gif "    '  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&Faxdot.gif "    '  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&Faxdot.gif"
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 

转载于:https://www.cnblogs.com/nyzfl/articles/839823.html

  • 0
    点赞
  • 0
    收藏
    觉得还不错? 一键收藏
  • 0
    评论
评论
添加红包

请填写红包祝福语或标题

红包个数最小为10个

红包金额最低5元

当前余额3.43前往充值 >
需支付:10.00
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、付费专栏及课程。

余额充值