Programming Tool Box/SIMS_2.iso/bp_6_93/vbwin/regdb/starter.bas

BASIC Source File | 1993-01-05 | 12KB | 352 lines

Option Explicit
'
'
' **************************************************************
' * Copyright 1993 Markus Kreisel und Renate Reinartz - k.r.s. *
' * fⁿr Basic Professionell 6/93                               *
' **************************************************************
'
'
Global Const MB_RETRYCANCEL = 5
Global Const MB_ICONSTOP = 16
Global Const IDCANCEL = 2
Global Const IDRETRY = 4
'
Declare Function GetProfileString% Lib "Kernel" (ByVal lpAppName$, ByVal lpKeyName$, ByVal lpDefault$, ByVal lpReturnedString$, ByVal nSize%)
Declare Function RegQueryValue& Lib "shell.dll" (ByVal hkey&, ByVal subkey$, ByVal buf$, buflen&)
Declare Function FindExecutable% Lib "shell.dll" (ByVal file$, ByVal dr$, ByVal result$)
Declare Function GetModuleHandle% Lib "Kernel" (ByVal lpModuleName$)

' Fⁿgt einen Backslash an einen String an, wenn dessen letztes Zeichen
' kein Backslash ist. Einige Funktionen liefern z.B.
' "a:\" oder "a:\test" zurⁿck. Wⁿrde man ungeprⁿft einen
' Backslash anhΣngen, dann erhielte man "a:\\" und somit
' ein Programm, das Dateien in der Root eines Dateibaums
' nicht korrekt bearbeiten k÷nnte.
Function addbslash$ (ByVal t$)
    If Len(t) Then
        If Right$(t, 1) <> "\" Then
            addbslash = t & "\"
        Else
            addbslash = t
        End If
    Else
        addbslash = ""
    End If
End Function

' Prⁿft, ob eine Anwendung fⁿr eine DDE-Kommunikation
' angemeldet wurde.
Function canextdde% (ByVal fext$)
    Dim dde$, class$
    On Error Resume Next
    class = queryregbase("." & fext)
    If Len(class) Then
        dde = queryregbase(class & "\shell\open\ddeexec")
        If Len(dde) Then
            canextdde = True
        Else
            canextdde = False
        End If
    Else
        canextdde = False
    End If
End Function

Function Exec% (c As Control, ByVal fullname$)
    Dim fpath$, fname$, fbody$, fext$, res%
    On Error Resume Next

    ' ▄bergabe in ihre Bestandteile zerlegen.
    splitpathname fullname, fpath, fname
    splitfilename fname, fbody, fext

    ' Ist die Datei eventuell ein ausfⁿhrbares Programm? Die entsprechenden
    ' Dateiendungen stehen in der WIN.INI.
    If isfileoftype(fext, readwininistring("windows", "programs", "")) Then
        Exec = execprograms(fullname)
    Else
        ' Unterstⁿtzt die Anwendung, die zu fext geh÷rt, DDE?
        If canextdde(fext) Then
            ' mit DDE Kontakt zur Anwendung aufnehmen
            Exec = execdocwithdde(c, fullname, fpath, fext)
        Else
            ' Dokument als Parameter ⁿbergeben
            Exec = execdocwithprogram(fullname, fpath)
        End If
    End If
End Function

