第10章--其-他-应-用代码【超实用VBA】

104第10章其他应用范例144取得电脑名称PrivateSubWorkbook_Open()DimmyNameAsStringmyName=Environ(Computername)IfmyNameYUANZHUPINGThenMsgBox对不起，您不是合法用户，文件将关闭!ThisWorkbook.CloseEndIfEndSub范例145定时关闭电脑SubTimingOff()Shell(at20:09Shutdown.exe-s)EndSub范例146保护VBA代码146-1设置工程密码146-2设置“工程不可查看”范例147使用数字签名范例148打开指定网页105SubOpenTheWeb()ActiveWorkbook.FollowHyperlink_Address:=:=TrueEndSub范例149自定义“加载项”选项卡SubAddinstab()DimmyBarPopupAsCommandBarPopupDimmyBarAsCommandBarDimArrOneAsVariantDimArrTwoAsVariantDimArrThreeAsVariantDimArrFourAsVariantDimiAsByteOnErrorResumeNextArrOne=Array(凭证打印,账簿打印,报表打印)ArrThree=Array(会计凭证,会计账簿,会计报表)ArrTwo=Array(281,283,285)ArrFour=Array(9893,284,9590)WithApplication.CommandBars(Worksheetmenubar).ResetSetmyBarPopup=.Controls.Add(msoControlPopup)WithmyBarPopup.Caption=打印Fori=0ToUBound(ArrOne)With.Controls.Add(msoControlButton).Caption=ArrOne(i).FaceId=ArrTwo(i).OnAction=myOnActionEndWithNextEndWithEndWithApplication.CommandBars(MyToolbar).DeleteSetmyBar=Application.CommandBars.Add(MyToolbar)WithmyBar.Visible=TrueFori=0ToUBound(ArrThree)With.Controls.Add(msoControlButton).Caption=ArrThree(i).FaceId=ArrFour(i).OnAction=myOnAction106.Style=msoButtonIconAndCaptionBelowEndWithNextEndWithSetmyBarPopup=NothingSetmyBar=NothingEndSubPublicSubmyOnAction()MsgBox您选择了：&Application.CommandBars.ActionControl.CaptionEndSubSubDeleteToolbar()OnErrorResumeNextApplication.CommandBars(MyToolbar).DeleteApplication.CommandBars(Worksheetmenubar).ResetEndSub范例150使用右键快捷菜单150-1右键快捷菜单增加菜单项SubMyCmb()DimMyCmbAsCommandBarButtonWithApplication.CommandBars(Cell).ResetSetMyCmb=.Controls.Add(Type:=msoControlButton,_ID:=2521,Temporary:=True)EndWithMyCmb.BeginGroup=TrueSetMyCmb=NothingEndSub150-2自定义右键快捷菜单SubMycell()WithApplication.CommandBars.Add(Mycell,msoBarPopup)With.Controls.Add(Type:=msoControlButton).Caption=会计凭证.FaceId=9893EndWithWith.Controls.Add(Type:=msoControlButton)107.Caption=会计账簿.FaceId=284EndWithWith.Controls.Add(Type:=msoControlPopup).Caption=会计报表With.Controls.Add(Type:=msoControlButton).Caption=月报.FaceId=9590EndWithWith.Controls.Add(Type:=msoControlButton).Caption=季报.FaceId=9591EndWithWith.Controls.Add(Type:=msoControlButton).Caption=年报.FaceId=9592EndWithEndWithWith.Controls.Add(Type:=msoControlButton).Caption=凭证打印.FaceId=9614.BeginGroup=TrueEndWithWith.Controls.Add(Type:=msoControlButton).Caption=账簿打印.FaceId=707EndWithWith.Controls.Add(Type:=msoControlButton).Caption=报表打印.FaceId=986EndWithEndWithEndSubPrivateSubWorksheet_BeforeRightClick(ByValTargetAsRange,CancelAsBoolean)Application.CommandBars(Mycell).ShowPopupCancel=TrueEndSub150-3使用快捷菜单输入数据SubMycell()DimarrAsVariantDimiAsIntegerDimMycellAsCommandBar108OnErrorResumeNextApplication.CommandBars(Mycell).Deletearr=Array(经理室,办公室,生技科,财务科,营业部)SetMycell=Application.CommandBars.Add(Mycell,msoBarPopup)Fori=0To4WithMycell.Controls.Add(1).Caption=arr(i).OnAction=MyOnActionEndWithNextEndSubSubMyOnAction()ActiveCell=Application.CommandBars.ActionControl.CaptionEndSubPrivateSubWorksheet_SelectionChange(ByValTargetAsRange)IfTarget.Column=1AndTarget.Count=1ThenCallMycellApplication.CommandBars(Mycell).ShowPopupEndIfEndSub150-4禁用右键快捷菜单SubDisableMenu()DimmyBarAsCommandBarForEachmyBarInCommandBarsIfmyBar.Type=msoBarTypePopupThenmyBar.Enabled=FalseEndIfNextEndSubSubEnableMenu()DimmyBarAsCommandBarForEachmyBarInCommandBarsIfmyBar.Type=msoBarTypePopupThenmyBar.Enabled=TrueEndIfNextEndSub范例151VBE相关操作109151-1添加模块和过程SubNowModule()DimVBCAsVBComponentSetVBC=ThisWorkbook.VBProject.VBComponents.Add(vbext_ct_StdModule)VBC.Name=NowModuleWithVBC.CodeModuleIf.Lines(1,1)OptionExplicitThen.InsertLines1,OptionExplicitEndIf.InsertLines2,SubProcessOne().InsertLines3,vbTab&MsgBox这是第一个过程!.InsertLines4,EndSub.AddFromStringSubProcessTwo()&Chr(13)&vbTab_&MsgBox这是第二个过程!&Chr(13)&EndSubEndWithSetVBC=NothingEndSub151-2建立事件过程SubAddMatter()DimShAsWorksheetDimrAsIntegerForEachShInWorksheetsIfSh.Name=MatterThenExitSubNextSetSh=Sheets.Add(After:=Sheets(Sheets.Count))Sh.Name=MatterApplication.VBE.MainWindow.Visible=TrueWithThisWorkbook.VBProject.VBComponents(Sh.CodeName).CodeModuler=.CreateEventProc(SelectionChange,Worksheet).ReplaceLiner+1,vbTab&IfTarget.Count=1Then_&Chr(13)&Space(8)&MsgBox你选择了&Target.Address(0,0)&单元格!_&Chr(13)&vbTab&EndIfEndWithApplication.VBE.MainWindow.Visible=FalseSetSh=NothingEndSub151-3模块的导入与导出SubCopyModule()110DimNowbookAsWorkbookDimMyTxtAsStringMyTxt=ThisWorkbook.Path&\AddMatter.txtThisWorkbook.VBProject.VBComponents(AddMatter).ExportMyTxtSetNowbook=Workbooks.AddWithNowbook.SaveAsFilename:=ThisWorkbook.Path&\CopyModule.xlsm,FileFormat:=xlOpenXMLWorkbookMacroEnabled.VBProject.VBComponents.ImportMyTxt.CloseSavechanges:=TrueEndWithKillMyTxtEndSub151-4删除VBA代码SubDelMacro()DimWbAsWorkbookDimVbcAsVBComponentSetWb=Workbooks.Open(ThisWorkbook.Path&\DelMacro.xlsm)WithWbForEachVbcIn.VBProject.VBComponentsIfVbc.Typevbext_ct_DocumentThenSelectCaseVbc.NameCaseShowFormVbc.CodeModule.DeleteLines3,3CaseMyTreeViewCaseElse.VBProject.VBComponents.RemoveVbcEndSelectEndIfNe