Monster Media 1994 #1/monster.zip/monster/PROG_BAS/VBWRAP.ZIP/VBMAGIC.BAS

BASIC Source File | 1994-02-04 | 17KB | 569 lines

' Visual Basic Magic Wrappers
' Copyright (c) 1992, 1993, 1994
' Big Dog Software
' 25 Shirley Parkway
' Piscataway, N.J. 08854-4444
' ALL RIGHTS RESERVED

Option Explicit
DefInt A-Z
Const nuls$ = ""
Const zero = 0
Const one = 1
Const two = 2
Global winver% ' e.g. 300, 310...
Declare Sub cascadechildw300 Lib "User" Alias "CascadeChildWindows" (ByVal parentwin%)
Declare Sub cascadechildw310 Lib "User" Alias "CascadeChildWindows" (ByVal parentwin%, ByVal style%)
Declare Sub tilechildw300 Lib "User" Alias "TileChildWindows" (ByVal parentwin%)
Declare Sub tilechildw310 Lib "User" Alias "TileChildWindows" (ByVal parentwin%, ByVal style%)
Declare Function GetActiveWindow% Lib "User" ()
Declare Function setactivewindow% Lib "User" (ByVal hWnd%)
Declare Function APIsetfocus% Lib "User" Alias "SETFOCUS" (ByVal hWnd%)
Declare Function APIgetversion% Lib "Kernel" Alias "GETVERSION" ()
Declare Function BringWindowToTop Lib "User" (ByVal hWnd%) As Integer
Declare Function SendMessage Lib "User" (ByVal hWnd, ByVal wMsg, ByVal wParam, ByVal lParam As Any)
Declare Function GetPrivateProfileInt Lib "Kernel" (ByVal lpAppName$, ByVal lpKeyname$, ByVal nDefault%, ByVal file$) As Integer
Declare Function GetPrivateProfileString Lib "Kernel" (ByVal lpAppName$, ByVal lpKeyname$, ByVal lpDefault$, ByVal lpReturn$, ByVal nSize%, ByVal file$) As Integer
Declare Function WritePrivateProfileString Lib "Kernel" (ByVal lpAppName$, ByVal lpKeyname$, ByVal lpString$, ByVal file$) As Integer
Declare Function ShowWindow Lib "User" (ByVal hWnd%, ByVal nCmdShow%) As Integer
Declare Function FindWindow Lib "User" (ByVal class&, ByVal caption&) As Integer
Declare Function Findwindowbyclass Lib "User" Alias "FINDWINDOW" (ByVal class$, ByVal caption$) As Integer
Declare Function GetWindow Lib "User" (ByVal hWnd%, ByVal wCmd%) As Integer
Declare Function GetNextWindow Lib "User" (ByVal hWnd%, ByVal wCmd%) As Integer
Declare Function GetWindowText Lib "User" (ByVal hWnd%, ByVal Buf$, ByVal lBuf%) As Integer
Declare Function getwindowlong Lib "User" (ByVal hWnd%, ByVal nIndex%) As Long
Declare Function setwindowlong Lib "User" (ByVal hWnd%, ByVal nIndex%, ByVal dwNewLong&) As Long
Declare Function APIGetWinDir Lib "KERNEL" Alias "GETWINDOWSDIRECTORY" (ByVal buvver$, ByVal buflen%) As Integer
Declare Function APIGetSysDir Lib "KERNEL" Alias "GETSYSTEMDIRECTORY" (ByVal buvver$, ByVal buflen%) As Integer
Declare Function winexec% Lib "KERNEL" (ByVal cmdstr$, ByVal mode%)
Declare Function GetSysColor Lib "USER" (ByVal key%) As Long
Declare Function SetWindowWord% Lib "USER" (ByVal myhwnd%, ByVal cmd%, ByVal poppa%)

Const SWW_HPARENT = -8
Const GW_HWNDfirst = 0
Const GW_HWNDNEXT = 2
Const WM_USER = &H400

' edit box messages
Const ES_PASSWORD = &H20
Const EM_LIMITTEXT = WM_USER + 21
Const EM_SETPASSWORDCHAR = WM_USER + 28
Const EM_SETREADONLY = WM_USER + 31
Const EM_LINEFROMCHAR = WM_USER + 25
Const EM_LINEINDEX = WM_USER + 11
Const EM_LINELENGTH = WM_USER + 17
Const EM_GETLINECOUNT = WM_USER + 10
Const em_getline = WM_USER + 20