' Steuert den Kontakt mit einer Anwendung via DDE, um ein
' Dokument in diese Anwendung einzulesen.
Function execdocwithdde% (c As Control, ByVal fullname$, ByVal fpath$, ByVal fext$)
    Dim topic$, application$, ddeexec$, ifexec$, cmd$, class$
    Dim fpath1$, fname$, fbody$, fext1$
    On Error Resume Next
    ' Die Klasse kann mit Hilfe der Dateierweitung gefunden werden.
    ' Sie wird fⁿr alle folgenden Aufrufe ben÷tigt.
    class = queryregbase("." & fext)
    If Len(class) Then
        ' Lese n÷tige Parameter aus der Registrationsdatenbank.
        cmd = queryregbase(class & "\shell\open\command")
        ddeexec = queryregbase(class & "\shell\open\ddeexec")
        ifexec = queryregbase(class & "\shell\open\ddeexec\ifexec")
        If Len(ifexec) = 0 Then
            ' Die Angabe von ifexec ist optional. Wird Sie unterlassen, dann
            ' mu▀ ddeexec benutzt werden.
            ifexec = ddeexec
        End If
        topic = queryregbase(class & "\shell\open\ddeexec\topic")
        If Len(topic) = 0 Then
            ' Wenn kein Topic angegeben wird, dann wird System als
            ' Topic vorausgesetzt.
            topic = "System"
        End If
        application = queryregbase(class & "\shell\open\ddeexec\application")
        If Len(application) = 0 Then
            ' Auch der Name der Applikation mu▀ nicht in der
            ' Registrationsdatenbank stehen. Leider etwas mehr
            ' Arbeit fⁿr den Entwickler, da fⁿr application
            ' der Stammteil des Programmnamens benutzt wird.
            splitpathname cmd, fpath1, fname
            splitfilename fname, fbody, fext1
            application = fbody
        End If
        ' Ist das Programm vielleicht schon aktiv?
        If GetModuleHandle(cmd) = 0 Then
            ' Nein, dann starten
            If execprograms(cmd) = True Then
                ' in das ifexec-Kommando mu▀ nun noch der Dokumentname
                ' einkopiert werden. Die passende Stelle ist mit
                ' %1 gekennzeichnet. replacestringpart ⁿbernimmt
                ' die Zeichenfriemelei.
                ' Zur Erinnerung: ifexec kann gleich ddeexec sein,
                ' wenn die Anwendung hier keinen Unterschied macht.
                ifexec = replaceStringpart(ifexec, "%1", fullname)
                ' Endlich: Das DDE-Kommando in loaddocwithdde wird
                ' aufgerufen.
                execdocwithdde = loaddocwithdde(c, application, topic, ifexec)
            Else
                execdocwithdde = False
            End If
        Else
            ' Das Programm ist aktiv und mu▀ nicht gestartet werden.
            ' Ansonsten der gleiche Ablauf wie zuvor, jedoch mit
            ' ddeexec.
            ddeexec = replaceStringpart(ddeexec, "%1", fullname)
            execdocwithdde = loaddocwithdde(c, application, topic, ddeexec)
        End If
    Else
        execdocwithdde = False
    End If
End Function

Function execdocwithprogram% (ByVal fullname$, ByVal fpath$)
    Dim res%, buffer$
    On Error Resume Next
    buffer = Space$(144)
    ' Sucht das passende Programm zur Anwendung.
    res = FindExecutable(fullname, CurDir$, buffer)
    If (res >= 32) Or (res < 0) Then
        ' Laufwerk und Pfad als aktuell setzen.
        ChDrive fpath
        ChDir fpath
        Err = 0
        ' Programm mit commandline-Parameter starten.
        res = Shell(vbstr(buffer) & " " & fullname, 1)
        If Err = 0 Then
            execdocwithprogram = True
        Else
            execdocwithprogram = False
        End If
    Else
        execdocwithprogram = False
    End If
End Function

' Startet ein Programm
Function execprograms% (ByVal fullname$)
    Dim res%
    On Error Resume Next
    Err = 0
    res = Shell(fullname, 1)
    If Err Then
        execprograms = False
    Else
        execprograms = True
    End If
End Function

' Prⁿft, ob eine Dateierweiterung in einer Auswahl von M÷glichkeiten vorkommt.
' Die Erweiterungen in extensions mⁿssen durch Leerzeichen voneinander
' getrennt sein. Beispiel: "exe com pif bat". Gro▀-/Kleinschreibung wird
' ignoriert.
Function isfileoftype% (ByVal checkextension$, ByVal extensions$)
    On Error Resume Next
    If Len(checkextension) Then
        If InStr(" " & UCase$(extensions) & " ", " " & UCase$(checkextension) & " ") Then
            isfileoftype = True
        Else
            isfileoftype = False
        End If
    Else
        isfileoftype = False
    End If
End Function

' Schickt einen DDE-Befehl an eine Anwendung. Hier speziell zum Laden
' von Dokumenten.
Function loaddocwithdde% (c As Control, ByVal application$, ByVal topic$, ByVal cmd$)
    On Error Resume Next
    c.LinkMode = 0
    c.LinkTimeout = -1
    c.LinkTopic = application & "|" & topic
    c.LinkMode = 2
    c.LinkExecute cmd
    c.LinkMode = 0
    If Err = 0 Then
        loaddocwithdde = True
    Else
        loaddocwithdde = False
    End If
End Function

' Benutzt den Datentyp Variant.
Function min (ByVal a, ByVal b)
    If a > b Then min = b Else min = a
End Function

' Liest einen String aus der Registrationsdatenbank. Um die Verwaltung
' einfach zu halten, beginnt die Suche immer in der ROOT der
' Datenbank.
Function queryregbase$ (ByVal entry$)
    Dim buf$, buflen&
    On Error Resume Next
    buf = Space$(80)
    buflen = Len(buf)
    ' 1 = von ROOT aus lesen
    ' buflen wird von der Funktion geΣndert, deshalb wΣre
    ' RegQueryValue(1, entry, buf, len(buf)) falsch.
    If RegQueryValue(1, entry, buf, buflen) = 0 Then
        If buflen > 1 Then
            ' Die Rⁿckgabe in buflen zΣhlt chr$(0) am Ende mit
            ' Also ein Zeichen abziehen, aber natⁿrlich nur dann,
            ' wenn chr$(0) nicht das einzige Zeichen in der Rⁿckgabe ist.
            queryregbase = Left$(buf, buflen - 1)
        Else
            queryregbase = ""
        End If
    Else
        queryregbase = ""
    End If
