Programming Tool Box/SIMS_2.iso/code/grafik/show3d/nm_mod.bas

BASIC Source File | 1995-02-27 | 14.1 KB | 480 lines

Option Explicit
DefInt A-Z
Declare Function LockWindowUpdate Lib "User" (ByVal hwndLock As Integer) As Integer
Declare Function SetSysModalWindow Lib "User" (ByVal hWnd As Integer) As Integer
Declare Function GetFreeSpace Lib "Kernel" (ByVal wFlags) As Long
Declare Function GetWinFlags Lib "Kernel" () As Long
Declare Function GetVersion Lib "Kernel" () As Long
Declare Function GetSystemMetrics Lib "User" (ByVal nIndex As Integer) As Integer
Declare Function GetFreeSystemResources Lib "User" (ByVal fuSysResource As Integer) As Integer
Declare Sub SetWindowPos Lib "User" (ByVal hWnd As Integer, ByVal hWndInsertAfter As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal cx As Integer, ByVal cy As Integer, ByVal wFlags As Integer)
Declare Function GetDeviceCaps Lib "GDI" (ByVal hDC As Integer, ByVal nIndex As Integer) As Integer
Declare Function GetSystemMenu Lib "User" (ByVal hWnd As Integer, ByVal bRevert As Integer) As Integer
Declare Function RemoveMenu Lib "User" (ByVal hMenu As Integer, ByVal nPosition As Integer, ByVal wFlags As Integer) As Integer
Declare Function GetPrivateProfileString Lib "Kernel" (ByVal lpApplicationName$, ByVal lpKeyName$, ByVal lpDefault As String, ByVal lpReturnedString$, ByVal nSize As Integer, ByVal lpFileName As String) As Integer
Declare Sub WritePrivateProfileString Lib "Kernel" (ByVal lpApplicationName$, ByVal lpKeyName$, ByVal lpString$, ByVal lplFileName$)

Global Const C_AnzahlBreite = 3
Global Const C_AnzahlHoehe = 7

Const WF_STANDARD = &H10
Const WF_ENHANCED = &H20
Const WF_80x87 = &H400
Const SM_DEBUG = 22
Const GFSR_SYSTEMRESOURCES = &H0
Const MF_BYPOSITION = &H400
Const KEY_ESCAPE = &H1B


Global G_TabName$
Global Const C_Ordner = 1
Global Const C_Dokument = 2
Global Const C_Information = 3

Function F_EntferneNull$ (Text As String)
Text = Trim$(Text)
Do
    If Len(Text$) <= 1 Then Exit Do
    If Left$(Text, 1) = Chr$(0) Then
        Text = Mid$(Text, 2)
    Else
        Exit Do
    End If
Loop
Do
    If Len(Text$) <= 1 Then Exit Do
    If Right$(Text, 1) = Chr$(0) Then
        Text = Mid$(Text, 1, Len(Text) - 1)
    Else
        Exit Do
    End If
Loop

F_EntferneNull = Text
End Function

Function F_FileExist (ByVal DateiName$)
On Error Resume Next
Dim Datei$
If DateiName$ = "" Then Exit Function
Datei$ = Dir$(DateiName$)
If Trim$(Datei$) = "" Or Asc(DateiName$) = 0 Then
    F_FileExist = False
Else
    F_FileExist = True
End If

End Function

Function F_GetPrivatIni (ByVal section As String, ByVal Key As String) As String
Dim lplFileName As String
Dim retVal As String, AppName As String, worked As Integer

lplFileName$ = App.EXEName + ".INI"

    retVal = String$(255, 0)
    worked = GetPrivateProfileString(section, Key, "", retVal, Len(retVal), lplFileName$)
    If worked = 0 Then
        F_GetPrivatIni = ""
    Else
        F_GetPrivatIni = Left(retVal, worked)
    End If
End Function

Function F_Test256Color ()