Global Const GWL_STYLE = -16
Global Const LB_SETTABSTOPS = &H400 + 19

' list box messages
Const CB_LIMITTEXT = WM_USER + 1
Const CB_ADDSTRING = WM_USER + 3
Const CB_INSERTSTRING = WM_USER + 10
Const CB_RESETCONTENT = WM_USER + 11
Const CB_SHOWDROPDOWN = WM_USER + 15
Const CB_GETITEMDATA = WM_USER + 16
Const CB_SETITEMDATA = WM_USER + 17
Const CB_FINDSTRING = WM_USER + 12
Const CB_FINDSTRINGEXACT = WM_USER + 24
Const CB_SELECTSTRING = WM_USER + 13
Const LB_ADDSTRING = WM_USER + 1
Const LB_RESETCONTENT = WM_USER + 5
Const LB_SETITEMDATA = WM_USER + 27
Const LB_GETITEMDATA = WM_USER + 26
Const LB_FINDSTRINGEXACT = WM_USER + 35
Const LB_FINDSTRING = WM_USER + 16
Const LB_INSERTSTRING = WM_USER + 2
Const LB_SELECTSTRING = WM_USER + 13

Global white3d As Long
Global black3d As Long
Dim line3d As Integer
Dim init3d As Integer
Dim appname As String

Function addlistitem (ctl As Control, Text$, index%, dataval&)
On Error Resume Next
ctl.AddItem Text, index
ctl.ItemData(index) = dataval
addlistitem = index
End Function

Function addslistitem (ctl As Control, Text As String, dvalue As Long) As Integer
On Error Resume Next
ctl.AddItem Text
ctl.ItemData(ctl.NewIndex) = dvalue
addslistitem = ctl.NewIndex
End Function

Sub boxtrack (tb As TextBox, lb As Control)
Dim stringsrch$, index%
stringsrch = Trim$(tb.Text)
If Len(stringsrch) Then
    index = findstring(lb, zero, stringsrch)
Else
    index = -1
End If
If index < lb.ListCount Then
    lb.ListIndex = index
End If
End Sub

Sub cascadechildren (Parent%, style%)
Dim i%
i = getversion()
Select Case winver
    Case 300
        cascadechildw300 Parent
    Case 310
        cascadechildw310 Parent, style
End Select
End Sub

Sub center (fname As Form)
fname.Move (screen.Width - fname.Width) / two, (screen.Height - fname.Height) / two
End Sub

Sub clearlistbox (alistbox As Control)
' VB1.0
Dim flag As Integer, i%
If TypeOf alistbox Is ListBox Then flag = True
If flag Then
    i = sendmessagetocontrol(alistbox, LB_RESETCONTENT, zero, zero)
ElseIf TypeOf alistbox Is ComboBox Then
    i = sendmessagetocontrol(alistbox, CB_RESETCONTENT, zero, zero)
Else
    MsgBox "Improper use of ClearListBox", 48, "BUG!!"
End If
End Sub

Function crypt$ (action$, key$, src$)
'trivial perturbed encription algorithm
Dim count%, keypos%, keylen%, srcasc%, dest$, srcpos%, xtest$
keylen = Len(key)
If UCase$(action) = "E" Then
    For srcpos = one To Len(src)
        srcasc = Asc(Mid$(src, srcpos, one))
        If keypos < keylen Then keypos = keypos + one Else keypos = one
        xtest = Hex$(srcasc Xor Asc(Mid$(key, keypos, one)))
        dest = dest + Format$(xtest, "@@")
    Next srcpos
ElseIf UCase$(action) = "D" Then
    For srcpos = one To Len(src) Step two
        srcasc = Val("&H" + Trim$(Mid$(src, srcpos, two)))
        If keypos < keylen Then keypos = keypos + one Else keypos = one
        dest = dest & Chr$(srcasc Xor Asc(Mid$(key, keypos, one)))
    Next srcpos
End If
crypt = dest
End Function

Function em_getlinetext$ (eb As Control, lineno%)
Dim linelen%, firstchar%, buffer$, ret%
firstchar = sendmessagetocontrol(eb, EM_LINEINDEX, lineno, zero)
If firstchar < zero Then
    em_getlinetext = nuls
    MsgBox "Programmer attempted to select text for line" + Str$(lineno) + ".  This line does not exist.", 48, "BUG ALERT"
    Exit Function