End Function

' Liest einen String aus der WIN.INI
Function readwininistring$ (ByVal section$, ByVal entry$, ByVal default$)
    Dim buffer$, l%
    On Error Resume Next
    buffer = Space$(144)
    l = GetProfileString(section, entry, default, buffer, Len(buffer))
    readwininistring = Left$(buffer, l)
End Function

' Einfache Suchen- und Ersetzenfunktion fⁿr Stringteile.
' Wenn src mehrfach gefunden wird, dann wird es auch mehrfach durch
' rpl ersetzt. Gro▀-/Kleinschreibung wird ignoriert, so da▀
' sich die Funktion speziell fⁿr Pfadoperationen und Σhnliches anbietet.
Function replaceStringpart$ (ByVal source$, ByVal src$, ByVal rpl$)
    Dim pos&
    On Error Resume Next
    src = UCase$(src)
    pos = InStr(UCase$(source), src)
    If src <> UCase$(rpl) Then
        Do While pos
            source = Left$(source, pos - 1) & rpl & Right$(source, Len(source) - pos - Len(src) + 1)
            pos = InStr(pos + Len(rpl), UCase$(source), src)
        Loop
    End If
    replaceStringpart = source
End Function

' Zerlegt einen Dateinamen ohne Pfad in den Stammteil des Namens
' und die Dateierweiterung.
' Fⁿr kompletten Dateinamen ggf. zuerst splitpathname aufrufen
Sub splitfilename (ByVal fname$, fbody$, fext$)
    Dim p%
    On Error Resume Next
    p = InStr(fname, ".")
    If p Then
        fbody = Left$(fname, p - 1)
        fext = Mid$(fname, p + 1, Len(fname) - p)
    Else
        fbody = fname
        fext = ""
    End If
End Sub

' Zerlegt einen kompletten Dateiname in Pfad und Dateiname ohne Pfad
Sub splitpathname (ByVal fullname$, fpath$, fname$)
    Dim i%, p%
    On Error Resume Next
    Do
        p = i
        i = InStr(i + 1, fullname, "\")
    Loop While i
    If p Then
        fpath = Left$(fullname, p)
    End If
    fname = Right$(fullname, Len(fullname) - p)
End Sub

' Zeichnet 3-D Effekt um alle Controls einer Form, die sichtbar
' sind und in ihrem Tag eine 3 haben. Die Form selbst wird ebenfalls
' mit einem 3-D Effekt verziert.
' Diese Routine ist nicht in Basic Professionell abgedruckt.
'
Sub threed (f As Form)
    Dim i%, c%, m%, l%, t%, w%, h%
    On Error Resume Next
    m = f.ScaleMode
    f.ScaleMode = 3
    f.DrawWidth = 1
    c = f.Controls.Count - 1
    For i = 0 To c
        If f.Controls(i).Tag = "3" And f.Controls(i).Visible Then
            l = f.Controls(i).Left - 1
            t = f.Controls(i).Top - 1
            w = f.Controls(i).Width + 1
            h = f.Controls(i).Height + 1
            f.Line (l, t)-Step(w, 0), &H808080
            f.Line (l, t)-Step(0, h), &H808080
            f.Line (l + w, t)-Step(0, h), &HFFFFFF
            f.Line (l, t + h)-Step(w, 0), &HFFFFFF
        End If
    Next i
    l = 1
    t = 1
    f.DrawWidth = 2
    w = f.ScaleWidth - 2
    h = f.ScaleHeight - 2
    f.Line (l, t)-Step(w, 0), &HFFFFFF
    f.Line (l, t)-Step(0, h), &HFFFFFF
    f.Line (l + w, t)-Step(0, h), &H808080
    f.Line (l, t + h)-Step(w, 0), &H808080
    f.ScaleMode = m
End Sub

' Funktion zum Wandeln von ASCIIZ-Strings in VB-Strings.
' Entfernt auch fⁿhrende und folgende Leerzeichen.
Function vbstr$ (ByVal c$)
    Dim pos&
    pos = InStr(c, Chr$(0))
    Select Case pos
    Case Is > 1
        vbstr = Trim$(Left$(c, pos - 1))
    Case 1
        vbstr = ""
    Case 0
        vbstr = Trim$(c)
    End Select
End Function