Dim Tmp_AnzahlBitP As Integer
Dim Tmp_AnzahlFarben As Integer

' Anzahl Farben
Tmp_AnzahlFarben = GetDeviceCaps(Screen.ActiveForm.hDC, 104)

' Anzahl Bit pro Pixel
Tmp_AnzahlBitP = GetDeviceCaps(Screen.ActiveForm.hDC, 12)
If Tmp_AnzahlBitP = 8 And Tmp_AnzahlFarben = 256 Then
    F_Test256Color = True
Else
    F_Test256Color = False
End If

End Function

Sub FreezeOff ()
Dim Dummy As Integer
Dummy = LockWindowUpdate(0)
End Sub

Sub FreezeOn (ByVal Handle As Integer)
Dim Dummy As Integer
Dummy = LockWindowUpdate(Handle)
End Sub

Function HIBYTE (ShortInt As Integer) As Integer
    HIBYTE% = ShortInt% \ 256
End Function

Function HIWORD (LongInt As Long) As Integer
    HIWORD% = LongInt& \ 65536
End Function

Function LOBYTE (ShortInt As Integer) As Integer
    LOBYTE% = ShortInt% Mod 256
End Function

Function LOWORD (LongInt As Long) As Integer
    LOWORD% = LongInt& Mod 65536
End Function

Sub P_ChangeFont (F_Source As Form, F_Name As String)
Dim I As Integer

For I = 0 To F_Source.Controls.Count - 1
    F_Source.Controls(I).FontName = F_Name
Next I

End Sub

' Alle Schriftgr÷ssen der Controls innerhalb des Formulars F_Source
' werden auf die neue gr÷sse Fontsize angepasst
'
' F_Source -> Formular
' Fontsize -> Schriftgr÷sse
'
Sub P_ChangeFontSize (F_Source As Form, FontSize As Single)

On Error Resume Next
Dim I As Integer

For I = 0 To F_Source.Controls.Count - 1
    F_Source.Controls(I).FontSize = FontSize
Next I

End Sub

Sub P_ReadDataBase ()




End Sub

' Die Feldnamen der Tabelle TableName aus der Datenbank DataBaseName
' werden in einem Control O_Source angezeigt
'
' DataBaseName -> Name der Datenbank
' TableName -> Name der Tabelle oder Name des Queries
' O_Source -> Name des Objektes (Liste oder Combo-Box)
'
Sub P_ReadFields (ByVal DataBaseName As String, ByVal TableName As String, O_Source As Control)
On Error Resume Next
Dim DB As Database
Dim Sn As SnapShot
Dim I As Integer

Set DB = OpenDatabase(DataBaseName)
Set Sn = DB.CreateSnapshot(TableName)

O_Source.Clear
For I = 0 To Sn.Fields.Count - 1
    O_Source.AddItem Sn.Fields(I).Name
Next I

End Sub

' Alle Records des Feldes FieldName aus der Tabelle TableName
' werden in einem Control O_Source angezeigt
'
' DataBaseName -> Name der Datenbank
' TableName -> Name der Tabelle oder Name des Queries
' FieldName -> Feldname
' O_Source -> Name des Objektes (Liste oder Combo-Box)
'
Sub P_ReadFieldValue (DataBaseName As String, ByVal TableName As String, ByVal FieldName As String, O_Source As Control)

Dim DB As Database
Dim Sn As SnapShot

Dim I As Integer

Set DB = OpenDatabase(DataBaseName)
Set Sn = DB.CreateSnapshot(TableName)

O_Source.Clear
Do While Not Sn.EOF
    O_Source.AddItem Format$(Sn.Fields(FieldName))
    Sn.MoveNext
Loop

End Sub

' Alle Tabellen der Datenbank DataBaseName werden im
' Control O_Source angezeigt
'
' DataBaseName -> Name der Datenbank'
' O_Source -> Name des Objektes (Liste oder Combo-Box)
'
Sub P_ReadTables (DB As Database, O_Source As Control)