End If
linelen = sendmessagetocontrol(eb, EM_LINELENGTH, firstchar, zero)
If linelen < zero Then
    em_getlinetext = nuls
    MsgBox "Unable to determine line length", 48, "BUG ALERT"
    Exit Function
End If
If linelen > zero Then
    buffer = Space(linelen + one)
    ret = sendstringtocontrol(eb, em_getline, lineno, buffer)
    em_getlinetext = Left$(buffer, linelen)
Else
    em_getlinetext = nuls
End If
End Function

Function em_getnumlines& (eb As Control)
em_getnumlines = sendmessagetocontrol(eb, EM_GETLINECOUNT, zero, zero)
End Function

Function findstring% (ctl As Control, start%, Text As String)
If TypeOf ctl Is ListBox Then
    findstring = sendstringtocontrol(ctl, LB_FINDSTRING, start, Text)
ElseIf TypeOf ctl Is ComboBox Then
    findstring = sendstringtocontrol(ctl, CB_FINDSTRING, start, Text)
Else
    MsgBox "findstring may only be used with listbox, combobox or multilist."
    findstring = -1
End If
End Function

Function findstringexact% (ctl As Control, Text As String)
If TypeOf ctl Is ListBox Then
    findstringexact = sendstringtocontrol(ctl, LB_FINDSTRINGEXACT, zero, Text)
ElseIf TypeOf ctl Is ComboBox Then
    findstringexact = sendstringtocontrol(ctl, CB_FINDSTRINGEXACT, zero, Text)
Else
    MsgBox "findstringexact may only be used with listbox, combobox or multilist."
    findstringexact = -1
End If
End Function

Function getblack3d& ()
getblack3d = black3d
End Function

Function getlistdata% (alistbox As Control, index%)
Dim flag As Integer, rogue&, i%
If TypeOf alistbox Is ListBox Then flag = True
If flag Then
    i = sendmessagetocontrol(alistbox, LB_GETITEMDATA, index, 0&)
ElseIf TypeOf alistbox Is ComboBox Then
    i = sendmessagetocontrol(alistbox, CB_GETITEMDATA, index, 0&)
Else
    MsgBox "Improper use of getlistdata", 48, "BUG!!"
    i% = -1
End If
getlistdata = i
End Function

Function getprofileint (sect$, entry$, def%) As Integer
If Trim$(appname) = nuls Then
Beep
MsgBox "Application name not specified in getprofileint", 48, "ERROR"
getprofileint = zero
Exit Function
End If
getprofileint = GetPrivateProfileInt(sect, entry, def, appname)
End Function

Function getprofilename$ ()
getprofilename = appname
End Function

Function getprofilestring (section$, entry$, default$, buffer$, size%) As Integer
Dim a$, i%
'
' prepare the string with nulls, and make sure it is big enough
'
If Trim$(appname) = nuls Then
Beep
MsgBox "Application name not specified in getprofilestring", 48, "ERROR"
getprofilestring = zero
Exit Function
End If
a = String$(size + two, zero)
i = GetPrivateProfileString(section, entry, default, a, size + one, appname)
a = Left$(a, i)
i = InStr(a, Chr$(zero))
If i Then
    If i = one Then
        a = nuls
    Else
        a = Left$(a, i - one)
    End If
End If
a = Trim$(a)
i = Len(a)
If i > size Then i = size

buffer = Left$(a, i)
getprofilestring = i
End Function

Function GetSystemDirectory$ ()
Dim workspace As String, i%, j%
workspace = "  "
i = APIGetSysDir(workspace, one)
If i > zero Then
    workspace = String$(i + one, Chr$(zero))
    j = APIGetSysDir(workspace, i)
    If j > zero Then
        GetSystemDirectory = Left$(workspace, j)
        Exit Function
    End If
End If
GetSystemDirectory = "ERROR"
End Function

Function getversion% ()
Dim intver%
intver = APIgetversion()
winver = (intver And &HFF) * 100 + (intver And &HFF00) / 256
getversion = winver
End Function

Function getwhite3d& ()
getwhite3d = white3d
End Function

