IFIX中一些常用功能的VBA代码.docx

根据现场实际需要做适当修改后即可使用：1.退出工作台Option ExplicitPrivate Declare Function FindWindow Lib user32 Alias FindWindowA (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPrivate Declare Function SendMessage& Lib user32 Alias SendMessageA (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Any)Private Sub bmpExit_Click() Dim lResult As Long Dim iResult Dim hw&, cnt& hw& = FindWindow(iFix Startup, vbNullString) If hw& = 0 Then MsgBox (无法关闭演示系统。请使用 Windows任务管理器将工作台关闭。) End If If hw& 0 Then cnt& = SendMessage(hw&, &H10, 0, 0&)End Sub2.IE浏览器打开网页Private Sub bmpGEFanucWebSite_Click()Dim lVar As Long Dim Result lVar = GetFocus() This shell function accesses the internet, and opens directly to the GE Fanuc Website Result = ShellExecute(lVar, Open, http:, vbNullString, vbNullString, 5) error check; If the local node is not connected to the internet, display an error message If Result 32 Then MsgBox 您需要连接服务器且具有互联网浏览器来显示GE Fanuc网站。 End IfEnd Sub3.打开帮助文档Private Declare Function WinHelp Lib user32 Alias WinHelpA (ByVal hwnd As Long, ByVal lpHelpFile As String, ByVal wCommand As Long, ByVal dwData As Long) As LongPrivate Sub txtHelpHelp_Click() Dim lngValue As Long Dim hwnd As Long Open Help for the Open Picture Command form hwnd = GetFocus lngValue = WinHelp(hwnd, System.HelpPath & SampleSystem.hlp, &H1&, 1)End Sub4.关闭虚拟键盘（需要copy文件）Private Sub bmpStopKey_Click() Dim hw&, cnt& hw& = FindWindow(My-T-Mouse, vbNullString) If hw& 0 Then cnt& = SendMessage(hw&, &H10, 0, 0&)End Sub5.打开虚拟键盘（需要copy文件）Private Sub bmpStartKey_Click() Dim hw& Dim d As Double hw& = FindWindow(My-T-Mouse, vbNullString) If hw& = 0 Then d = Shell(System.BasePath & MYTSOFT.EXE, vbMinimizedFocus) End IfEnd Sub6.检测机器分辨率Public Function CheckScreenResIsAtLeast1024x768() As BooleanFunction:Return a True if the NT screen resolution is1024 x 768 _ Only display the message box one time. Dim sngWidth As Single, sngHeight As Single, sMessage As String Dim sTitle As String Static boolRunOnce As Boolean On Error GoTo HandleError CheckScreenResIsAtLeast1024x768 = False sngWidth = clsSreenInfo.WidthInPixels sngHeight = clsSreenInfo.HeightInPixels If sngWidth = 1024 And sngHeight = 768 Then if at least 1024 x 768 resolution CheckScreenResIsAtLeast1024x768 = True End If If Not CheckScreenResIsAtLeast1024x768 And Not boolRunOnce Then sTitle = Your Screen Resolution is: & CStr(sngWidth) & x & CStr(sngHeight) sMessage = The sample system is best viewed at a screen resolution of at least _ & 1024 x 768. & vbCrLf _ & To change, go to the Windows Control Panel and modify the Display - Settings _ & property. We only want to show this dialog one time MsgBox sMessage, vbInformation, sTitle boolRunOnce = True End IfHandleError: Exit here on errorEnd Function7.改变字体大小Public Sub ChangeFontsIfBelow1024x768(objPic As Object) On Error Resume Next Dim sngWidth As Single, sngHeight As Single Dim clsSreenInfo As New ScreenInfo Dim DummyString As String Dim objChild As Object sngWidth = clsSreenInfo.WidthInPixels sngHeight = clsSreenInfo.HeightInPixels If Not (sngWidth = 1024 And sngHeight = 768) Then if not at least 1024 x 768 resolution For Each objChild In objPic.ContainedObjects If objChild.ClassName = OleObject Then DummyString = objChild.Font.Size If Err.Number = 0 Then objChild.Font.Size = objChild.Font.Size - 2 End If Err.Clear End If If objChild.ContainedObjects.Count 0 Then ChangeFontsIfBelow1024x768 objChild End If Next End If Set clsSreenInfo = NothingEnd Sub8.检测机器颜色是不是32真彩（由于字数太多，代码已删除）9.打开chm帮助指定页Public Declare Function HTMLHelp Lib hhctrl.ocx Alias HtmlHelpA (ByVal hwnd As Long, ByVal lpHelpFile As String, ByVal wCommand As Long, dwData As Any) As LongPrivate Sub txtLearnAboutIt_Click()Bring them to the specific Help docs page Dim aHelpFile As String Dim sSecondary As String aHelpFile = System.HelpPath & DRW.chmsecondary sSecondary = DRW_Using_Tag_Status_and_Quick_Trend_Pictures.htm Call HTMLHelp(0, aHelpFile, HH_DISPLAY_TOPIC, ByVal sSecondary)End Sub10.切换当前页面的提示信息Private Sub cmdToggleToolTips_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) On Error Resume NextFunction:Enable/Disable tool tips. _ Note that this function does not recurse through grouped objects - it _ only looks at main objects in the picture Dim obj As Object boolToolTipsControl.CurrentValue = Not boolToolTipsControl.CurrentValue For Each obj In Me.ContainedObjects obj.EnableTooltips = boolToolTipsControl.CurrentValue NextEnd Sub11.弹出滑块调节（模拟量）Private Sub TankBatchC3_Click() The Comments below have been added automatically. Any changes could cause adverse effects to the functionality of the Script Authoring Experts. WizardName=DataEntryOn Error GoTo ErrorHandlerIf blnDataEntryFrmFlag True Then GetFormSlider Dim dblLow As Double Dim dblHigh As Double Dim blnFetch As Boolean dblLow = ReadValue(Fix32.THISNODE.IFIX1_BATCH_TANK3LEVEL.a_elo) dblHigh = ReadValue(Fix32.THISNODE.IFIX1_BATCH_TANK3LEVEL.a_ehi) If (dblHigh 32767) Then MsgBox The high limit cannot be greater than 32,767 for this type of Data Entry, Please choose another. Exit Sub End If blnFetch = True Slider.Slider1.min = CInt(dblLow) Slider.Slider1.max = CInt(dblHigh) Slider.GetTheVars a:=1, b:=Fix32.THISNODE.IFIX1_BATCH_TANK3LEVEL.F_CV Slider.lblLow.Caption = dblLow Slider.lblHigh.Caption = dblHigh Slider.ShowEnd IfExit SubErrorHandler:HandleErrorEnd Sub12.弹出按钮控制（数字量）Private Sub MixerGroup1_Click() The Comments below have been added automatically. Any changes could cause adverse effects to the functionality of the Script Authoring Experts. WizardName=DataEntryOn Error GoTo ErrorHandlerIf blnDataEntryFrmFlag = True Then Exit SubEnd If GetFormPushbutton Dim strOpenButton As String Dim strCloseButton As String Dim dblLow As Double Dim dblHigh As Double dblLow = 0 dblHigh = 1 strOpenButton = 关闭 strCloseButton = 打开 Pushbutton.GetTheVars a:=1, b:=Fix32.THISNODE.IFIX1_BATCH_TANK3AGITATE.F_CV Pushbutton.cmdOpen.Caption = strOpenButton Pushbutton.cmdClose.Caption = strCloseButton Pushbutton.ShowExit SubErrorHandler:HandleErrorEnd Sub13.弹出梯度调节框Private Sub TempGroupTank1_Click() The Comments below have been added automatically. Any changes could cause adverse effects to the functionality of the Script Authoring Experts. WizardName=DataEntryOn Error GoTo ErrorHandlerIf blnDataEntryFrmFlag = True Then Exit SubEnd IfGetFormRampDim strFast As StringDim strSlow As StringDim blnFetch As BooleanRamp.GetTheLimits High:=ReadValue(Fix32.THISNODE.IFIX1_BATCH_TANK1TEMP.a_ehi), Low:=ReadValue(Fix32.THISNODE.IFIX1_BATCH_TANK1TEMP.a_elo)blnFetch = TrueRamp.GetTheVars a:=1, b:=Fix32.THISNODE.IFIX1_BATCH_TANK1TEMP.F_CVRamp.FastSlow F:=10, s:=5strFast = 10strSlow = 5Ramp.lblSlow = strSlow & %Ramp.lblFast = strFast & %Ramp.ShowExit SubErrorHandler:HandleErrorEnd Sub14.确认报警控件中的所有报警Private Sub cmdAcknowledgeAll_Click() Acknowledge all filtered alarms AlarmSummaryOCX1.AckAlarmPageExEnd Sub15.确认所选报警Private Sub cmdAcknowledgeSelected_Click() Acknowledge the alarm currently selected Dim sNode As String, sTag As String, boolTagSelected As Boolean boolTagSelected = AlarmSummaryOCX1.GetSelectedNodeTag(sNode, sTag) If boolTagSelected Then AcknowledgeAnAlarm sTagEnd Sub16.启用报警音效Private Sub cmdToggleAlarmHorn_Click() The Comments below have been added automatically. Any changes could cause adverse effects to the functionality of the Script Authoring Experts. WizardName=AlarmHorn Property1=optExpertTypeToggle AlarmHornEnabledToggleEnd Sub17.取消报警音效（静音）Private Sub cmdSilenceHorn_Click() The Comments below have been added automatically. Any changes could cause adverse effects to the functionality of the Script Authoring Experts. WizardName=AlarmHorn Property1=optExpertTypeSilence AlarmHornSilenceEnd Sub18.在下拉菜单中选择排序列（画面加载时用additem加选报警列名）Private Sub cmbSortList_Change() Resort the list If cmbSortList.Text Then AlarmSummaryOCX1.SortColumnName = cmbSortList.Text End IfEnd Sub19.报警控件中的升序Private Sub optSortAscending_Click() AlarmSummaryOCX1.SortOrderAscending = True optSortDescending.Value = False声音报警原代码2007-09-04 20:54在USER里添加一个模块,将下面代码放到模块里Private Declare Function sndPlaySound& Lib winmm.dll Alias sndPlaySoundA (ByVal lpszSoundName As String, ByVal uFlags As Long)Const SND_ASYNC = &H1Const SND_LOOP = &H8Public Sub playalarm() On Error Resume Next If User.playalarm.CurrentValue = True Then sndPlaySound C:windowsMediaringin.wav, SND_ASYNC Or SND_LOOP 循环播放 End IfEnd SubPublic Sub StopAlarm() On Error Resume Next sndPlaySound vbNullString, SND_ASYNC 停止播放 User.playalarm.CurrentValue = FalseEnd SubPublic Sub StartAlarm()User.playalarm.CurrentValue = TrueEnd Sub登陆脚本 Private Sub cmdlogin_Click()If user.userid.CurrentValue = admi