' VBSUBS.BAS
'
' Utility subroutines for Visual BASIC
' All subroutines are documented in comments at the start of the routine.
'
'
' Capital Equipment Corp., 1992
'

' Declare Windows routines
Declare Function CreateBitmap Lib "gdi" (ByVal W As Integer, ByVal H As Integer, ByVal np As Integer, ByVal nbits As Integer, bits As Any) As Integer
Declare Sub DeleteObject Lib "gdi" (ByVal handle As Integer)
Declare Function OpenClipboard Lib "user" (ByVal hwnd As Integer) As Integer
Declare Sub CloseClipboard Lib "user" ()
Declare Sub SetClipboardData Lib "user" (ByVal fmt As Integer, ByVal H As Integer)
Declare Function GetDeviceCaps Lib "gdi" (ByVal hdc As Integer, ByVal ninfo As Integer) As Integer
Const LOGPIXELSX = 88
Const LOGPIXELSY = 90
Declare Sub StretchBlt Lib "gdi" (ByVal hDest%, ByVal X%, ByVal Y%, ByVal W%, ByVal H%, ByVal hSrc%, ByVal Xsrc%, ByVal Ysrc%, ByVal srcW%, ByVal srcH%, ByVal Op As Long)
Const COPYPEN = &HCC0020
Declare Function CreateCompatibleDC Lib "gdi" (ByVal hdc As Integer) As Integer
Declare Sub DeleteDC Lib "gdi" (ByVal hdc As Integer)
Declare Function SelectObject Lib "gdi" (ByVal hdc As Integer, ByVal hObj As Integer) As Integer

' Declare internal Visual BASIC routines
Declare Sub VBGetControlName Lib "vbrun100.dll" (hctl As Control, ByVal N As String)
Declare Sub VBGetAppTitle Lib "vbrun100.dll" (ByVal Title As String, ByVal Maxlen As Integer)

'-----------------------------------------------------------------
' CopyBitmapToClipboard  (bits(),nrows,ncols)
'       Copies an integer array containing bitmap data to the windows clipboard.
'       Note: DOES NOT CLEAR THE CLIPBOARD FIRST!
'-----------------------------------------------------------------
Sub CopyBitmapToClipboard (bits() As Integer, ByVal Nrows As Integer, ByVal Ncols As Integer)
    handle% = CreateBitmap(Ncols, Nrows, 1, 1, bits(0))
    If OpenClipboard(0) <> 0 Then
        SetClipboardData 2, handle%
        CloseClipboard
    End If
End Sub

Sub CopyVector (Vector() As Single, ByVal Nvalues As Integer)
'-----------------------------------------------------------------
' CopyVector (vector(),nvalues)
'       Copy a 1-D array of numbers to the clipboard. (index starts at 0)
'       Creates multiple data formats for pasting into other applications.
'       Note: DOES NOT CLEAR THE CLIPBOARD FIRST!
'-----------------------------------------------------------------
    ' Create "Text" format data, one value per line
    t$ = ""
    For i% = 0 To Nvalues - 1
        t$ = t$ + Format$(Vector(i%)) + Chr$(13) + Chr$(10)
    Next i%
    Clipboard.SetText t$
End Sub

Sub CopyTwoVectors (VectorX() As Single, VectorY() As Single, ByVal Nvalues As Integer)
'-----------------------------------------------------------------
' CopyTwoVectors (vectorX(),vectorY(),nvalues)
'       Copy two 1-D arrays of numbers to the clipboard, in two columns.
'       Creates multiple data formats for pasting into other applications.
'       Note: DOES NOT CLEAR THE CLIPBOARD FIRST!
'-----------------------------------------------------------------
    ' Create "Text" format data, one pair of values per line
    t$ = ""
    For i% = 0 To Nvalues - 1
        t$ = t$ + Format$(VectorX(i%)) + Chr$(9) + Format$(VectorY(i%)) + Chr$(13) + Chr$(10)
    Next i%
    Clipboard.SetText t$
End Sub

