PC Plus SuperCD (UK) 1995 September

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

/ PC Plus SuperCD (UK) 1995 September / Image.iso / pcplus / handson / vbwrk107 / apimmain.frm (.txt) < prev next >

Wrap

Visual Basic Form | 1995-06-09 | 21.2 KB | 675 lines

VERSION 2.00 Begin Form APIMAGIC BackColor = &H00C0C0C0& BorderStyle = 1 'Fixed Single Caption = "API Magic" ClientHeight = 5868 ClientLeft = 1392 ClientTop = 1944 ClientWidth = 7572 ClipControls = 0 'False Height = 6612 Icon = APIMMAIN.FRX:0000 Left = 1344 LinkTopic = "Form1" MaxButton = 0 'False ScaleHeight = 5868 ScaleWidth = 7572 Top = 1248 Width = 7668 Begin PictureBox Busy_Flash BackColor = &H00800000& ClipControls = 0 'False Height = 825 Left = 540 ScaleHeight = 804 ScaleWidth = 3684 TabIndex = 20 Top = 2430 Visible = 0 'False Width = 3705 Begin Label Label1 Alignment = 2 'Center BackStyle = 0 'Transparent Caption = "Loading Data...." ForeColor = &H00000000& Height = 195 Left = 180 TabIndex = 21 Top = 270 Width = 3255 End Begin Shape Shape1 BorderColor = &H0080FFFF& BorderStyle = 0 'Transparent FillColor = &H0080FFFF& FillStyle = 0 'Solid Height = 645 Left = 90 Top = 90 Width = 3525 End End Begin PictureBox AniPic AutoRedraw = -1 'True AutoSize = -1 'True BorderStyle = 0 'None Height = 384 Index = 0 Left = 4860 Picture = APIMMAIN.FRX:0302 ScaleHeight = 32 ScaleMode = 3 'Pixel ScaleWidth = 32 TabIndex = 18 Top = 5940 Visible = 0 'False Width = 384 End Begin PictureBox AniPic AutoRedraw = -1 'True AutoSize = -1 'True BorderStyle = 0 'None Height = 384 Index = 1 Left = 5490 Picture = APIMMAIN.FRX:0604 ScaleHeight = 32 ScaleMode = 3 'Pixel ScaleWidth = 32 TabIndex = 17 Top = 5940 Visible = 0 'False Width = 384 End Begin Timer AniTimer Enabled = 0 'False Interval = 100 Left = 4320 Top = 6030 End Begin SSFrame Frame3D5 Font3D = 3 'Inset w/light shading Height = 1905 Left = 180 ShadowStyle = 1 'Raised TabIndex = 15 Top = 3780 Width = 7215 Begin PictureBox mask BackColor = &H00C0C0C0& BorderStyle = 0 'None Enabled = 0 'False Height = 285 Left = 6885 ScaleHeight = 288 ScaleWidth = 288 TabIndex = 16 TabStop = 0 'False Top = 1575 Width = 285 End Begin TextBox txtOutput ForeColor = &H00000000& Height = 1635 Left = 90 MultiLine = -1 'True ScrollBars = 3 'Both TabIndex = 2 Top = 180 Width = 7035 End End Begin SSFrame Frame3D4 Font3D = 3 'Inset w/light shading Height = 1635 Left = 165 ShadowStyle = 1 'Raised TabIndex = 14 Top = 1995 Width = 4440 Begin ListBox lbSelect ForeColor = &H00000000& Height = 1368 Left = 75 TabIndex = 1 Top = 165 Width = 4248 End End Begin SSFrame Frame3D3 Font3D = 3 'Inset w/light shading Height = 1635 Left = 4860 ShadowStyle = 1 'Raised TabIndex = 13 Top = 1980 Width = 2535 Begin PictureBox Logo AutoSize = -1 'True ClipControls = 0 'False ForeColor = &H00000000& Height = 408 Left = 1620 MousePointer = 4 'Icon Picture = APIMMAIN.FRX:0906 ScaleHeight = 32 ScaleMode = 3 'Pixel ScaleWidth = 32 TabIndex = 19 TabStop = 0 'False Top = 270 Width = 408 End Begin SSCommand btn3DClear Caption = "&Clear" Font3D = 3 'Inset w/light shading ForeColor = &H00000000& Height = 465 Left = 180 TabIndex = 7 Top = 270 Width = 915 End Begin SSCommand btn3DExport Caption = "&Export" Enabled = 0 'False Font3D = 3 'Inset w/light shading ForeColor = &H00000000& Height = 465 Left = 180 TabIndex = 8 Top = 990 Width = 915 End Begin SSCommand btn3DExit Caption = "E&xit" Font3D = 3 'Inset w/light shading ForeColor = &H00000000& Height = 465 Left = 1440 TabIndex = 9 Top = 990 Width = 915 End End Begin SSFrame Frame3D2 Caption = "Display" Font3D = 3 'Inset w/light shading ForeColor = &H00000000& Height = 1635 Left = 4860 ShadowStyle = 1 'Raised TabIndex = 12 Top = 180 Width = 2535 Begin SSOption OptVBConst Caption = "VB Constants" Font3D = 3 'Inset w/light shading ForeColor = &H00000000& Height = 285 Left = 270 TabIndex = 6 TabStop = 0 'False Top = 1170 Width = 2085 End Begin SSOption OptAPIDecs Caption = "API Declarations" Font3D = 3 'Inset w/light shading ForeColor = &H00000000& Height = 285 Left = 270 TabIndex = 3 Top = 360 Width = 2085 End Begin SSOption OptAPIConst Caption = "API Constants" Font3D = 3 'Inset w/light shading ForeColor = &H00000000& Height = 285 Left = 270 TabIndex = 4 TabStop = 0 'False Top = 630 Width = 2085 End Begin SSOption OptAPIStruct Caption = "API Structures" Font3D = 3 'Inset w/light shading ForeColor = &H00000000& Height = 285 Left = 270 TabIndex = 5 TabStop = 0 'False Top = 900 Width = 2085 End End Begin SSFrame Frame3D1 Caption = "Search" Font3D = 3 'Inset w/light shading ForeColor = &H00000000& Height = 1635 Left = 180 ShadowStyle = 1 'Raised TabIndex = 10 Top = 180 Width = 4425 Begin TextBox txtSearch BackColor = &H00FFFF00& ForeColor = &H00000000& Height = 285 Left = 180 TabIndex = 0 Top = 360 Width = 4065 End Begin CommandButton btnAlpha BackColor = &H00C0C0C0& Caption = "A" Height = 285 Index = 0 Left = 360 TabIndex = 11 TabStop = 0 'False Top = 810 Width = 285 End End Begin Menu mnuHelp Caption = "&Help" Begin Menu mnuHelpContents Caption = "&Contents" End Begin Menu sep1 Caption = "-" End Begin Menu mnuHelpAbout Caption = "&About" End End Option Explicit 'create form level variables/constants Dim DB As Database 'database object Dim DTbl As Table 'table object Dim anistate As Integer 'animate logo true/false Dim BMark() As Variant 'dynamic array to hold bookmarks Dim CRLF As String * 2 'carriage return/linefeed pair Dim result As Integer 'return value from API calls Dim user_choice As Integer 'last user selection Const DB_READONLY = 4 'database read only option 'cursor keys Const KEY_CUR_DOWN = &H28 'cursor down Const KEY_CUR_UP = &H26 'cursor up Sub Animate () 'this routine animates the APIMAGIC icons Static state As Integer 'animation state record 'toggle animation state on each call state = state Xor 1 'animate icon if application minimised If APIMAGIC.WindowState = MINIMIZED Then 'animate icon result = BitBlt(APIMAGIC.hDC, 2, 2, 32, 32, AniPic(state).hDC, 0, 0, SRCCOPY) 'otherwise animate logo on main window result = BitBlt(Logo.hDC, 0, 0, 32, 32, AniPic(state).hDC, 0, 0, SRCCOPY) 'if About... screen loaded - animate it's logos If AboutLoaded Then result = BitBlt(APIMLOGO!Logo1.hDC, 0, 0, 32, 32, AniPic(state).hDC, 0, 0, SRCCOPY) result = BitBlt(APIMLOGO!Logo2.hDC, 0, 0, 32, 32, AniPic(state).hDC, 0, 0, SRCCOPY) End If End If End Sub Sub AniTimer_Timer () 'call icon animation subroutine Animate End Sub Sub btn3DClear_Click () 'reset select/search box lbSelect.ListIndex = 0 txtSearch.SetFocus 'erase the output textbox txtOutput = "" End Sub Sub btn3DExit_Click () 'trigger program end Unload Me End Sub Sub btn3DExport_Click () Dim VBCode As String 'text to be exported Dim MBD_MsgText As String 'text in message box 'prepare export text VBCode = txtOutput If Right(VBCode, 2) <> CRLF Then VBCode = VBCode & CRLF 'place data onto clipboard Clipboard.Clear Clipboard.SetText txtOutput & CRLF 'return select box to last selected item Reset_SelectBox 'switch to VB - if VB not running then skip 'the rest of this event result = FindWindowByTitle(0&, "Microsoft Visual Basic") If result = 0 Then Exit Sub result = ShowWindow(result, SW_SHOWNOACTIVATE) AppActivate "Microsoft Visual Basic" DoEvents 'paste clipboard contents into VB code window if 'not running in design environment If App.EXEName = "APIM" Then MBD_MsgText = "Cannot export code into my own executing source code. Code placed on clipboard only." MsgBox MBD_MsgText, 48, "API MAGIC Reality Error" Exit Sub SendKeys "%EP", True End If End Sub Sub btnAlpha_Click (Index As Integer) 'clear any search string txtSearch = "" 'find next entry in select box starting with button legend result = SendMessageByString(lbSelect.hWnd, LB_FINDSTRING, lbSelect.ListIndex, btnAlpha(Index).Caption) 'if match found then position it at the top of 'the select box If result > -1 Then lbSelect.ListIndex = result result = SendMessageByNum(lbSelect.hWnd, LB_SETTOPINDEX, result, 0&) End If txtSearch.SetFocus End Sub Sub Form_Load () Dim i As Integer 'general loop counter Dim x As Integer 'positioning value for alpha buttons Dim y As Integer 'positioning value for alpha buttons Dim db_name As String 'path and name of database Dim MBD_MsgText As String 'message box text 'allow only one copy of API MAGIC to run 'switch to previous instance if it exists If App.PrevInstance Then Dim SaveTitle As String SaveTitle = App.Title App.Title = "... duplicate instance." APIMAGIC.Caption = "... duplicate instance." AppActivate SaveTitle SendKeys "% R", True End End If 'build path and filename of database file db_name = App.Path If Right(db_name, 1) <> "\" Then db_name = db_name & "\" db_name = db_name & "APIMAGIC.MDB" 'check we have a database If Len(Dir(db_name)) = 0 Then MBD_MsgText = "Unable to locate database file:" & Chr$(10) & db_name MsgBox MBD_MsgText, 16 End End If '***** Loading the form APIMBtn will add a button '***** to Visual BASIC's toolbar *if* Visual BASIC is '***** currently loaded. Clicking on this new button '***** will bring API Magic to the fore - even if '***** currently minimised. See file _README.TXT If Command$ = "" Then Load APIMBtn End If 'define carriage return/linefeed pair CRLF = Chr$(13) & Chr$(10) 'display logo screen APIMLOGO.Show APIMLOGO.Refresh 'indicate busy while initialising Screen.MousePointer = HOURGLASS 'load and position 13 alpha buttons (A-N) x = btnAlpha(0).Left y = btnAlpha(0).Top For i = 1 To 12 Load btnAlpha(i) x = x + btnAlpha(0).Width btnAlpha(i).Move x, y btnAlpha(i).Caption = Chr$(i + 65) btnAlpha(i).Visible = True 'load and position 13 alpha buttons (M-Z) x = btnAlpha(0).Left y = y + btnAlpha(0).Height For i = 13 To 25 Load btnAlpha(i) btnAlpha(i).Move x, y btnAlpha(i).Caption = Chr$(i + 65) x = x + btnAlpha(0).Width btnAlpha(i).Visible = True 'open the database Set DB = OpenDatabase(db_name, True, True) 'display main screen Center_Form Me Me.Show 'switch on icon animation anistate = True DoEvents 'clear logo screen Unload APIMLOGO 'load declarations OptAPIDecs = 1 End Sub Sub Form_Unload (Cancel As Integer) Dim i As Integer 'close table DTbl.Close Set DTbl = Nothing 'close the database DB.Close Set DB = Nothing 'release help file if open result = WinHelp(Me.hWnd, App.HelpFile, HELP_QUIT, 0&) 'unload VB toolbar button Unload APIMBtn 'unload alpha buttons For i = 1 To 25 Unload btnAlpha(i) 'double check logo screen no longer loaded If AboutLoaded Then Unload APIMLOGO 'tidy up AniTimer.Enabled = False Erase BMark End Sub Sub lbSelect_DblClick () Dim outstr As String 'build data for transfer to output textbox DTbl.Bookmark = BMark(lbSelect.ListIndex) Select Case user_choice Case 0 'declarations If Left(DTbl("Entry"), 1) Like "[%&]" Then outstr = "Declare Function " Else outstr = "Declare Sub " End If outstr = outstr & DTbl("Caption") & DTbl("Entry") Case 2 'structures outstr = CRLF & "Type " & DTbl("Caption") & CRLF & DTbl("Entry") & "End Type" & CRLF Case Else 'constants outstr = "Global Const " & DTbl("Caption") & DTbl("Entry") End Select 'do not transfer data if it already exists 'in the output textbox If InStr(txtOutput, outstr) Then txtSearch.SetFocus Exit Sub End If 'transfer data to output textbox 'add a cr/lf if not the first entry If txtOutput > "" Then txtOutput = txtOutput & CRLF & outstr txtOutput = outstr End If 'scroll to last entry in output box result = SendMessageByNum(txtOutput.hWnd, EM_GETLINECOUNT, 0, 0&) result = SendMessageByNum(txtOutput.hWnd, EM_LINEINDEX, result - 1, 0&) txtOutput.SelStart = result txtSearch.SetFocus End Sub Sub lbSelect_GotFocus () txtSearch.SetFocus End Sub Sub lbSelect_KeyPress (KeyAscii As Integer) 'equate pressing [Enter] key to a double click If KeyAscii = 13 Then lbSelect_DblClick End Sub Sub Logo_Click () 'toggle animation on/off with each click AniTimer.Enabled = Not AniTimer.Enabled anistate = Not anistate txtSearch.SetFocus End Sub Sub mnuHelpAbout_Click () 'display logo screen with OK button enabled APIMLOGO.btnOK.Visible = True APIMLOGO.Show 1 End Sub Sub mnuHelpContents_Click () 'display application help file contents result = WinHelp(Me.hWnd, App.HelpFile, HELP_INDEX, "") End Sub Sub Open_Table (BTable As String, Idx As String) 'close any open tables If Not (DTbl Is Nothing) Then DTbl.Close 'open database table in read only mode Set DTbl = DB.OpenTable(BTable, DB_READONLY) 'use primary index DTbl.Index = Idx End Sub Sub OptAPIConst_Click (Value As Integer) 'open table of API Constants Open_Table "Constants", "APICIdx" 'flag API constants selected user_choice = 1 'resize array to hold constants database bookmarks Erase BMark DTbl.MoveLast ReDim BMark(DTbl.RecordCount) 'process selected option Select_Option End Sub Sub OptAPIDecs_Click (Value As Integer) 'open table of API Declarations Open_Table "Declarations", "APIDIdx" 'flag declarations selected user_choice = 0 'resize array to hold declaration database bookmarks Erase BMark DTbl.MoveLast ReDim BMark(DTbl.RecordCount) 'process selected option Select_Option End Sub Sub OptAPIStruct_Click (Value As Integer) 'open table of API Structures Open_Table "Structures", "APISIdx" 'flag structures selected user_choice = 2 'resize array to hold structures database bookmarks Erase BMark DTbl.MoveLast ReDim BMark(DTbl.RecordCount) 'process selected option Select_Option End Sub Sub OptVBConst_Click (Value As Integer) 'open table of VB Constants Open_Table "VB_Const", "VBCIdx" 'flag Visual BASIC constants selected user_choice = 3 'resize array to hold VB constants database bookmarks Erase BMark DTbl.MoveLast ReDim BMark(DTbl.RecordCount) 'process selected option Select_Option End Sub Sub Reset_SelectBox () Dim selectIdx As Integer 'return select box to last selected item selectIdx = lbSelect.ListIndex lbSelect.ListIndex = -1 lbSelect.ListIndex = selectIdx txtSearch.SetFocus End Sub Sub Select_Option () 'load selectbox from database based on user selection 'suspend animation during heavy processing AniTimer.Enabled = False 'indicate busy state Busy_Flash.Visible = True Busy_Flash.Refresh Screen.MousePointer = HOURGLASS 'clear search input box and select box txtSearch = "" lbSelect.Clear 'prevent update of select box until all entries added result = SendMessageByNum(lbSelect.hWnd, WM_SETREDRAW, 0, 0&) 'load captions into select box DTbl.MoveFirst result = SendMessageByString(lbSelect.hWnd, LB_ADDSTRING, 0, DTbl("Caption")) BMark(result) = DTbl.Bookmark DTbl.MoveNext Loop While Not DTbl.EOF 'update select box contents result = SendMessageByNum(lbSelect.hWnd, WM_SETREDRAW, 1, 0&) lbSelect.ListIndex = 0 'process any pending events DoEvents 'clear busy state Busy_Flash.Visible = False Screen.MousePointer = DEFAULT 'set focus to search box txtSearch.SetFocus 'resume animation If anistate Then AniTimer.Enabled = True End Sub Sub txtOutput_Change () 'enable Export button if output box contains data 'otherwise disable the Export buton If txtOutput > "" Then btn3DExport.Enabled = True btn3DExport.Enabled = False End If End Sub Sub txtSearch_Change () 'search for a match to input text in select box result = SendMessageByString(lbSelect.hWnd, LB_FINDSTRING, -1, txtSearch) 'if match found then display it If result > -1 Then lbSelect.ListIndex = result result = SendMessageByNum(lbSelect.hWnd, LB_SETTOPINDEX, result, 0&) End If End Sub Sub txtSearch_KeyDown (KeyCode As Integer, Shift As Integer) 'transfer control to select box if up/down cursor key Select Case KeyCode Case KEY_CUR_UP If lbSelect.ListIndex > 0 Then lbSelect.ListIndex = lbSelect.ListIndex - 1 End If txtSearch.SetFocus Case KEY_CUR_DOWN If lbSelect.ListIndex < lbSelect.ListCount - 1 Then lbSelect.ListIndex = lbSelect.ListIndex + 1 End If txtSearch.SetFocus End Select End Sub Sub txtSearch_KeyPress (KeyAscii As Integer) 'equate pressing of Enter key to 'double clicking on select box If KeyAscii = 13 Then KeyAscii = 0 lbSelect_DblClick txtSearch = "" txtSearch.SetFocus End If End Sub Sub txtSearch_LostFocus () 'clear search string txtSearch = "" End Sub