Dim TableList As SnapShot

Set TableList = DB.ListTables()

O_Source.Clear
While TableList.EOF = False
    If TableList!Attributes And &H80000002 Then
    Else
        O_Source.AddItem TableList!Name
    End If
    TableList.MoveNext
Wend

End Sub

Sub P_RemoveItemsSysMenu (F_Source As Form, Positon As Integer)

    Dim HSysMenu As Integer
    Dim Dummy As Integer
    HSysMenu = GetSystemMenu(F_Source.hWnd, 0)
    Dummy = RemoveMenu(HSysMenu, Positon, MF_BYPOSITION)

End Sub

Sub P_ResizeFormCenter (Source As Form)

Source.Left = (Screen.Width - Source.Width) / 2
Source.Top = (Screen.Height - Source.Height) / 2

End Sub

' Anpassen eines Control-Arrays O_Source2 an ein ⁿberliegendes Control O_Source1
' wobei die Ausrichtung vertikal erfolgt.
'
' F_Source -> Formular
' O_Source1 -> ⁿberliegendes Control
' O_Source2 -> Control-Array das ausgerichtet werden muss
' Anzahl -> Anzahl der Objekte(O_Source2) die angezeigt werden mⁿssen
' Abstand1 ->  Linker, rechter, oberer und unterer Abstand des auszurichtenden objektes an
' das Vaterelement
' Abstand2 -> Zwischenabstand
'
Sub P_ResizeMultiObjectToParents (F_Source As Form, O_Source1 As Control, O_Source2 As Control, Anzahl As Integer, Abstand1 As Integer, Abstand2 As Integer)
Dim I As Integer
Dim II As Integer
Dim Tmp_Hoehe As Integer
Dim Tmp_Breite As Integer
Dim Tmp_Zwischenhoehe As Integer


For I = 0 To F_Source.Controls.Count - 1
    If O_Source2 = F_Source.Controls(I) Then
        For II = I To F_Source.Controls.Count - 1
            If O_Source2 = F_Source.Controls(II) Then
                F_Source.Controls(II).Visible = False
            End If
        Next II
        Tmp_Hoehe = O_Source1.Height - (Abstand1 * 2) - ((Anzahl - 1) * Abstand2)
        Tmp_Breite = O_Source1.Width - (Abstand1 * 2)
        Tmp_Zwischenhoehe = Tmp_Hoehe / Anzahl
        For II = Anzahl - 1 To 0 Step -1
            F_Source.Controls(I + II).Top = Abstand1 + (II * Tmp_Zwischenhoehe) + (II * Abstand2)
            F_Source.Controls(I + II).Left = Abstand1
            F_Source.Controls(I + II).Width = Tmp_Breite
            F_Source.Controls(I + II).Height = Tmp_Zwischenhoehe
            F_Source.Controls(I + II).Visible = True
        Next II
        Exit For
    End If
Next I

End Sub

' Control wird an einem Formular ausgerichtet
'
' F_Source -> Formular
' O_Source -> Objekt das ausgerichtet werden muss
'
Sub P_ResizeObjectToForm (F_Source As Form, O_Source As Control, Abstand)

O_Source.Left = Abstand
O_Source.Top = Abstand
O_Source.Width = F_Source.ScaleWidth - (2 * Abstand)
O_Source.Height = F_Source.ScaleHeight - (2 * Abstand)

End Sub

' Ein Control wird an einem ⁿberliegenden Control ausgerichtet
'
' O_OutSource -> ⁿberliegendes Control
' O_InSource -> Control das ausgerichtet werden muss
' Abstand -> Abstand des auszurichtenden Controls zum Vaterobjekt
'
Sub P_ResizeObjectToObject (O_OutSource As Control, O_InSource As Control, Abstand As Integer)

