PC Answers 1995 May/PC Answers CD-ROM 7 (Future Publishing) (May 1995).iso/vbits/code/zuck/vbaust1.frm

Visual Basic Form | 1994-10-06 | 9.5 KB | 299 lines

VERSION 2.00
Begin Form CmdTextLines
   Caption         =   "Accessing the Windows API"
   ClientHeight    =   4020
   ClientLeft      =   1755
   ClientTop       =   2295
   ClientWidth     =   7365
   Height          =   4710
   Left            =   1695
   LinkTopic       =   "Form1"
   ScaleHeight     =   4020
   ScaleWidth      =   7365
   Top             =   1665
   Width           =   7485
   Begin PictureBox MenuPicture
      Height          =   495
      Left            =   3780
      Picture         =   VBAUST1.FRX:0000
      ScaleHeight     =   465
      ScaleWidth      =   465
      TabIndex        =   15
      Top             =   3360
      Width           =   495
   End
   Begin CommandButton Command1
      Caption         =   "Menu"
      Height          =   375
      Left            =   1740
      TabIndex        =   14
      Top             =   1020
      Width           =   1275
   End
   Begin CommandButton CmdBitBlt
      Caption         =   "BitBlt"
      Height          =   375
      Left            =   1740
      TabIndex        =   13
      Top             =   600
      Width           =   1275
   End
   Begin CommandButton CmdTextLines
      Caption         =   "TextLines"
      Height          =   375
      Left            =   1740
      TabIndex        =   12
      Top             =   180
      Width           =   1275
   End
   Begin TextBox Text1
      Height          =   1335
      Left            =   4320
      MultiLine       =   -1  'True
      TabIndex        =   11
      Text            =   "This text box contains multiple lines.  The Windows API provides a mechanism for manipulating a text box on a line oriented basis."
      Top             =   2520
      Width           =   2355
   End
   Begin CommandButton CmdGetProfile
      Caption         =   "GetProfile"
      Height          =   375
      Left            =   180
      TabIndex        =   10
      Top             =   3540
      Width           =   1335
   End
   Begin CommandButton CmdModuleUsage
      Caption         =   "ModuleUsage"
      Height          =   375
      Left            =   180
      TabIndex        =   9
      Top             =   3120
      Width           =   1335
   End
   Begin CommandButton CmdDrawText
      Caption         =   "DrawText"
      Height          =   375
      Left            =   180
      TabIndex        =   8
      Top             =   2700
      Width           =   1335
   End
   Begin CommandButton CmdNumColors
      Caption         =   "NumColors"
      Height          =   375
      Left            =   180
      TabIndex        =   7
      Top             =   2280
      Width           =   1335
   End
   Begin Timer Timer1
      Interval        =   200
      Left            =   6780
      Top             =   2460
   End
   Begin CommandButton CmdMinProgman
      Caption         =   "MinProgMan"
      Height          =   375
      Left            =   180
      TabIndex        =   5
      Top             =   1860
      Width           =   1335
   End
   Begin CommandButton CmdSetText
      Caption         =   "SetText"
      Height          =   375
      Left            =   180
      TabIndex        =   4
      Top             =   1440
      Width           =   1335
   End
   Begin CommandButton CmdBrushDraw
      Caption         =   "BrushDraw"
      Height          =   375
      Left            =   180
      TabIndex        =   3
      Top             =   1020
      Width           =   1335
   End
   Begin CommandButton CmdRectDraw
      Caption         =   "RectDraw"
      Height          =   375
      Left            =   180
      TabIndex        =   2
      Top             =   600
      Width           =   1335
   End
   Begin PictureBox Picture1
      Height          =   1815
      Left            =   4320
      ScaleHeight     =   1785
      ScaleWidth      =   2865
      TabIndex        =   1
      Top             =   240
      Width           =   2895
   End
   Begin CommandButton CmdHwndRect
      Caption         =   "HwndRect"
      Height          =   375
      Left            =   180
      TabIndex        =   0
      Top             =   180
      Width           =   1335
   End
   Begin Label labelkeys
      BorderStyle     =   1  'Fixed Single
      Height          =   255
      Left            =   4320
      TabIndex        =   6
      Top             =   2100
      Width           =   2895
   End
   Begin Menu Mnu_Top
      Caption         =   "Menu"
      Begin Menu mnu_entry
         Caption         =   "Entry #1"
         Index           =   0
      End
      Begin Menu mnu_entry
         Caption         =   "Entry #2"
         Index           =   1
      End
   End
' ------------------------------------------------------------------------
'     VBits1.FRM -- Demonstration of Windows API Access
'                       Copyright (C) 1993 Desaware
'  You have a royalty-free right to use, modify, reproduce and distribute
'  this file (and/or any modified version) in any way you find useful,
'  provided that you agree that Desaware has no
'  warranty, obligation or liability for its contents.
' ------------------------------------------------------------------------
Option Explicit
Sub CmdBitBlt_Click ()
    Dim rc As RECT
    Dim di%
    GetClientRect picture1.hWnd, rc
    ' Copy left half of picture to right half
    di% = BitBlt(picture1.hDC, rc.right / 2, 0, rc.right / 2, rc.bottom, picture1.hDC, 0, 0, SRCCOPY)
