Programmer 7500/MAX_PROGRAMMERS.iso/VISUAL_B/CODIGO_2/VB_PROJ/VBPROJ.BAS

BASIC Source File | 1992-10-21 | 13.4 KB | 410 lines

DefInt A-Z

'----------------------
'for vbproj.ini file.
'----------------------
Declare Function WritePrivateProfileString Lib "Kernel" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpString As Any, ByVal lplFileName As String) As Integer
Declare Function GetPrivateProfileString Lib "Kernel" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Integer, ByVal lpFileName As String) As Integer

'-----------------------------------------------
'For finding if Visual Basic is already running.
'-----------------------------------------------
Declare Function GetModuleHandle Lib "Kernel" (ByVal Program$)
Declare Function GetModuleUsage Lib "Kernel" (ByVal hModule)

'------------------------------------
'For finding Visual Basic title text
'and define proper contants.
'------------------------------------
Declare Function FindWindow Lib "User" (ByVal lpClass&, ByVal WinName&)
Declare Function GetWindow Lib "User" (ByVal hWnd, ByVal wCmd)
Declare Function GetNextWindow Lib "User" (ByVal hWnd, ByVal wCmd)
Declare Function GetWindowText Lib "User" (ByVal hWnd, ByVal WinText$, ByVal BufSize)
Const GW_HWNDFIRST = 0
Const GW_HWNDNEXT = 2

'------------------------------------
'For restoring VB if it is minimized.
'------------------------------------
Declare Function ShowWindow Lib "User" (ByVal hWnd, ByVal nCmdShow)
Const SW_RESTORE = 9

'---------------------------------
'Define Contants for messageboxes.
'---------------------------------
Const IDYES = 6
Const YESNO = 4

'----------------------------------------------------
'Path where visual Basic is installed. See ReadButton
'procedure how to read it from vbproj.ini
'----------------------------------------------------
Dim VBPath As String

Sub DoCmdLine (Index As Integer)
'----------------------------------------------------
'Check first if user have installed VB to a different
'directory after first taking this program to use.
'If directory has changed, let the user re-enter
'correct path where VB is installed.
'----------------------------------------------------

    Section$ = "VB"
    KeyName$ = "Path"
    Fname$ = "vbproj.ini"
    Match$ = Dir$(VBPath$)
    If Match$ = "" Then VBNotFound Section$, KeyName$, Fname$

'---------------------------------------------
'If button's caption UnUsed, ask if user want
'to start new project.
'---------------------------------------------

If Projects.Cmd_Project(Index).Caption = "&UnUsed" Then

    Msg$ = "Start New Project?"
    Title$ = "????"
    Answer% = MsgBox(Msg$, 32 + YESNO, Title$)
    If Answer% = IDYES Then
    Ret% = IsVBRunnig()
    If Ret% > 0 Then
        Ret% = BrowseWindows()
        SendKeys "%F" + "{ENTER}"
    Else
        X% = Shell(VBPath$, 1)
    End If
   Else
    Exit Sub
   End If
End
End If


'--------------------------------------------
'Check if desired project file is found.
'--------------------------------------------

Match$ = Dir$(Projects.Cmd_Project(Index).Tag)
If Match$ = "" Then
    Msg$ = "Project file " + Projects.Cmd_Project(Index).Tag + " not found?" + Chr$(10) + Chr$(13)
    Msg$ = Msg$ + "Check the correct path from [File|Add or Modify Buttons] menu."
    MsgBox Msg$, 16, "ERROR!"
    Exit Sub
End If


'-------------------------------------------------
'Check is VB already running. See IsVBRunning and
'BrowseWindows functions. If VB is running send
'keystrokes to open desired project, else start VB
'using Shell function with desired project.
'-------------------------------------------------

Ret% = IsVBRunnig()
If Ret% > 0 Then

    Ret% = BrowseWindows()

    '----------------------------------------------
    'Change also to directory where project file is
    'located. See Todir$ Function in this module.
    '----------------------------------------------

    WhichDir$ = ToDir$((Projects.Cmd_Project(Index).Tag))
    SendKeys "%FO" + Projects.Cmd_Project(Index).Tag + "{ENTER}", -1
    ChDir WhichDir$
    End

Else
    WhichDir$ = ToDir$((Projects.Cmd_Project(Index).Tag))
    ChDir WhichDir$
    X% = Shell(VBPath$ + " " + Projects.Cmd_Project(Index).Tag, 1)
End If

End

End Sub

Sub ReadButton (Frm As Form)

