home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Programming Tool Box
/
SIMS_2.iso
/
bp_6_93
/
vbwin
/
regdb
/
starter.bas
< prev
next >
Wrap
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