O_InSource.Left = Abstand
O_InSource.Top = Abstand
O_InSource.Width = O_OutSource.Width - (2 * Abstand)
O_InSource.Height = O_OutSource.Height - (2 * Abstand)

End Sub

Sub P_SetSysModal (F_Source As Form)
 Dim Dummy As Integer
 Dummy = SetSysModalWindow(F_Source.hWnd)
End Sub

Sub P_SetWindowTop (F_Source As Form)

    ' Setze das Fenster (F_Source) auf die oberste Position
    ' muss  nach jedem Laden des Fenster neu aufgerufen werden

    SetWindowPos F_Source.hWnd, -1, 0, 0, 0, 0, &H10 Or &H40

End Sub

Sub P_SystemInfo (WVersion As String, FreeMemory As Long, FreeResources As Integer)

Dim WinFlags As Long
Dim Mode As String
Dim Version As Long
Dim lKBfree As Long
Dim KBfree As String
Dim SystemMetrics As Integer

'fill the mode label...
Mode = "Windows version "

' Get current Windows configuration
Version = GetVersion()
Mode = Mode + Format(LOBYTE(LOWORD(Version)), "#") + "." + Format(HIBYTE(LOWORD(Version)), "#") + "  -  "
WinFlags = GetWinFlags()
If WinFlags And WF_ENHANCED Then Mode = Mode + "Enhanced Mode" Else Mode = Mode + "Standard Mode"
SystemMetrics = GetSystemMetrics(SM_DEBUG)
If SystemMetrics <> 0 Then Mode = Mode + " (DEBUG)"
WVersion = Mode

FreeMemory = GetFreeSpace(0) \ 1024
FreeResources = GetFreeSystemResources(GFSR_SYSTEMRESOURCES)

End Sub

Sub P_Warte (Sekunden)

Dim Temp_Zeit As Double
Temp_Zeit = Timer
Do While Not Temp_Zeit + Sekunden < Timer
    DoEvents
Loop

End Sub

Sub P_WritePrivatInit (ByVal Sektion$, ByVal Key$, ByVal Result$)
On Error Resume Next
Dim lpApplicationName$
Dim lpKeyName$
Dim lpString$
lpApplicationName$ = Sektion$
lpKeyName$ = Key$
lpString$ = Result$

Dim Dummy As Integer
Dim lplFileName As String

lplFileName$ = App.EXEName + ".INI"
lpKeyName$ = lpKeyName$ + String$(255 - Len(lpKeyName$), 0)
lpString$ = lpString$ + String$(255 - Len(lpString$), 0)

WritePrivateProfileString lpApplicationName$, lpKeyName$, lpString$, lplFileName$

End Sub

Sub show3D (Frm As Form)

' Konstanten fⁿr die Farben
Const BLACK = &H0&
Const WHITE = &HFFFFFF
Const GRAY = &HC0C0C0
Const DGRAY = &H808080

Dim Ct As Control
Dim I As Integer
Dim Tx As Integer
Dim Ty As Integer

' Anzahl Twips innerhalb eines Pixels
Tx = Screen.TwipsPerPixelX
Ty = Screen.TwipsPerPixelY
Frm.AutoRedraw = True

' Zeichne Formular falls Border fest
Frm.BackColor = &HC0C0C0
If Frm.BorderStyle = 0 Or Frm.BorderStyle = 1 Or Frm.BorderStyle = 3 Then
    Frm.DrawWidth = 2
    Frm.Line (0, 0)-(Frm.ScaleWidth, Frm.ScaleHeight), DGRAY, B
    Frm.DrawWidth = 1
    Frm.Line (0, 0)-(Frm.ScaleWidth, Frm.ScaleHeight), WHITE, B
End If