End Sub
Sub CmdBrushDraw_Click ()
    Dim hbrush%, oldbrush%, di%
    ' Create the red brush
    hbrush% = CreateSolidBrush%(&HFF&)
    ' Select if for use.
    oldbrush% = SelectObject%(picture1.hDC, hbrush%)
    ' Draw with it
    di% = Rectangle(picture1.hDC, 10, 10, 75, 75)
    ' Select it out of the hDC before deleting it.
    hbrush% = SelectObject%(picture1.hDC, oldbrush%)
    di% = DeleteObject%(hbrush%)
End Sub
Sub CmdDrawText_Click ()
    Dim rc As RECT
    Dim outp$
    Dim di%
    ' Get coordinates of the picture control
    GetClientRect picture1.hWnd, rc
    ' Shrink it a bit
    InflateRect rc, -5, -5
    outp$ = "This is a demonstration of word wrapping. "
    outp$ = outp$ + "And this is the second line that "
    outp$ = outp$ + "demonstrates word wrapping."
    di% = DrawText(picture1.hDC, outp$, Len(outp$), rc, DT_WORDBREAK)
End Sub
Sub CmdGetProfile_Click ()
    Dim prof As String * 64
    Dim di%
    di% = GetProfileString("Windows", "Device", "", prof, 63)
    MsgBox prof, 0, "Default Printer is"
End Sub
Sub CmdHwndRect_Click ()
    Dim rc As RECT
    Dim comma$
    GetWindowRect hWnd, rc
    comma$ = " , "
    MsgBox rc.left & comma$ & rc.top & comma$ & rc.right & comma$ & rc.bottom, 0, "Window Rectangle in Screen Coordinates"
End Sub
Sub CmdMinProgman_Click ()
    Dim proghWnd%
    proghWnd% = FindWindowByString(0, "Program Manager")
    If proghWnd% <> 0 Then  ' Minimize it if it exists
        CloseWindow proghWnd%
    End If

End Sub
Sub CmdModuleUsage_Click ()
    Dim hinst%, usage%
    Dim usewnd%
    usewnd% = FindWindowByString(0, "Print Manager")
    If (usewnd%) Then
        hinst% = GetWindowWord%(usewnd, GWW_HINSTANCE)
        ' usage% = GetModuleUsage%(hins%)  ' Parameter error!
        ' usage% = GetModuleUsage%(usage%)  ' Parameter error!
        usage% = GetModuleUsage%(hinst%)
        MsgBox Str$(usage%), 0, "Module Usage"
    Else
        MsgBox "Window Not Found"
    End If
End Sub
Sub CmdNumColors_Click ()
    Dim numplanes%, numbitspixel%
    Dim numcolors&
    numplanes% = GetDeviceCaps%(hDC, PLANES)
    numbitspixel% = GetDeviceCaps%(hDC, BITSPIXEL)
    ' Left shift operation
    numcolors& = 2 ^ (numplanes% * numbitspixel%)
    MsgBox Str$(numcolors&), 0, "Total Colors"
End Sub
Sub CmdRectDraw_Click ()
    Dim di%
    di% = Rectangle(picture1.hDC, 5, 5, 50, 50)
End Sub
Sub CmdSetText_Click ()
    Static tog%
    If tog% Then
        Caption = "Accessing the Windows API"
        tog% = False
    Else
        SetWindowText hWnd, "This is a new caption"
        ' The Windows API function also effects the Caption Property
        MsgBox Caption, 0, "Caption property is now"
        tog% = True
    End If
End Sub
Sub CmdTextLines_Click ()
    Dim lines%
    lines% = SendMessageBynum(text1.hWnd, EM_GETLINECOUNT, 0, 0)
    MsgBox Str$(lines%), 0, "Lines in Text1"
End Sub
Sub Command1_Click ()
    Dim menucmd%, submenu%, itemid%
    Dim di%
    ' Get handle to popup menu
    submenu% = GetSubMenu(GetMenu(hWnd), 0)
    ' Get command ID of second entry
    itemid% = GetMenuItemId%(submenu%, 1)
    di% = ModifyMenu(submenu%, 1, MF_BYPOSITION Or MF_BITMAP, itemid%, CLng(MenuPicture.Picture))
End Sub
Sub mnu_entry_Click (Index As Integer)
    MsgBox "Menu entry # " & Index & " pressed."
End Sub
Sub Picture1_DblClick ()
    picture1.Cls
End Sub
Sub Timer1_Timer ()
    Dim numlockstate%
    Dim caplockstate%
    Dim scrollstate%
    Dim res$
    ' Get the state of the keys
    numlockstate% = GetKeyState%(VK_NUMLOCK)
    caplockstate% = GetKeyState%(VK_CAPITAL)
    scrollstate% = GetKeyState%(VK_SCROLL)
    ' And build a display string
    If numlockstate% And &H1 Then res$ = "NUM "
    If caplockstate% And &H1 Then res$ = res$ + "CAP "
    If scrollstate% And &H1 Then res$ = res$ + "SCROLL"
    labelkeys.Caption = res$
End Sub