Sub CopyArray (Array() As Single, ByVal Nrows As Integer, ByVal Ncols As Integer)
'-----------------------------------------------------------------
' CopyArray (array(),nrows,ncols)
'       Copy a 2-D array of numbers to the clipboard.
'       Creates multiple data formats for pasting into other applications.
'       Note: DOES NOT CLEAR THE CLIPBOARD FIRST!
'-----------------------------------------------------------------
    ' Create "Text" format data, tabs between columns
    t$ = ""
    For i% = 0 To Nrows - 1
        For j% = 0 To Ncols - 1
            If j% <> 0 Then t$ = t$ + Chr$(9)   ' tab
            t$ = t$ + Format$(Array(i%, j%))
        Next j%
        t$ = t$ + Chr$(13) + Chr$(10)   ' add CR/LF (end of line)
    Next i%
    Clipboard.SetText t$
End Sub

Sub CopyBitmapToPicture (bits() As Integer, ByVal Nrows As Integer, ByVal Ncols As Integer, Pic As Control, ByVal DoScale As Integer)
'-----------------------------------------------------------------
' CopyBitmapToPicture  (bits(),nrows,ncols,ctrl,scale)
'       Copies an integer array containing bitmap data to a picture control.
'          ctrl as control      (must be picturebox)
'          scale as integer     (if TRUE(-1), scale to fit current picture
'                               size)
'       NOTE: REPLACES CLIPBOARD CONTENTS AS A SIDE EFFECT
'-----------------------------------------------------------------
    If TypeOf Pic Is PictureBox Then
    Else
        Exit Sub
    End If
    handle% = CreateBitmap(Ncols, Nrows, 1, 1, bits(0))
    If DoScale Then
        ' need to create another bitmap and use StretchBlt to scale it
        handle1% = handle%
        ' Make device contexts for the two bitmaps
        hdc% = CreateCompatibleDC(0)
        hdc1% = CreateCompatibleDC(0)
        ' calculate picture size in pixel units
        lx = GetDeviceCaps(hdc%, LOGPIXELSX)
        ly = GetDeviceCaps(hdc%, LOGPIXELSY)
        destw% = Pic.Width / 1440# * lx
        desth% = Pic.Height / 1440# * ly
        handle% = CreateBitmap(destw%, desth%, 1, 1, ByVal 0&)
        ' Select bitmaps into the contexts
        i% = SelectObject(hdc1%, handle1%)
        j% = SelectObject(hdc%, handle%)
        ' copy the data
        StretchBlt hdc%, 0, 0, destw%, desth%, hdc1%, 0, 0, Ncols, Nrows, COPYPEN
        ' Delete temporary stuff
        DeleteDC hdc%
        DeleteDC hdc1%
        DeleteObject handle1%
    End If
    ' Use clipboard to copy the bitmap to the picture control
    Clipboard.Clear
    If OpenClipboard(0) <> 0 Then
        SetClipboardData 2, handle%
        CloseClipboard
    End If
    Pic.Picture = Clipboard.GetData(2)
End Sub

Sub SetRemote (Link As Control, ByVal AppTopic As String, ByVal Item As String, ByVal Value As String)
'-----------------------------------------------------------------
' SetRemote Link, AppTopic, Item, Value
'       Sets the value of an item in another program through DDE.
'         Link must be a textbox control in this program (can be invisible).
'               (note: Link will have its value modified)
'         AppTopic should be of the form "Appname|Topicname"
'         Item is the remote item name (control name for VB apps).
'   Note: re-establishes the remote link each time the routine is called.
'         If the link is to be re-used, it may be faster to use the VB
'         statements directly.
'-----------------------------------------------------------------
    On Error Resume Next
    Link.LinkMode = 0       ' no link
    Link.LinkTopic = AppTopic
    Link.LinkItem = Item
    Link.Text = Value
    Link.LinkMode = 2       ' cold link -  open connection now
    Link.LinkPoke           ' copy value to remote app
    Link.LinkMode = 0       ' close link
End Sub

Function GetRemote (Link As Control, ByVal AppTopic As String, ByVal Item As String) As String
'-----------------------------------------------------------------
' GetRemote (Link, AppTopic, Item)
'       Gets the value of an item in another program through DDE.
'         Link must be a textbox control in this program (can be invisible).
'               (note: Link will have its value modified)
'         AppTopic should be of the form "Appname|Topicname"
'         Item is the remote item name
'-----------------------------------------------------------------
    On Error Resume Next
    Link.LinkMode = 0       ' no link
    Link.LinkTopic = AppTopic
    Link.LinkItem = Item
    Link.LinkMode = 2       ' cold link -  open connection now
    Link.LinkRequest        ' copy value to remote app
    Link.LinkMode = 0       ' close link
    GetRemote = Link.Text   ' return value
End Function