For I = 0 To Frm.Controls.Count - 1
    Set Ct = Frm.Controls(I)

    ' Steuerelemnt <Shape>
    If TypeOf Ct Is Shape Then
        Ct.Visible = False
        Frm.DrawWidth = 2
        Frm.Line (Ct.Left, Ct.Top)-(Ct.Width + (1 * Tx) + Ct.Left, Ct.Top + Ct.Height), DGRAY, B
        Frm.DrawWidth = 1
        Frm.Line (Ct.Left - (1 * Tx), Ct.Top - (1 * Ty))-(Ct.Width + Ct.Left, Ct.Top + Ct.Height - (1 * Ty)), WHITE, B
    End If

    ' Steuerelemnt <Label>
    If TypeOf Ct Is Label Then
        Frm.FontSize = Ct.FontSize
        Frm.FontName = Ct.FontName
        Frm.FontBold = Ct.FontBold
        Ct.Visible = False
        Frm.CurrentX = Ct.Left + Tx
        Frm.CurrentY = Ct.Top + Ty
        Frm.ForeColor = WHITE
        Frm.Print Ct.Caption
        Frm.CurrentX = Ct.Left
        Frm.CurrentY = Ct.Top
        Frm.ForeColor = BLACK
        Frm.Print Ct.Caption
    End If

    ' Steuerelemnt <TextBox>
    If TypeOf Ct Is TextBox Then
        Frm.Line (Ct.Left + (1 * Tx), Ct.Top + (1 * Ty))-(Ct.Width + Ct.Left, Ct.Top + Ct.Height), WHITE, B
        Frm.Line (Ct.Left - (1 * Tx), Ct.Top - (1 * Ty))-(Ct.Width + (1 * Tx) + Ct.Left, Ct.Top + Ct.Height + (1 * Ty)), DGRAY, B
        Frm.Line (Ct.Left - (2 * Tx), Ct.Top - (2 * Ty))-(Ct.Width + Ct.Left + (1 * Tx), Ct.Top + Ct.Height + (1 * Ty)), GRAY, B
    End If

    ' Steuerelemnt <ListBox>
    If TypeOf Ct Is ListBox Then
        Frm.Line (Ct.Left + (1 * Tx), Ct.Top + (1 * Ty))-(Ct.Width + Ct.Left, Ct.Top + Ct.Height), DGRAY, B
        Frm.Line (Ct.Left - (1 * Tx), Ct.Top - (1 * Ty))-(Ct.Width + (1 * Tx) + Ct.Left, Ct.Top + Ct.Height + (1 * Ty)), WHITE, B
        Frm.Line (Ct.Left - (2 * Tx), Ct.Top - (2 * Ty))-(Ct.Width + Ct.Left + (1 * Tx), Ct.Top + Ct.Height + (1 * Ty)), GRAY, B
    End If

    ' Steuerelemnt <ComboBox>
    If TypeOf Ct Is ComboBox Then
        Frm.Line (Ct.Left + (1 * Tx), Ct.Top + (1 * Ty))-(Ct.Width + Ct.Left, Ct.Top + Ct.Height), DGRAY, B
        Frm.Line (Ct.Left - (1 * Tx), Ct.Top - (1 * Ty))-(Ct.Width + (1 * Tx) + Ct.Left, Ct.Top + Ct.Height + (1 * Ty)), WHITE, B
        Frm.Line (Ct.Left - (2 * Tx), Ct.Top - (2 * Ty))-(Ct.Width + Ct.Left + (1 * Tx), Ct.Top + Ct.Height + (1 * Ty)), GRAY, B
    End If

    ' Steuerelemnt <Line>
    If TypeOf Ct Is Line Then
        Ct.Visible = False
        Frm.Line (Ct.X1 + (1 * Tx), Ct.Y1 + (1 * Ty))-(Ct.X2 + (1 * Tx), Ct.Y2 + (1 * Ty)), DGRAY
        Frm.Line (Ct.X1, Ct.Y1)-(Ct.X2, Ct.Y2), WHITE
    End If

Next I

' Merke-Modus von Formular ausschalten
Frm.AutoRedraw = False

End Sub