Programming Tool Box/SIMS_2.iso/bp_1_94/vbwin/regdb2/starter.bas

BASIC Source File | 1993-11-14 | 14KB | 398 lines

Option Explicit
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$, ByVal tp$)
    Dim dde$, class$
    On Error Resume Next
    class = QueryRegbase("." & fext)
    If Len(class) Then
        dde = QueryRegbase(class & "\shell\" & tp & "\ddeexec")
        If Len(dde) Then
            canextdde = True
        Else
            canextdde = False
        End If
    Else
        canextdde = False
    End If
End Function

Function CountChar% (ByVal t, ByVal z%)
    Dim g&, zeichen$, n&
    On Error Resume Next
    zeichen = Chr$(z)
    Do
        g = InStr(g + 1, t, zeichen)
        n = n + 1
    Loop While g
    CountChar = n - 1
End Function

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

    If t = 0 Then tp = "open" Else tp = "print"

    fn = GetAvailPart(fullname, 32, 1)
    para = Right$(fullname, Len(fullname) - Len(fn) - 1)

    ' ▄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, para)
    Else
        ' Unterstⁿtzt die Anwendung, die zu fext geh÷rt, DDE?
        If canextdde(fext, tp) Then
            ' mit DDE Kontakt zur Anwendung aufnehmen
            Exec = execdocwithdde(c, fullname, fpath, fext, tp)
        Else
            ' Dokument als Parameter ⁿbergeben
            Exec = execdocwithprogram(fullname, fpath, fext, tp)
        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$, ByVal tp$)
    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\" & tp & "\command")
        ddeexec = QueryRegbase(class & "\shell\" & tp & "\ddeexec")
        ifexec = QueryRegbase(class & "\shell\" & tp & "\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\" & tp & "\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\" & tp & "\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, tp) = 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$, ByVal fext$, ByVal tp$)
    Dim res%, buffer$, class$
    On Error Resume Next
    buffer = Space$(144)
    class = QueryRegbase("." & fext)
    If Len(class) Then
        buffer = QueryRegbase(class & "\shell\" & tp & "\command")
        If Len(buffer) Then
            res = Shell(ReplaceStringPart(buffer, "%1", fullname), 1)
            If Err = 0 Then
                execdocwithprogram = True
            Else
                execdocwithprogram = False
            End If
            Exit Function
        End If
    End If
    ' 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$, ByVal p$)
    Dim res%
    On Error Resume Next
    Err = 0
    If Len(p) Then fullname = fullname & " " & p
    res = Shell(fullname, 1)
    If Err Then
        execprograms = False
    Else
        execprograms = True
    End If
End Function

Function GetAvailPart (t, ByVal z%, ByVal nr%)
    Dim Zaehler%
    On Error Resume Next
    Zaehler = CountChar(t, z) + 1
    If Zaehler >= nr Then GetAvailPart = GetStringPartX(t, Chr$(z), nr)
End Function

Function GetStringPartX (ByVal t, ByVal z$, ByVal nr%)
    Dim i&, p&
    On Error Resume Next
    If Len(t) Then
        t = t & z
        nr = nr - 1
        For i = 1 To nr
            p = InStr(p + 1, t, z)
        Next i
        GetStringPartX = Mid$(t, p + 1, InStr(p + 1, t, z) - p - 1)
    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

' Verbessert gegenⁿber Version 1
' Funktioniert jetzt besser mit Large Fonts und
' Controls, die keine TAG-Eigenschaft besitzen
'
Sub threed (f As Form)
    Dim i%, c%, m%, l!, t!, w!, h!
    On Error Resume Next
    If f.WindowState = 1 Then Exit Sub
    m = f.ScaleMode
    f.ScaleMode = 3
    f.DrawWidth = 1
    c = f.Controls.Count - 1
    For i = 0 To c
        Err = 0
        If f.Controls(i).Tag = "3" And f.Controls(i).Visible Then
            If Err = 0 Then
                l = f.Controls(i).Left - 1
                t = f.Controls(i).Top - 1
                w = f.Controls(i).Width + 1.5
                h = f.Controls(i).Height + 1.5
                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
        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