'-----------------------------------------------------------
'This procedure reads information from vbproj.ini, which
'is located in windows directory. We use API call function
'GetPrivateProfileString, which is declared in global module
'NOTE! When you use the function, you must Dim returned
'string as varible lenght string because of dll return.
'
'Dim RetStr As String * 128
'
'Unless you don't, it will hang your system.
'-----------------------------------------------------------

Dim RetStr As String * 128
Section$ = "ButtonCaption"
Def$ = "&UnUsed,C:\VB\NO.MAK"
Size% = 128
Fname$ = "vbproj.ini"

'----------------------------------------------------
'Start loop for reading properties from vbproj.ini.
'----------------------------------------------------

I = -1
Do
    I = I + 1
    KeyName$ = "Button" + Str$(I)
    Returned% = GetPrivateProfileString(Section$, KeyName$, Def$, RetStr$, Size%, Fname$)

    '----------------
    'Get the caption.
    '----------------
    Frm.Cmd_Project(I).Caption = Left$(RetStr$, (InStr(RetStr$, ",")) - 1)

    '-----------------------------------------------------
    'Get commandline assigning it to buttons Tag property.
    '-----------------------------------------------------
    Frm.Cmd_Project(I).Tag = Mid$(RetStr$, (InStr(RetStr$, ",")) + 1)

    '----------------------------
    'we have reached last button.
    '----------------------------
    If I = 11 Then Exit Do
Loop

'----------------------------------------
'next read path from where to execute VB.
'----------------------------------------

Section$ = "VB"
KeyName$ = "Path"
Def$ = "NotDefined"
Returned% = GetPrivateProfileString(Section$, KeyName$, Def$, RetStr$, Size%, Fname$)
VBPath$ = Left$(RetStr$, Returned%)

'-----------------------------------------------------
'First time, get path where Visual Basic is installed.
'-----------------------------------------------------

If VBPath$ = "NotDefined" Then VBNotFound Section$, KeyName$, Fname$


End Sub

Function IsVBRunnig ()

'-------------------------------------
'Get value if Visual Basic is already
'runnig value 0 means VB is NOT runnig
'value >0 means VB is running.
'-------------------------------------

    hModule = GetModuleHandle("VB.EXE")
    IsVBRunnig = GetModuleUsage(hModule)

End Function

Function BrowseWindows ()

'---------------------------------------------------------
'This function searches all windows for finding if Visual
'Basic is already runnig. Finding method is browse all
'windows that are currently running and get those title
'text. If Visual Basic's title text is found, we use
'AppActivate statement to activate it for sending
'keystrokes. See DoCmdLine procedure found in this module.
'NOTE!
'Dim TitleText As String * 256 is needed for dll return or
'system will hang.
'---------------------------------------------------------

    Dim TitleText As String * 256
    Wnd = FindWindow(0, 0)
    Wnd = GetWindow(Wnd, GW_HWNDFIRST)

'----------------------------------------------------------------
'Search Visual Basic's windows handle for getting it's
'title text. It is better using this method insted of
'AppActivate "Title", because if user has some sort
'of program running, which will add something else to
'active window's title text (eg. clock), straight AppActivate
'would not work. Now we only search the string containing program's
'title text to get firm result.
'Function InStr(TextToSearchFrom, TextToSearchfor) will do the job.
'If return value is not 0 (zero), then program is runnig.
'------------------------------------------------------------------

    While Wnd <> 0
    TChars = GetWindowText(Wnd, TitleText, 256)
    X% = InStr(TitleText, "Microsoft Visual Basic [design]")
    If X% <> 0 Then

        '--------------------------------------------------------
        'If VB is minimized, API function ShowWindow will restore
        'it, so there is no error message "Illegal function".
        '--------------------------------------------------------

        SW = ShowWindow(Wnd, SW_RESTORE)
        AppActivate (TitleText)
        Exit Function
    End If
    Wnd = GetNextWindow(Wnd, GW_HWNDNEXT)
    Wend
    BrowseWindows = 0
End Function

Sub WriteButton (Frm As Form)

'--------------------------------------------
'This procedure saves all button captions and
'command lines to vbproj.ini
'--------------------------------------------

Section$ = "ButtonCaption"
Fname$ = "vbproj.ini"

I = -1
Do
    I = I + 1
    KeyName$ = "Button" + Str$(I)
    'check named mark to end loop
    WriteStr$ = Frm.Cmd_Project(I).Caption + "," + Frm.Cmd_Project(I).Tag
    WriteThings% = WritePrivateProfileString(Section$, KeyName$, WriteStr$, Fname$)
    If I = 11 Then Exit Do
