Visual Basic Toolbox

home *** CD-ROM | disk | FTP | other *** search

/ Visual Basic Toolbox / Visual Basic Toolbox (P.I.E.)(1996).ISO / message / msgboxmw / mbdmain.frm (.txt) < prev next >

Wrap

Visual Basic Form | 1995-04-03 | 19.9 KB | 619 lines

VERSION 2.00 Begin Form MBDMain BackColor = &H00C0C0C0& BorderStyle = 1 'Fixed Single Caption = "Message Box Designer" ClientHeight = 6315 ClientLeft = 1065 ClientTop = 510 ClientWidth = 7770 FontBold = -1 'True FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = -1 'True Height = 6720 Icon = MBDMAIN.FRX:0000 Left = 1005 LinkTopic = "Form1" MaxButton = 0 'False ScaleHeight = 6315 ScaleWidth = 7770 Top = 165 Width = 7890 Begin SSFrame Frame3D5 Caption = "Data" Font3D = 3 'Inset w/light shading ForeColor = &H00000000& Height = 2985 Left = 180 TabIndex = 16 Top = 180 Width = 7395 Begin PictureBox Picture1 BackColor = &H00C0C0C0& BorderStyle = 0 'None Height = 285 Left = 6975 ScaleHeight = 285 ScaleWidth = 285 TabIndex = 26 TabStop = 0 'False Top = 2580 Width = 285 End Begin TextBox txtMessage BackColor = &H00FFFF00& FontBold = -1 'True FontItalic = 0 'False FontName = "System" FontSize = 9.75 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 1380 Left = 180 MultiLine = -1 'True ScrollBars = 3 'Both TabIndex = 3 Top = 1440 Width = 7035 End Begin CommandButton btnClear Caption = "&Wipe" Height = 375 Left = 6300 TabIndex = 4 Top = 630 Width = 915 End Begin TextBox txtTitle BackColor = &H00FFFF00& FontBold = -1 'True FontItalic = 0 'False FontName = "System" FontSize = 9.75 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 360 Left = 180 TabIndex = 1 Text = "{application name}" Top = 630 Width = 5955 End Begin Label NumLines Alignment = 1 'Right Justify BackColor = &H00C0C0C0& Caption = "0" ForeColor = &H00808080& Height = 195 Left = 6210 TabIndex = 24 Top = 1170 Width = 330 End Begin Label Label3 BackColor = &H00C0C0C0& Caption = "&Title" Height = 195 Left = 180 TabIndex = 0 Top = 360 Width = 1005 End Begin Label Label4 BackColor = &H00C0C0C0& Caption = "&Message" Height = 195 Left = 180 TabIndex = 2 Top = 1170 Width = 765 End Begin Label Label8 BackColor = &H00C0C0C0& Caption = "Line(s)" ForeColor = &H00808080& Height = 195 Left = 6570 TabIndex = 25 Top = 1170 Width = 585 End End Begin SSFrame Frame3D4 ForeColor = &H00000000& Height = 915 Left = 180 TabIndex = 23 Top = 5220 Width = 7395 Begin CommandButton btnHelp Caption = "&Help" Height = 465 Left = 3960 TabIndex = 14 Top = 270 Width = 1275 End Begin CommandButton btnExit Caption = "E&xit" Height = 465 Left = 5760 TabIndex = 15 Top = 270 Width = 1275 End Begin CommandButton btnTest Caption = "&Preview" Enabled = 0 'False Height = 465 Left = 2160 TabIndex = 13 Top = 270 Width = 1275 End Begin CommandButton btnExport Caption = "&Export" Enabled = 0 'False Height = 465 Left = 360 TabIndex = 12 Top = 270 Width = 1275 End End Begin SSFrame Frame3D3 Caption = "Modal State" Font3D = 3 'Inset w/light shading ForeColor = &H00000000& Height = 1905 Left = 5940 TabIndex = 20 Top = 3240 Width = 1635 Begin SSOption MState1 Caption = "&Application" Height = 465 Index = 1 Left = 180 TabIndex = 11 Top = 1170 Value = -1 'True Width = 1185 End Begin SSOption MState1 Caption = "&System" Height = 465 Index = 0 Left = 180 TabIndex = 10 TabStop = 0 'False Top = 720 Width = 1185 End End Begin SSFrame Frame3D2 Caption = "Icon" Font3D = 3 'Inset w/light shading ForeColor = &H00000000& Height = 1905 Left = 3960 TabIndex = 18 Top = 3240 Width = 1815 Begin VScrollBar VScroll1 Height = 1005 Left = 180 Max = 3 TabIndex = 9 Top = 720 Width = 285 End Begin PictureBox DisplayIcon BackColor = &H00C0C0C0& BorderStyle = 0 'None Height = 540 Left = 870 ScaleHeight = 38.118 ScaleMode = 0 'User ScaleWidth = 38.118 TabIndex = 21 TabStop = 0 'False Top = 810 Width = 540 End Begin Label Label5 BackColor = &H00C0C0C0& Caption = "Sele&ct" Height = 195 Left = 180 TabIndex = 19 Top = 450 Width = 1005 End Begin Label Label1 Alignment = 2 'Center BackColor = &H00C0C0C0& Caption = "Stop" Height = 285 Left = 540 TabIndex = 22 Top = 1440 Width = 1185 End End Begin SSFrame Frame3D1 Caption = "Buttons" Font3D = 3 'Inset w/light shading Height = 1905 Left = 180 TabIndex = 17 Top = 3240 Width = 3615 Begin ComboBox MBbtnStyle BackColor = &H00FFFF00& Height = 300 Left = 180 Style = 2 'Dropdown List TabIndex = 6 Top = 720 Width = 3255 End Begin ComboBox MBbtnDefault BackColor = &H00FFFF00& Enabled = 0 'False Height = 300 Left = 180 Style = 2 'Dropdown List TabIndex = 8 Top = 1440 Width = 3255 End Begin Label Label2 BackColor = &H00C0C0C0& Caption = "&Default" Height = 195 Index = 0 Left = 180 TabIndex = 7 Top = 1170 Width = 1245 End Begin Label Label2 BackColor = &H00C0C0C0& Caption = "&Layout" Height = 195 Index = 1 Left = 180 TabIndex = 5 Top = 450 Width = 1245 End End Begin Image Image2 Height = 540 Index = 3 Left = 2790 Picture = MBDMAIN.FRX:0302 Top = 6840 Width = 540 End Begin Image Image2 Height = 540 Index = 2 Left = 2160 Picture = MBDMAIN.FRX:064C Top = 6840 Width = 540 End Begin Image Image2 Height = 540 Index = 1 Left = 1530 Picture = MBDMAIN.FRX:0996 Top = 6840 Width = 540 End Begin Image Image2 Height = 540 Index = 0 Left = 900 Picture = MBDMAIN.FRX:0CE0 Top = 6840 Width = 540 End Option Explicit Dim IconArr(4) As String 'msgbox icon descriptions Dim MBValue As Integer 'msgbox type value Sub btnClear_Click () 'clear title and message text boxes txtTitle = "{application name}" txtMessage = "" txtTitle.SetFocus NumLines = 0 'hilite contents of title textbox txtTitle.SelStart = 0 txtTitle.SelLength = Len(txtTitle) End Sub Sub btnExit_Click () 'unload all forms and terminate Unload Me End Sub Sub btnExport_Click () 'export code for creating message box to clipboard 'if VB code window open paste into window at current 'caret position 'linefeed Const LF = " & Chr$(10)" 'variable declarations Dim CR As String * 1 'carriage return Dim QT As String * 1 'quote Dim temp As String 'scratch string Dim MBD_Title As String 'message box title Dim MBD_MsgText As String 'message box text Dim VBLine As String 'command line in VB format Dim message As String 'scratch string Dim loopcount As Integer 'loop counter Dim linecount As Integer 'number of lines in textbox 'carriage return and quote characters CR = Chr$(13) QT = Chr$(34) 'get function/statement option from user ExOption.Show MODAL 'abort paste to clipboard on user request If MBD_BtnReturned = IDCANCEL Then Exit Sub 'get number of lines in textbox linecount = SendMessageBynum(txtMessage.hWnd, EM_GETLINECOUNT, 0, 0&) 'get first line temp = GetTextLine(txtMessage, 0) 'build message text of message box 'allow for empty first line If temp = "" Then message = "MBD_MsgText = Chr$(10)" message = "MBD_MsgText = " & QT & temp & QT If linecount > 1 Then message = message & LF End If 'get each remaining line and add to message text 'of message box For loopcount = 1 To linecount - 1 temp = GetTextLine(txtMessage, loopcount) If temp = "" Then 'empty line If loopcount < linecount - 1 Then message = message & LF Else 'line with text message = message & CR & "MBD_MsgText = MBD_MsgText & " & QT & temp & QT 'append linefeed if not last line If loopcount < linecount - 1 Then message = message & LF End If 'start of function/statement call If MBD_BtnReturned = IDYES Then VBLine = "MBD_BtnReturned = MsgBox(MBD_MsgText" 'function VBLine = "MsgBox MBD_MsgText" 'statement End If 'place type value in call Calc_MBValue VBLine = VBLine & ", " & MBValue 'allow for default title If UCase(txtTitle) = "{APPLICATION NAME}" Then MBD_Title = "" 'no title given - use default MBD_Title = txtTitle 'title supplied End If 'place title text in call (if title exists) If MBD_Title > "" Then VBLine = VBLine & ", " & QT & MBD_Title & QT End If 'terminate function call If MBD_BtnReturned = IDYES Then VBLine = VBLine & ")" clipcopy: 'copy call to clipboard Clipboard.Clear Clipboard.SetText message & CR & VBLine 'switch to VB - if VB not running signal error On Error GoTo err_handler AppActivate "Microsoft Visual Basic" On Error GoTo 0 DoEvents 'paste clipboard contents into VB code window SendKeys "%EP" DoEvents Exit Sub 'handle error in switching to VB err_handler: On Error GoTo 0 MBD_MsgText = "Microsoft Visual Basic not running. Unable to export directly to " MBD_MsgText = MBD_MsgText & "Visual Basic code window. Code copied to Clipboard only." MBD_BtnReturned = MsgBox(MBD_MsgText, 69, "Message Box Designer") If MBD_BtnReturned = IDRETRY Then Resume clipcopy Exit Sub End If End Sub Sub btnHelp_Click () Dim result As Integer 'load help file MBDMain.MousePointer = 11 'hourglass pointer result = WinHelp(Me.hWnd, App.HelpFile, HELP_INDEX, "") MBDMain.MousePointer = 0 'default pointer End Sub Sub btnTest_Click () 'display a sample message box using currently selected 'values Dim message As String Dim i As Integer Dim char As String * 1 'calculate selected type values Calc_MBValue 'strip out CR characters (upsets system modal MB's) For i = 1 To Len(txtMessage) char = Mid(txtMessage, i, 1) If char <> Chr$(13) Then message = message & char 'display message box using selected values MsgBox message, MBValue, txtTitle End Sub Sub Calc_MBValue () 'calculate message box type value from MDBMain 'control settings 'icon MBValue = VScroll1.Value * 16 + 16 'modal state If MState1(0).Value Then MBValue = MBValue + 4096 'number/type of buttons MBValue = MBValue + MBbtnStyle.ListIndex 'default button MBValue = MBValue + MBbtnDefault.ListIndex * 256 End Sub Sub Form_Load () Dim result As Integer Dim SaveAppTitle As String 'allow only one copy of application to run 'switch to previous instance if it exists If App.PrevInstance Then SaveAppTitle = App.Title App.Title = "... duplicate instance." MBDMain.Caption = "... duplicate instance." AppActivate SaveAppTitle SendKeys "% R", True End End If 'initialise style combo box 'ItemData property = number of buttons in each style MBbtnStyle.AddItem "OK button only." MBbtnStyle.ItemData(MBbtnStyle.NewIndex) = 1 MBbtnStyle.AddItem "OK and Cancel buttons." MBbtnStyle.ItemData(MBbtnStyle.NewIndex) = 2 MBbtnStyle.AddItem "Abort, Retry, and Ignore buttons." MBbtnStyle.ItemData(MBbtnStyle.NewIndex) = 3 MBbtnStyle.AddItem "Yes, No, and Cancel buttons." MBbtnStyle.ItemData(MBbtnStyle.NewIndex) = 3 MBbtnStyle.AddItem "Yes and No buttons." MBbtnStyle.ItemData(MBbtnStyle.NewIndex) = 2 MBbtnStyle.AddItem "Retry and Cancel buttons." MBbtnStyle.ItemData(MBbtnStyle.NewIndex) = 2 MBbtnStyle.ListIndex = 0 'initialise default button combo box MBbtnDefault.AddItem "First button" MBbtnDefault.ListIndex = 0 'initialise string array of icon descriptions IconArr(0) = "Stop" IconArr(1) = "Question" IconArr(2) = "Exclamation" IconArr(3) = "Information" 'show banner About.Show MODAL 'load user option form Load ExOption 'center form on screen Center_Form Me 'show default icon DisplayIcon.Picture = image2(0).Picture 'hilite title txtTitle.SelStart = 0 txtTitle.SelLength = Len(txtTitle) Me.Refresh End Sub Sub Form_QueryUnload (Cancel As Integer, UnloadMode As Integer) Dim result As Integer 'unload help file if open result = WinHelp(Me.hWnd, App.HelpFile, HELP_QUIT, 0&) 'clear preloaded form Unload ExOption End Sub Sub Form_Unload (Cancel As Integer) End Sub Function GetTextLine (TB As TextBox, nLine As Integer) As String 'retrieve a line (nLine) of text from textbox (TB) Dim start As Integer Dim lSize As Long Dim buffer As String Dim result As Long 'get offset to first character in line nLine start = SendMessageBynum(TB.hWnd, EM_LINEINDEX, nLine, 0&) 'get length of line nLine lSize = SendMessageBynum(TB.hWnd, EM_LINELENGTH, start, 0&) + 1 'allocate string to contain result buffer = String$(lSize + 2, 0) 'prepare string for API call Mid$(buffer, 1, 1) = Chr$(lSize And &HFF) Mid$(buffer, 2, 1) = Chr$(lSize \ &H100) 'get the line result = SendMessageBystring(TB.hWnd, EM_GETLINE, nLine, buffer) 'return result to caller GetTextLine = Left(buffer, result) End Function Sub MBbtnStyle_Click () Static old_value As Integer 'saved value 'present available default buttons based on message box style 'skip if new style has same default as previous selection If MBbtnStyle.ItemData(MBbtnStyle.ListIndex) <> old_value Then 'clear combo MBbtnDefault.Clear 'add available defaults based on itemdata property of style MBbtnDefault.AddItem "First button" Select Case MBbtnStyle.ItemData(MBbtnStyle.ListIndex) Case 2 MBbtnDefault.AddItem "Second button" Case 3 MBbtnDefault.AddItem "Second button" MBbtnDefault.AddItem "Third button" End Select 'show first available default MBbtnDefault.ListIndex = 0 MBbtnDefault.Refresh 'save value for next call old_value = MBbtnStyle.ItemData(MBbtnStyle.ListIndex) 'disable defaults if only one available If old_value = 1 Then MBbtnDefault.Enabled = False Else MBbtnDefault.Enabled = True End If End If End Sub Function TotalLines (TB As TextBox) As Integer 'get total number of lines in textbox TB TotalLines = SendMessageBynum(TB.hWnd, EM_GETLINECOUNT, 0, 0&) End Function Sub txtMessage_Change () Dim tlnew As Integer Static tlold As Integer 'saved value 'disable Export and Preview buttons if no message text If Len(txtMessage) > 0 Then btnExport.Enabled = True btnTest.Enabled = True btnExport.Enabled = False btnTest.Enabled = False NumLines = 0 tlold = 0 Exit Sub End If 'display number of lines in message textbox 'skip if no change tlnew = TotalLines(txtMessage) If tlnew <> tlold Then NumLines = tlnew tlold = tlnew End If End Sub Sub txtTitle_KeyPress (KeyAscii As Integer) 'allow Enter key to terminate Title entry If KeyAscii = 13 Then KeyAscii = 0 'prevent beep txtMessage.SetFocus 'move caret to message entry textbox End If End Sub Sub txtTitle_LostFocus () 'if Title entry text box empty replace default If txtTitle = "" Then txtTitle = "{application name}" End Sub Sub VScroll1_Change () 'display icon and descriptor based on scrollbar position DisplayIcon.Picture = image2(VScroll1.Value).Picture Label1.Caption = IconArr(VScroll1.Value) End Sub Sub VScroll1_Scroll () 'display icon and descriptor based on scrollbar position DisplayIcon.Picture = image2(VScroll1.Value).Picture Label1.Caption = IconArr(VScroll1.Value) End Sub