Function getwindowsdirectory$ ()
Dim workspace As String, i%, j%
workspace = "  "
i = APIGetWinDir(workspace, one)
If i > zero Then
    workspace = String$(i% + one, Chr$(zero))
    j = APIGetWinDir(workspace, i)
    If j > zero Then
        getwindowsdirectory = Left$(workspace, j)
        Exit Function
    End If
End If
getwindowsdirectory = "ERROR"
End Function

Sub notelaunch (filename$)
Dim s$, i%, j%, l%, w$, sep$, comstr$, temps$
Const SW_SHOW = 5
Const SW_RESTORE = 4
s = Trim$(filename)
i = InStr(s, Chr$(zero))
If i Then s = Left$(s, i - one)
i = InStr(s, " ")
If i Then s = Left$(s, i - one)
i = InStr(s, Chr$(9))
If i Then s = Left$(s, i - one)
i = InStr(s, ".")
If i Then s = Left$(s, i - one)
l = Len(s)
If l = zero Then
    s = "TEMP.TXT"
Else
    s = s + ".TXT"
End If
i = InStr(s, "\")
If i = zero Then
    w = getwindowsdirectory()
    i = Len(w)
    sep = Right$(w$, one)
    If sep <> "\" Then w$ = w$ + "\"
Else
    w = nuls
End If
w = w + s
comstr = "NOTEPAD.EXE " + w
temps = "Notepad - " + s
i = Findwindowbyclass("Notepad", temps)
If i Then
    j = ShowWindow(i, SW_RESTORE)
    j = BringWindowToTop(i)
Else
    i = winexec(comstr, SW_SHOW)
    If i < 32 Then
        MsgBox "Unable to activate the notepad.", 48, "WARNING"
    End If
End If
End Sub

Sub relatemeto (baby As Form, poppa As Form)
Dim ret%
ret = SetWindowWord(baby.hWnd, SWW_HPARENT, poppa.hWnd)
End Sub

Function SearchWindow% (search$)
Dim capt As String, wnd%, length%, source$
Dim dest As String
    dest = UCase$(search)
    wnd = FindWindow(zero, zero)
    wnd = GetWindow(wnd, GW_HWNDfirst)
    While wnd
        capt = String$(256, zero)
        length = GetWindowText(wnd, capt, 255)
        If length > zero Then
            source = UCase$(Left$(capt, length))
            If InStr(source, dest) Then
                capt = nuls
                source = nuls
                dest = nuls
                SearchWindow = wnd
                Exit Function
            End If
        End If
        capt = nuls
        wnd = GetNextWindow(wnd, GW_HWNDNEXT)
    Wend
    source = nuls
    dest = nuls
    SearchWindow = zero
End Function

Function selectstring% (ctl As Control, start%, Text As String)
If TypeOf ctl Is ListBox Then
    selectstring = sendstringtocontrol(ctl, LB_SELECTSTRING, zero, Text)
ElseIf TypeOf ctl Is ComboBox Then
    selectstring = sendstringtocontrol(ctl, CB_SELECTSTRING, zero, Text)
Else
    MsgBox "findstring may only be used with listbox, combobox or multilist."
    selectstring = -1
End If

End Function

Function sendmessagetocontrol% (ctl As Control, wMsg, wParam, lParam&)
sendmessagetocontrol = SendMessage(ctl.hWnd, wMsg, wParam, lParam)
End Function

Function sendstringtocontrol (ctl As Control, wMsg%, wParam%, lParam$)
sendstringtocontrol = SendMessage(ctl.hWnd, wMsg, wParam, lParam)
End Function

Sub set_3d (white&, black&, boldness%)
init3d = one
If getversion() = 300 Then
    black = &H808080
    white = &HE0E0E0
Else
If black = zero Then black = GetSysColor(16)
If white = zero Then white = GetSysColor(20)
End If
white3d = white
black3d = black
line3d = boldness
End Sub

Sub setappname (appstring As String)
Dim errno As Integer, s As String
s = Trim$(appstring)
If s = nuls Then errno = one
If InStr(s, Chr$(9)) Then errno = one
If InStr(s, " ") Then errno = one
If errno Then
    appname = nuls
Else
    appname = s
End If
End Sub

Function setemreadonly (ctl As Control, bool As Integer)
Dim i%
i = sendmessagetocontrol(ctl, EM_SETREADONLY, bool, 0&)
setemreadonly = i
End Function

Sub setlbtabs (lb As Control, tablist%())
Dim styleword&, ret%, cnt%, jnk&, i%, tabstr$
tabstr = nuls
styleword = getwindowlong(lb.hWnd, GWL_STYLE)
If Not styleword And &H80& Then
    styleword = styleword + &H80&
    jnk = setwindowlong(lb.hWnd, GWL_STYLE, styleword)
End If
For i = LBound(tablist) To UBound(tablist)
    If tablist(i) > zero Then
        cnt = cnt + one
        tabstr = tabstr + Chr$(tablist(i) And 255) + Chr$(Int(tablist(i) / 256))
    Else
        i = UBound(tablist) + one
    End If
Next i
If cnt = zero Then Exit Sub
ret = sendstringtocontrol(lb, &H400 + 19, cnt, tabstr)

End Sub

Function setlistdata% (alistbox As Control, index%, value&)
Dim dataval&
dataval = value

If TypeOf alistbox Is ListBox Then
    setlistdata = sendmessagetocontrol(alistbox, LB_SETITEMDATA, index, dataval)
ElseIf TypeOf alistbox Is ComboBox Then
    setlistdata = sendmessagetocontrol(alistbox, CB_SETITEMDATA, index, dataval)
Else
    MsgBox "Improper use of setlistdata", 48, "BUG!!"
    setlistdata = -1
End If
End Function

Function setpasswordstyle (ctl As Control, parm%) As Integer
Dim Styleflags As Long
Dim hWind As Integer
If TypeOf ctl Is TextBox Then
    hWind = ctl.hWnd
    Styleflags = getwindowlong(hWind, GWL_STYLE)
    Styleflags = Styleflags Or ES_PASSWORD
    Styleflags = setwindowlong(hWind, GWL_STYLE, Styleflags)
    Styleflags = SendMessage(hWind, EM_SETPASSWORDCHAR, parm, 0&)
Else
    MsgBox "SetPassWordStyle: wrong control type passed.", 48, "DEBUG"
End If
End Function

Function settextlength (ctl As Control, size%) As Integer
Dim i%
If TypeOf ctl Is TextBox Then
    i = sendmessagetocontrol(ctl, EM_LIMITTEXT, size, 0&)
ElseIf TypeOf ctl Is ComboBox Then
    i = sendmessagetocontrol(ctl, CB_LIMITTEXT, size, 0&)
Else
    MsgBox "Settextlength: wrong control type", 48
    i = -1
End If
settextlength = i
End Function

Sub three_dee (box As Control, style As Integer)
Dim smode As Integer
If init3d = zero Then
set_3d zero, zero, 4
End If

smode = box.Parent.ScaleMode
box.Parent.ScaleMode = 3
Dim white&, black&, t%, h%, w%, l%, i%
If style = zero Then ' recessed
    white = black3d
    black = white3d
Else
    white = white3d
    black = black3d
End If
For i = one To line3d
    t = box.Top - i
    l = box.Left - i
    h = box.Height + two * i
    w = box.Width + two * i
    box.Parent.Line (l, t)-Step(zero, h), white
    box.Parent.Line (l, t)-Step(w, zero), white
    box.Parent.Line (l + w, t)-Step(zero, h), black
    box.Parent.Line (l, t + h)-Step(w, zero), black
Next i
box.Parent.Line (box.Left - line3d, box.Top - line3d)-(box.Left, box.Top), box.Parent.BackColor
box.Parent.ScaleMode = smode
End Sub

Sub tilechildren (Parent%, style%)
Dim i%
i = getversion()
Select Case winver
    Case 300
        tilechildw300 Parent
    Case 310
        tilechildw310 Parent, style
End Select
End Sub

Sub undrop (ctl As Control)
Dim i%
i = sendmessagetocontrol(ctl, CB_SHOWDROPDOWN, zero, 0&)
End Sub

Function wndcaption$ (hWnd)
Dim ss As String, length
    ss = String$(256, zero)
    length = GetWindowText(hWnd, ss, 255)
    If length > -1 Then wndcaption = Left$(ss, length)
    ss = nuls
End Function

Function writeprofilestring (section As String, entry As String, value As String) As Integer
If Trim$(appname) = nuls Then
Beep
MsgBox "Application name not specified in writeprofilestring", 48, "ERROR"
writeprofilestring = zero
Exit Function
End If
writeprofilestring = WritePrivateProfileString(section, entry, value, appname)
End Function