Loop
End Sub

Sub VBNotFound (Section$, KeyName$, Fname$)

'-------------------------------------------------------
'This procedure is called whenever path for Visual Basic
'has changed or for the first time that user use this
'program.
'-------------------------------------------------------


WRONGPATH:
    Prompt$ = "Path for Visual Basic is not defined or it has changed."
    Prompt$ = Prompt$ + " Please enter full path where VB is installed."
    GetPath$ = InputBox$(Prompt$, "Defining path for Visual Basic", "C:\VB")

    '-----------------------------------------------
    'Check the path is correct. If it is wrong, give
    'user a chance to re-enter it.
    '-----------------------------------------------

    Match$ = Dir$(GetPath$ + "\" + "vb.exe")
    If Match$ = "" Then
    Answer% = MsgBox("Could not find VB.EXE. Check the path again?", 16 + YESNO, "ERROR!")
    If Answer% = IDYES Then
        GoTo WRONGPATH
    Else
        End
    End If
    End If

    '--------------------------------------------------------
    'If entered path is correct assing it to VBPath$
    'and write the path to vbproj.ini (to windows directory).
    '--------------------------------------------------------

    VBPath$ = GetPath$ + "\" + Match$
    WriteThings% = WritePrivateProfileString(Section$, KeyName$, UCase$(VBPath$), Fname$)
    WriteButton Projects
End Sub

Sub TreeD (Frm As Form, Ctrl As Control, Style As String)

'---------------------------------------------------
'This procedure draw 4 lines around a control
'to give 3 - dimensional look. You can give to
'control either raised or downed effect. Style
'variable determine if control is raised or downed.
'
'Style$ = "up" for raised effect and
'Style$ = "down" fo downed effect.
'etc. TreeD FormName, ControlName, "up" would give
'to control a raised look. Call this sub from Form's
'paint procedure.
'----------------------------------------------------

    '------------------------------------------------------
    'Check style and give proper colors representing style.
    '8 = Grey
    '15 = Bright White
    '------------------------------------------------------

    Style$ = LCase$(Style$)
    If Style$ = "down" Then
    Col1 = 8
    Col2 = 15
    ElseIf Style$ = "up" Then
    Col1 = 15
    Col2 = 8
    Else
    Msg$ = "TreeD Sub not properly defined." + Chr$(10) + Chr$(13)
    Msg$ = Msg$ + "You should use:" + Chr$(10) + Chr$(13)
    Msg$ = Msg$ + "TreeD FormName, ControlName, Style$" + Chr$(10) + Chr$(13)
    Msg$ = Msg$ + "Where Style$ is up or down"
    MsgBox Msg$, 64, "Designing time ERROR!"
    End
    End If

    '--------------------------
    'Get control's coordinates.
    '--------------------------

    CtrlLeft% = Ctrl.Left - 15
    CtrlTop% = Ctrl.Top - 15
    CtrlWide% = Ctrl.Width + 15
    CtrlHigh% = Ctrl.Height + 15

    '---------------------------------------------
    'Draw 4 lines around control, left & top
    'with same color and right & bottom with same.
    '---------------------------------------------

    Frm.Line (CtrlLeft%, CtrlTop%)-Step(CtrlWide%, 0), QBColor(Col1)
    Frm.Line -Step(0, CtrlHigh%), QBColor(Col2)
    Frm.Line -Step(-CtrlWide%, 0), QBColor(Col2)
    Frm.Line -Step(0, -CtrlHigh%), QBColor(Col1)
End Sub

Function ToDir (Directory As String) As String

'----------------------------------------------
'This function retrieves Button's Tag property
'(command line). First it converts it reverse
'to get project's directory which to change to.
'----------------------------------------------

StrLen% = Len(Directory$)           'Tag's lenght
For J% = StrLen% To 1 Step -1       ' Loop to start from right
    Temp$ = Mid$(Directory$, J%, 1)  'side 1 charcacter at a time
    RevStr$ = RevStr$ + Temp$        'store charcacter to temp$ variable.
Next

'--------------------------------------
'Now we have path without project file.
'--------------------------------------

RevStr$ = Mid$(RevStr$, InStr(RevStr$, "\") + 1)

'----------------------------------
'convert it back to original state.
'----------------------------------

StrLen% = Len(RevStr$)
For J% = StrLen% To 1 Step -1
    Temp$ = Mid$(RevStr$, J%, 1)
    RevStr1$ = RevStr1$ + Temp$
Next

'-----------------------------------------------
'give value to function to change the directory.
'-----------------------------------------------

ToDir = RevStr1$

End Function