Programming Tool Box/SIMS_2.iso/bp_1_94/vbwin/regdb2/qview.frm

Text File | 1993-11-14 | 10KB | 298 lines

VERSION 2.00
Begin Form Form1
   BackColor       =   &H00FFFFFF&
   Caption         =   "krsQuickView"
   ClientHeight    =   2310
   ClientLeft      =   1965
   ClientTop       =   2160
   ClientWidth     =   4260
   Height          =   2715
   Left            =   1905
   LinkMode        =   1  'Source
   LinkTopic       =   "system"
   ScaleHeight     =   2310
   ScaleWidth      =   4260
   Top             =   1815
   Width           =   4380
   Begin Image Image1
      Height          =   2055
      Left            =   0
      Stretch         =   -1  'True
      Tag             =   "3"
      Top             =   0
      Width           =   3945
   End
End
Option Explicit
'
'
' **************************************************************
' * Copyright 1993 Markus Kreisel und Renate Reinartz - k.r.s. *
' * fⁿr Basic Professionell 1/94                               *
' **************************************************************
'
' Bedienungsanleitung: Nicht aus dem Interpreter aus ausfⁿhren, sondern zuerst
' Make EXE File benutzen und aus dem Dateimanager aus starten.
' Danach mit Starter.exe aus Kursteil 1 oder Dateimanager Dateien mit den Endungen
' BMP WMF DIB RLE oder ICO ausfⁿhren. Voila!
'
Dim void
Declare Function RegQueryValue& Lib "shell.dll" (ByVal hkey&, ByVal subkey$, ByVal buf$, buflen&)
Declare Function RegSetValue& Lib "shell.dll" (ByVal hkey&, ByVal k1$, ByVal l&, ByVal k2$, ByVal r&)
Declare Function RegEnumKey& Lib "shell.dll" (ByVal hkey&, ByVal p1&, ByVal k1$, ByVal l&)

' 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

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 fileexists% (ByVal Dateiname$)
    On Error Resume Next
    void = FileLen(Dateiname)
    If Err = 0 Then fileexists = True
End Function

Function FindExec$ (ByVal s$)
    Dim i%, buffer$, fpath$, fname$
    s = LCase$(s)
    Do
        buffer = Space$(144)
        If RegEnumKey(1, i, buffer, Len(buffer)) = 0 Then
            buffer = vbstr(LCase$(getStringPart(queryregbase(vbstr(buffer) & "\shell\open\command"), 32, 1)))
            If Len(buffer) Then
                splitpathname buffer, fpath, fname
                If fname = s Then
                    FindExec = buffer
                    Exit Function
                End If
            End If
        Else
            Exit Do
        End If
        i = i + 1
    Loop
End Function

' Zerlegt cmdstr in zwei Teile und prⁿft, ob der erste Teil 'open' lautet.
' LΣdt mit dem zweiten Teil ein Bild, wenn die endung bmp ico wmf dib oder rle ist
Sub Form_LinkExecute (cmdstr As String, cancel As Integer)
    Dim befehl$, parameter$, fname$, fstamm$, fpath$, fext$
    On Error Resume Next
    befehl = LCase$(Trim$(getStringPart(cmdstr, 32, 1)))
    parameter = Right$(cmdstr, Len(cmdstr) - Len(befehl) - 1)
    If befehl = "open" Then
        If fileexists(parameter) = True Then
            splitpathname parameter, fpath, fname
            splitfilename fname, fstamm, fext
            If isfileoftype(fext, "bmp ico wmf dib rle") Then
                image1.Picture = LoadPicture(parameter)
                Me.ZOrder 0
                If Err = 0 Then
                    cancel = False
                Else
                    cancel = True
                End If
            Else
                cancel = True
            End If
        Else
            cancel = True
        End If
    Else
        cancel = True
    End If
End Sub

Sub Form_Load ()
    On Error Resume Next
    ' Nachsehen, ob QVIEW schon angemeldet ist
    If queryregbase(".dib") <> "krsQuickViewPicture" Then
        If MsgBox("'" & app.Title & "' ist noch nicht in der Registrationsdatenbank angemeldet. Wollen Sie das nachholen?", 292) = 6 Then
            ' anmelden
            void = RegBaseWrite(".DIB", "krsQuickViewPicture")
            void = RegBaseWrite(".BMP", "krsQuickViewPicture")
            void = RegBaseWrite(".WMF", "krsQuickViewPicture")
            void = RegBaseWrite(".RLE", "krsQuickViewPicture")
            void = RegBaseWrite(".ICO", "krsQuickViewPicture")
            void = RegBaseWrite("krsQuickViewPicture", "krsQuickView Bild")
            void = RegBaseWrite("krsQuickViewPicture\shell\open\command", addbslash(app.Path) & "qview.exe")
            void = RegBaseWrite("krsQuickViewPicture\shell\open\ddeexec", "open %1")
            void = RegBaseWrite("krsQuickViewPicture\shell\open\ddeexec\IfExec", "open %1")
            void = RegBaseWrite("krsQuickViewPicture\shell\open\ddeexec\application", "qview")
            void = RegBaseWrite("krsQuickViewPicture\shell\open\ddeexec\topic", "system")
            MsgBox "Ok, Sie k÷nnen '" & app.Title & "' jetzt vom krsStarter aus Basic Professionell 6/93 oder dem Dateimanager aus benutzen."
            Unload Me
        Else
            MsgBox "Sorry, dann kann '" & app.Title & "' nicht laufen."
            Unload Me
        End If
    End If
End Sub

Sub Form_Paint ()
    'Me.Cls
    'threed Me
End Sub

Sub Form_Resize ()
    On Error Resume Next
    If windowstate = 1 Then Exit Sub
    image1.Move 0, 0, ScaleWidth, ScaleHeight
    'image1.Width = ScaleWidth - 2 * image1.Left
    'image1.Height = ScaleHeight - 2 * image1.Top
End Sub

Function getStringPart$ (ByVal t$, ByVal z%, ByVal nr%)
    Dim zeichen$, Zaehler&, i%, temp$
    On Error Resume Next
    Zaehler = min(CountChar(t, z) + 1, nr)
    zeichen = Chr$(z)
    i = 1
    temp = t & zeichen
    Do While i < Zaehler
        temp = Right$(temp, Len(temp) - InStr(temp, zeichen))
        i = i + 1
    Loop
    getStringPart = Left$(temp, InStr(temp, zeichen) - 1)
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

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

Function RegBaseWrite% (ByVal entry$, ByVal value$)
    ' erstes 1& = ROOT
    ' zweites 1& = reserviert
    RegBaseWrite = RegSetValue(1&, entry, 1&, value, Len(value))
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

' 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