GFCurve/GFCurvectl.ctl

VERSION 5.00
Begin VB.UserControl GFCurvectl 
   ClientHeight    =   3450
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   6165
   ScaleHeight     =   3450
   ScaleWidth      =   6165
   Begin VB.Frame CFrame 
      BorderStyle     =   0  'Kein
      Height          =   495
      Left            =   60
      TabIndex        =   10
      Top             =   2880
      Width           =   6015
      Begin VB.OptionButton CInfoOption 
         Height          =   495
         Left            =   3480
         Picture         =   "GFCurvectl.ctx":0000
         Style           =   1  'Grafisch
         TabIndex        =   8
         Top             =   0
         Value           =   ‑1  'True
         Width           =   555
      End
      Begin VB.CommandButton CSaveCommand 
         Height          =   375
         Left            =   360
         MaskColor       =   &H00FF00FF&
         Picture         =   "GFCurvectl.ctx":0152
         Style           =   1  'Grafisch
         TabIndex        =   2
         Top             =   60
         UseMaskColor    =   ‑1  'True
         Width           =   375
      End
      Begin VB.CommandButton CLoadCommand 
         Height          =   375
         Left            =   0
         MaskColor       =   &H00FF00FF&
         Picture         =   "GFCurvectl.ctx":0694
         Style           =   1  'Grafisch
         TabIndex        =   1
         Top             =   60
         UseMaskColor    =   ‑1  'True
         Width           =   375
      End
      Begin VB.CheckBox CLogCheck 
         Caption         =   "log"
         Height          =   255
         Left            =   840
         TabIndex        =   3
         Top             =   120
         Value           =   1  'Aktiviert
         Width           =   555
      End
      Begin VB.CommandButton CZoomOutCommand 
         Caption         =   "‑"
         Height          =   375
         Left            =   1860
         TabIndex        =   5
         Top             =   60
         Width           =   375
      End
      Begin VB.CommandButton CZoomInCommand 
         Caption         =   "+"
         Height          =   375
         Left            =   1500
         TabIndex        =   4
         Top             =   60
         Width           =   375
      End
      Begin VB.OptionButton CZoomOption 
         Height          =   495
         Left            =   2940
         Picture         =   "GFCurvectl.ctx":0BD6
         Style           =   1  'Grafisch
         TabIndex        =   7
         Top             =   0
         Width           =   555
      End
      Begin VB.OptionButton CMoveOption 
         Height          =   495
         Left            =   2400
         Picture         =   "GFCurvectl.ctx":0D28
         Style           =   1  'Grafisch
         TabIndex        =   6
         Top             =   0
         Width           =   555
      End
      Begin VB.Label CInfoLabel 
         Alignment       =   2  'Zentriert
         Height          =   495
         Left            =   4080
         TabIndex        =   9
         Top             =   0
         Width           =   1935
      End
   End
   Begin VB.PictureBox CPicture 
      Height          =   2835
      Left            =   0
      MousePointer    =   99  'Benutzerdefiniert
      ScaleHeight     =   2775
      ScaleWidth      =   6075
      TabIndex        =   0
      Top             =   0
      Width           =   6135
   End
End
Attribute VB_Name = "GFCurvectl"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'(c)2002 by Louis.
'GFCDGetFileName
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
'GFCDSetFileName
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
'ProgramGetMousePos[X, Y]
Private Declare Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
'GetLongString
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
'GFCDGetFileName; GFCDSetFileName
Private Const OFN_HIDEREADONLY = &H4
Dim NULLARRAYSTRING(0 To 0) As String 'disable if already existing in target project
'GFCDGetFileName; GFCDSetFileName
Private Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type
'ProgramGetMousePos[X, Y]
Private Type POINTAPI
    x As Long
    y As Long
End Type
'CStruct ‑ general information
Private Type CStruct
    ZoomFactor As Single
    MoveEnabledFlag As Boolean
    MoveXPos As Long
    MoveYPos As Long
    LoadSavePath As String
    ScrollXStep As Long
    ScrollXPos As Long
    ScrollYPos As Long
    ValueNumberMax As Long
End Type
Dim CStructVar As CStruct
'CObjStruct
Private Type CObjStruct
    CObjName As String
    CObjNameLength As Long
    CObjColor As Long
    ValueNumber As Long 'what is to be displayed
    ValueArray() As Single 'what is to be displayed
End Type
Dim CObjStructNumber As Integer
Dim CObjStructArray() As CObjStruct

Public Function CObj_Add(ByVal CObjName As String, ByVal CObjColor As Long) As Boolean
    'on error resume next 'returns True for object has been newly added, False if not
    'verify
    If (GetCObjStructIndex(CObjName)) Then
        CObj_Add = False 'error
        Exit Function
    End If
    'begin
    If Not (CObjStructNumber = 32766) Then 'verify
        CObjStructNumber = CObjStructNumber + 1
    Else
        CObj_Add = False 'error
        Exit Function
    End If
    ReDim Preserve CObjStructArray(1 To CObjStructNumber) As CObjStruct
    CObjStructArray(CObjStructNumber).CObjName = CObjName
    CObjStructArray(CObjStructNumber).CObjNameLength = Len(CObjName)
    CObjStructArray(CObjStructNumber).CObjColor = CObjColor
    CObjStructArray(CObjStructNumber).ValueNumber = 0 'reset (important if first item removed once)
    ReDim CObjStructArray(CObjStructNumber).ValueArray(1 To 1) As Single 'reset
    Exit Function
End Function

Public Function CObj_Remove(ByVal CObjName As String) As Boolean
    'on error resume next 'returns True for anything has been removed, False for has not ( :‑( )
    Dim CObjIndex As Integer
    Dim CObjLoop As Integer
    'preset
    CObjIndex = GetCObjStructIndex(CObjName)
    If (CObjIndex = 0) Then
        CObj_Remove = False 'error
        Exit Function
    End If
    'begin
    For CObjLoop = CObjIndex To CObjStructNumber
        If Not (CObjLoop = CObjStructNumber) Then
            CObjStructArray(CObjLoop) = CObjStructArray(CObjLoop + 1)
        Else
            CObjStructNumber = CObjStructNumber ‑ 1
            CObjLoop = CObjStructNumber
            If CObjLoop < 1 Then CObjLoop = 1 'verify
            ReDim Preserve CObjStructArray(1 To CObjLoop) As CObjStruct
            Exit Function 'important
        End If
    Next CObjLoop
    CObj_Remove = True 'ok
    Exit Function
End Function

Public Function GetCObjStructIndex(ByVal CObjName As String) As Integer
    'on error resume next 'returns index or 0 for item not found
    Dim CObjNameLength As Long
    Dim CObjLoop As Integer
    'preset
    CObjNameLength = Len(CObjName)
    'begin
    For CObjLoop = 1 To CObjStructNumber
        If CObjStructArray(CObjLoop).CObjNameLength = CObjNameLength Then 'check first to increase speed
            If CObjStructArray(CObjLoop).CObjName = CObjName Then
                GetCObjStructIndex = CObjLoop 'ok
                Exit Function
            End If
        End If
    Next CObjLoop
    GetCObjStructIndex = 0 'error
    Exit Function
End Function

Public Sub C_ReceiveValue(ByVal ValueObjName As String, ByVal Value As Single)
    'on error resume next
    Dim StructIndex As Integer
    Dim Temp As Long
    'preset
    StructIndex = GetCObjStructIndex(ValueObjName)
    'verify
    If Not (CLogCheck.Value = 1) Then Exit Sub
    'begin
    If (StructIndex) Then 'verify
        If CObjStructArray(StructIndex).ValueNumber < CStructVar.ValueNumberMax Then
            CObjStructArray(StructIndex).ValueNumber = CObjStructArray(StructIndex).ValueNumber + 1
            If ((CObjStructArray(StructIndex).ValueNumber ‑ 1) Mod 128) = 0 Then
                'NOTE: see also CLoad.
                ReDim Preserve CObjStructArray(StructIndex).ValueArray(1 To CObjStructArray(StructIndex).ValueNumber + 127) As Single
            End If
            CObjStructArray(StructIndex).ValueArray(CObjStructArray(StructIndex).ValueNumber) = Value
        Else
            'NOTE: the number of saved values isn't unlimited, move stuff 'downwards' to create space for new value.
            For Temp = 2 To CObjStructArray(StructIndex).ValueNumber
                CObjStructArray(StructIndex).ValueArray(Temp ‑ 1) = CObjStructArray(StructIndex).ValueArray(Temp)
            Next Temp
            CObjStructArray(StructIndex).ValueArray(CObjStructArray(StructIndex).ValueNumber) = Value
        End If
    End If
    Exit Sub
End Sub

Public Sub C_Tick()
    'on error resume next
    If CLogCheck.Value = 1 Then
        Call Redraw
    End If
End Sub

Public Sub Initialize(ByVal ScrollXStep As Long, ByVal ValueNumberMax As Long)
    'on error resume next
    If Right$(App.Path, 1) = "\" Then
        CStructVar.LoadSavePath = App.Path
    Else
        CStructVar.LoadSavePath = App.Path + "\"
    End If
    CStructVar.ScrollXStep = ScrollXStep
    CStructVar.ValueNumberMax = MIN(ValueNumberMax, Int(32767 \ ScrollXStep)) 'the scroll bar cannot display more than 32767 units (the unit is shown x pixels)
    CStructVar.ZoomFactor = 1!
End Sub

Private Sub CLoadCommand_Click()
    'on error resume next
    Call CLoad
End Sub

Private Sub CLogCheck_Click()
    'on error resume next
    
End Sub

Private Sub CSaveCommand_Click()
    'on error resume next
    Call CSave
End Sub

Private Sub CPicture_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    'on error resume next
    If CZoomOption.Value = True Then
        Select Case Button
        Case vbLeftButton
            CStructVar.ZoomFactor = CStructVar.ZoomFactor * 2!
        Case vbRightButton
            CStructVar.ZoomFactor = CStructVar.ZoomFactor / 2!
        End Select
        Select Case CStructVar.ZoomFactor 'verify
        Case Is < 0.25!
            CStructVar.ZoomFactor = 0.25!
        Case Is > 4!
            CStructVar.ZoomFactor = 4!
        Case Else
            Call Redraw
        End Select
    End If
    If CMoveOption.Value = True Then
        CStructVar.MoveEnabledFlag = True
        CStructVar.MoveXPos = ProgramGetMousePosX
        CStructVar.MoveYPos = ProgramGetMousePosY
    End If
End Sub

Private Sub CPicture_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    'on error resume next
    Dim Temp As Long
    'begin
    If CZoomOption.Value = True Then
    End If
    If CMoveOption.Value = True Then
        If CStructVar.MoveEnabledFlag = True Then
            CStructVar.ScrollXPos = CStructVar.ScrollXPos ‑ (CStructVar.MoveXPos ‑ ProgramGetMousePosX)
            CStructVar.ScrollYPos = CStructVar.ScrollYPos ‑ (CStructVar.MoveYPos ‑ ProgramGetMousePosY)
            CStructVar.MoveXPos = ProgramGetMousePosX
            CStructVar.MoveYPos = ProgramGetMousePosY
            Call Redraw
        End If
    End If
    If CInfoOption.Value = True Then
        For Temp = 1 To CObjStructNumber
            If CObjStructArray(Temp).CObjColor = CPicture.Point(x, y) Then
                If Not (CInfoLabel.Caption = CObjStructArray(Temp).CObjName) Then
                    CInfoLabel.Caption = CObjStructArray(Temp).CObjName
                End If
            End If
        Next Temp
    End If
End Sub

Private Sub CPicture_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    'on error resume next
    If CZoomOption.Value = True Then
    End If
    If CMoveOption.Value = True Then
        CStructVar.MoveEnabledFlag = False
    End If
End Sub

Private Sub CZoomInCommand_Click()
    'on error resume next
    CStructVar.ZoomFactor = CStructVar.ZoomFactor * 2!
    Select Case CStructVar.ZoomFactor 'verify
    Case Is < 0.25!
        CStructVar.ZoomFactor = 0.25!
    Case Is > 4!
        CStructVar.ZoomFactor = 4!
    Case Else
        Call Redraw
    End Select
End Sub

Private Sub CZoomOption_Click()
    'on error resume next
    CPicture.MouseIcon = CZoomOption.Picture
    CPicture.MousePointer = 99
End Sub

Private Sub CMoveOption_Click()
    'on error resume next
    CPicture.MouseIcon = CMoveOption.Picture
    CPicture.MousePointer = 99
End Sub

Private Sub CInfoOption_Click()
    'on error resume next
    CPicture.MouseIcon = CInfoOption.Picture
    CPicture.MousePointer = 99
End Sub

Private Sub CZoomOutCommand_Click()
    'on error resume next
    CStructVar.ZoomFactor = CStructVar.ZoomFactor / 2!
    Select Case CStructVar.ZoomFactor 'verify
    Case Is < 0.25!
        CStructVar.ZoomFactor = 0.25!
    Case Is > 4!
        CStructVar.ZoomFactor = 4!
    Case Else
        Call Redraw
    End Select
End Sub

Private Sub UserControl_Resize()
    'on error resume next
    CPicture.Width = MAX(UserControl.Width, 25 * Screen.TwipsPerPixelX)
    CPicture.Height = MAX(UserControl.Height ‑ CFrame.Height ‑ 5 * Screen.TwipsPerPixelX, 25 * Screen.TwipsPerPixelY)
    CFrame.Left = CPicture.Width ‑ CFrame.Width
    CFrame.Top = UserControl.Height ‑ CFrame.Height
End Sub

Private Function MAX(ByVal Value1 As Long, ByVal Value2 As Long) As Long
    'on error resume next
    If Value1 > Value2 Then
        MAX = Value1
    Else
        MAX = Value2
    End If
End Function

Private Function MIN(ByVal Value1 As Long, ByVal Value2 As Long) As Long
    'on error resume next
    If Value1 < Value2 Then
        MIN = Value1
    Else
        MIN = Value2
    End If
End Function

Private Function ProgramGetMousePosX() As Long
    'on error Resume Next 'the format is: pixels
    Dim ProgramGetMousePosXTemp As Long
    Dim CurrentMousePos As POINTAPI
    ProgramGetMousePosXTemp = GetCursorPos(CurrentMousePos)
    ProgramGetMousePosX = CurrentMousePos.x
End Function

Private Function ProgramGetMousePosY() As Long
    'on error Resume Next 'the format is: pixels
    Dim ProgramGetMousePosYTemp As Long
    Dim CurrentMousePos As POINTAPI
    ProgramGetMousePosYTemp = GetCursorPos(CurrentMousePos)
    ProgramGetMousePosY = CurrentMousePos.y
End Function

Private Sub Redraw()
    'on error resume next
    Dim DrawWidth As Single
    Dim DrawHeight As Single
    Dim X1 As Single
    Dim X2 As Single
    Dim Y1 As Single
    Dim Y2 As Single
    Dim CObjLoop As Integer
    Dim ValueMax As Single
    Dim ValueLoop As Long
    Dim Temp As Long
    'preset
    CPicture.AutoRedraw = True
    CPicture.ScaleMode = vbPixels
    For CObjLoop = 1 To CObjStructNumber
        For ValueLoop = CObjStructArray(CObjLoop).ValueNumber To 1 Step (‑1) 'Strg‑C‑Strg‑V
            If CObjStructArray(CObjLoop).ValueArray(ValueLoop) > ValueMax Then
                ValueMax = CObjStructArray(CObjLoop).ValueArray(ValueLoop)
            End If
        Next ValueLoop
    Next CObjLoop
    'reset
    Call CPicture.Cls
    'begin
    DrawWidth = CPicture.ScaleWidth
    DrawHeight = CPicture.ScaleHeight
    For CObjLoop = 1 To CObjStructNumber
        For ValueLoop = CObjStructArray(CObjLoop).ValueNumber To 2 Step (‑1)
            X1 = DrawWidth ‑ CSng(CObjStructArray(CObjLoop).ValueNumber ‑ ValueLoop) * CStructVar.ScrollXStep * CStructVar.ZoomFactor + CStructVar.ScrollXPos
            Y1 = DrawHeight ‑ (CObjStructArray(CObjLoop).ValueArray(ValueLoop) / ValueMax * DrawHeight) * CStructVar.ZoomFactor + CStructVar.ScrollYPos
            X2 = DrawWidth ‑ CSng(CObjStructArray(CObjLoop).ValueNumber ‑ ValueLoop + 1) * CStructVar.ScrollXStep * CStructVar.ZoomFactor + CStructVar.ScrollXPos
            Y2 = DrawHeight ‑ (CObjStructArray(CObjLoop).ValueArray(ValueLoop ‑ 1) / ValueMax * DrawHeight) * CStructVar.ZoomFactor + CStructVar.ScrollYPos
            '
            Y1 = Y1 + (CObjLoop * 180) '80 = space between curves
            Y2 = Y2 + (CObjLoop * 180) '80 = space between curves
            '
            If ((X1 >= ‑CStructVar.ScrollXStep) And (X1 < DrawWidth + CStructVar.ScrollXStep)) Then 'And (Y1 >= 0!) And (Y1 < DrawHeight)) Then
                If ((X2 >= ‑CStructVar.ScrollXStep) And (X2 < DrawWidth + CStructVar.ScrollXStep)) Then 'And (Y2 >= 0!) And (Y2 < DrawHeight)) Then
                    CPicture.Line (X1, Y1)‑(X2, Y2), CObjStructArray(CObjLoop).CObjColor
                    If ((CObjStructArray(CObjLoop).ValueNumber ‑ (ValueLoop Mod 10)) Mod 10) = 0 Then 'draw every 32 pixels the passed ticks
                        CPicture.CurrentX = X1
                        CPicture.CurrentY = DrawHeight ‑ 12
                        CPicture.Print CObjStructArray(CObjLoop).ValueNumber ‑ ValueLoop
                    End If
                End If
            End If
        Next ValueLoop
    Next CObjLoop
    For Temp = 1 To 10
        CPicture.CurrentX = 0
        CPicture.CurrentY = (DrawHeight ‑ (CSng(Temp) * DrawHeight * CStructVar.ZoomFactor / 10!)) + CStructVar.ScrollYPos
        CPicture.Print CStr(ValueMax * CSng(Temp) / 10!)
    Next Temp
End Sub

Private Sub CLoad()
    On Error GoTo Error:
    Dim FilterDescriptionArray(1 To 1) As String
    Dim FilterStringArray(1 To 1) As String
    Dim LoadName As String
    Dim LoadNameFileNumber As Integer
    Dim Temp1 As Long
    Dim Temp2 As Long
    Dim Tempstr4 As String * 4
    'preset
    FilterDescriptionArray(1) = "GFCurve Data Files"
    FilterStringArray(1) = "*.cdf"
    'begin
    LoadName = GFCDGetFileName("Load curve data...", 1, FilterDescriptionArray(), FilterStringArray(), 1, CStructVar.LoadSavePath)
    If (Len(LoadName)) Then 'verify
        CStructVar.LoadSavePath = GetDirectoryName(LoadName)
        LoadNameFileNumber = FreeFile(0)
        Open LoadName For Binary As #LoadNameFileNumber
            '
            Get #LoadNameFileNumber, , Tempstr4
            CObjStructNumber = GetStringLong(Tempstr4)
            ReDim Preserve CObjStructArray(1 To MAX(CObjStructNumber, 1)) As CObjStruct
            For Temp1 = 1 To CObjStructNumber
                Get #LoadNameFileNumber, , Tempstr4
                CObjStructArray(Temp1).CObjName = String$(GetStringLong(Tempstr4), Chr$(0))
                Get #LoadNameFileNumber, , CObjStructArray(Temp1).CObjName
                Get #LoadNameFileNumber, , Tempstr4
                CObjStructArray(Temp1).CObjNameLength = GetStringLong(Tempstr4)
                Get #LoadNameFileNumber, , Tempstr4
                CObjStructArray(Temp1).CObjColor = GetStringLong(Tempstr4)
                Get #LoadNameFileNumber, , Tempstr4
                CObjStructArray(Temp1).ValueNumber = GetStringLong(Tempstr4)
                ReDim CObjStructArray(Temp1).ValueArray(1 To MAX(CObjStructArray(Temp1).ValueNumber + 127, 1)) As Single 'see C_ReceiveValue()
                For Temp2 = 1 To CObjStructArray(Temp1).ValueNumber
                    Get #LoadNameFileNumber, , Tempstr4
                    CObjStructArray(Temp1).ValueArray(Temp2) = GetStringSingle(Tempstr4)
                Next Temp2
            Next Temp1
            '
        Close #LoadNameFileNumber
        CLogCheck.Value = 0 'don't log anymore
        Call Redraw 'not done automatically
        MsgBox "File loaded successfully.", vbOKOnly + vbInformation
    End If
    Exit Sub
Error:
    MsgBox "Error loading file, reason: " + Err.Description, vbOKOnly + vbExclamation
    Exit Sub
End Sub

Public Property Let BackColor(ByVal BackColor As Long)
    'on error resume next
    CPicture.BackColor = BackColor
End Property

Public Property Set BackColor() As Long
    'on error resume next
    BackColor = CPicture.BackColor
End Property

Public Property Let ForeColor(ByVal ForeColor As Long)
    'on error resume next
    CPicture.ForeColor = ForeColor
End Property

Public Property Set ForeColor() As Long
    'on error resume next
    ForeColor = CPicture.ForeColor
End Property

Private Sub CSave()
    On Error GoTo Error:
    Dim FilterDescriptionArray(1 To 1) As String
    Dim FilterStringArray(1 To 1) As String
    Dim SaveName As String
    Dim SaveNameFileNumber As Integer
    Dim Temp1 As Long
    Dim Temp2 As Long
    'preset
    FilterDescriptionArray(1) = "GFCurve Data Files"
    FilterStringArray(1) = "*.cdf"
    'begin
    SaveName = GFCDSetFileName("Save curve data as...", 1, FilterDescriptionArray(), FilterStringArray(), 1, CStructVar.LoadSavePath)
    If (Len(SaveName)) Then 'verify
        If Not (LCase$(Right$(SaveName, 4)) = ".cdf") Then SaveName = SaveName + ".cdf" 'verify
        CStructVar.LoadSavePath = GetDirectoryName(SaveName)
        SaveNameFileNumber = FreeFile(0)
        Open SaveName For Output As #SaveNameFileNumber
            '
            Print #1, GetLongString(CObjStructNumber);
            For Temp1 = 1 To CObjStructNumber
                Print #1, GetLongString(Len(CObjStructArray(Temp1).CObjName));
                Print #1, CObjStructArray(Temp1).CObjName;
                Print #1, GetLongString(CObjStructArray(Temp1).CObjNameLength);
                Print #1, GetLongString(CObjStructArray(Temp1).CObjColor);
                Print #1, GetLongString(CObjStructArray(Temp1).ValueNumber);
                For Temp2 = 1 To CObjStructArray(Temp1).ValueNumber
                    Print #1, GetSingleString(CObjStructArray(Temp1).ValueArray(Temp2));
                Next Temp2
            Next Temp1
            '
        Close #SaveNameFileNumber
        MsgBox "File saved successfully.", vbOKOnly + vbInformation
    End If
    Exit Sub
Error:
    MsgBox "Error saving file, reason: " + Err.Description, vbOKOnly + vbExclamation
    Exit Sub
End Sub

Private Function GFCDGetFileName(ByVal Title As String, ByRef FilterNumber As Integer, ByRef FilterDescriptionArray() As String, ByRef FilterStringArray() As String, ByVal DefaultFilterIndex As Integer, ByVal DefaultPath As String) As String
    'on error resume next 'must be placed into a form (uses hWnd); FilterNumber may be 0 (then pass NULLARRAYSTRING()), DefaultPath should contain path and file name
    Dim OPENFILENAMEVar As OPENFILENAME
    Dim DefaultFileName As String
    Dim DefaultDirectoryName As String
    Dim Temp As Long
    '
    'NOTE: the FilerDescriptionArray() and the FilterStringArray() data
    'must have the following format (example; description/string):
    '
    'Bitmap/*.bmp;*.jpg;*.gif
    '
    'If FilterNumber is 0, the preset filter 'All Files/*.*' is used.
    'If the user pressed 'Cancel' the function returns nothing ("").
    '
    'initialize structure
    OPENFILENAMEVar.lStructSize = Len(OPENFILENAMEVar)
    OPENFILENAMEVar.hwndOwner = 0 'do not use form (module ?!) handle
    OPENFILENAMEVar.hInstance = App.hInstance
    If Not (FilterNumber = 0) Then
        '
        'NOTE: the filter string contains string pairs (filter description/string),
        'the string end is marked by two null chars.
        '
        For Temp = 1 To FilterNumber
            OPENFILENAMEVar.lpstrFilter = OPENFILENAMEVar.lpstrFilter + _
                FilterDescriptionArray(Temp) + Chr$(0) + FilterStringArray(Temp) + Chr$(0)
        Next Temp
        OPENFILENAMEVar.lpstrFilter = OPENFILENAMEVar.lpstrFilter + Chr$(0) 'two null chars at filter string end
    Else
        OPENFILENAMEVar.lpstrFilter = "All Files" + Chr$(0) + "*.*" + Chr$(0) + Chr$(0)
    End If
    OPENFILENAMEVar.nFilterIndex = DefaultFilterIndex
    If Not (GetFileName(DefaultPath) = "") Then
        DefaultFileName = GetFileName(DefaultPath)
        OPENFILENAMEVar.nMaxFile = 260 + 1 'MAX_PATH
        OPENFILENAMEVar.lpstrFile = String$(260 + 1, Chr$(0))
        Mid$(OPENFILENAMEVar.lpstrFile, 1, Len(DefaultFileName)) = Left$(DefaultFileName, 260)
    Else
        OPENFILENAMEVar.nMaxFile = 260 + 1 'MAX_PATH
        OPENFILENAMEVar.lpstrFile = String$(260 + 1, Chr$(0))
    End If
    OPENFILENAMEVar.lpstrTitle = Title + Chr$(0)
    DefaultDirectoryName = Left$(DefaultPath, Len(DefaultPath) ‑ Len(DefaultFileName))
    OPENFILENAMEVar.lpstrInitialDir = DefaultDirectoryName + Chr$(0)
    OPENFILENAMEVar.nMaxFileTitle = 260 + 1 'MAX_PATH
    OPENFILENAMEVar.lpstrFileTitle = String$(260 + 1, Chr$(0)) 'receives selected file name (without directory)
    OPENFILENAMEVar.flags = OFN_HIDEREADONLY
    'end of initializing structure
    If Not (GetOpenFileName(OPENFILENAMEVar) = 0) Then
        If Not (InStr(1, OPENFILENAMEVar.lpstrFile, Chr$(0), vbBinaryCompare) = 0) Then 'verify
            GFCDGetFileName = Left$(OPENFILENAMEVar.lpstrFile, InStr(1, OPENFILENAMEVar.lpstrFile, Chr$(0), vbBinaryCompare) ‑ 1)
        Else
            GFCDGetFileName = OPENFILENAMEVar.lpstrFile
        End If
    Else
        GFCDGetFileName = "" 'reset (error)
    End If
End Function

Private Function GFCDSetFileName(ByVal Title As String, ByRef FilterNumber As Integer, ByRef FilterDescriptionArray() As String, ByRef FilterStringArray() As String, ByVal DefaultFilterIndex As Integer, ByVal DefaultPath As String) As String
    'on error resume next 'must be placed into a form (uses hWnd); FilterNumber may be 0 (then pass NULLARRAYSTRING()), DefaultPath should contain path and file name
    Dim OPENFILENAMEVar As OPENFILENAME
    Dim DefaultFileName As String
    Dim DefaultDirectoryName As String
    Dim Temp As Long
    '
    'NOTE: the FilerDescriptionArray() and the FilterStringArray() data
    'must have the following format (example; description/string):
    '
    'Bitmap/*.bmp;*.jpg;*.gif
    '
    'If FilterNumber is 0, the preset filter 'All Files/*.*' is used.
    'If the user pressed 'Cancel' the function returns nothing ("").
    '
    'initialize structure
    OPENFILENAMEVar.lStructSize = Len(OPENFILENAMEVar)
    OPENFILENAMEVar.hwndOwner = 0 'do not use form (module ?!) handle
    OPENFILENAMEVar.hInstance = App.hInstance
    If Not (FilterNumber = 0) Then
        '
        'NOTE: the filter string contains string pairs (filter description/string),
        'the string end is marked by two null chars.
        '
        For Temp = 1 To FilterNumber
            OPENFILENAMEVar.lpstrFilter = OPENFILENAMEVar.lpstrFilter + _
                FilterDescriptionArray(Temp) + Chr$(0) + FilterStringArray(Temp) + Chr$(0)
        Next Temp
        OPENFILENAMEVar.lpstrFilter = OPENFILENAMEVar.lpstrFilter + Chr$(0) 'two null chars at filter string end
    Else
        OPENFILENAMEVar.lpstrFilter = "All Files" + Chr$(0) + "*.*" + Chr$(0) + Chr$(0)
    End If
    OPENFILENAMEVar.nFilterIndex = DefaultFilterIndex
    If Not (GetFileName(DefaultPath) = "") Then
        DefaultFileName = GetFileName(DefaultPath)
        OPENFILENAMEVar.nMaxFile = 260 + 1 'MAX_PATH
        OPENFILENAMEVar.lpstrFile = String$(260 + 1, Chr$(0))
        Mid$(OPENFILENAMEVar.lpstrFile, 1, Len(DefaultFileName)) = Left$(DefaultFileName, 260)
    Else
        OPENFILENAMEVar.nMaxFile = 260 + 1 'MAX_PATH
        OPENFILENAMEVar.lpstrFile = String$(260 + 1, Chr$(0))
    End If
    OPENFILENAMEVar.lpstrTitle = Title + Chr$(0)
    DefaultDirectoryName = Left$(DefaultPath, Len(DefaultPath) ‑ Len(DefaultFileName))
    OPENFILENAMEVar.lpstrInitialDir = DefaultDirectoryName + Chr$(0)
    OPENFILENAMEVar.nMaxFileTitle = 260 + 1 'MAX_PATH
    OPENFILENAMEVar.lpstrFileTitle = String$(260 + 1, Chr$(0)) 'receives selected file name (without directory)
    OPENFILENAMEVar.flags = OFN_HIDEREADONLY
    'end of initializing structure
    If Not (GetSaveFileName(OPENFILENAMEVar) = 0) Then
        If Not (InStr(1, OPENFILENAMEVar.lpstrFile, Chr$(0), vbBinaryCompare) = 0) Then 'verify
            GFCDSetFileName = Left$(OPENFILENAMEVar.lpstrFile, InStr(1, OPENFILENAMEVar.lpstrFile, Chr$(0), vbBinaryCompare) ‑ 1)
        Else
            GFCDSetFileName = OPENFILENAMEVar.lpstrFile
        End If
    Else
        GFCDSetFileName = "" 'reset (error)
    End If
End Function

Private Function GetLongString(ByVal LongValue As Long) As String
    'on error resume next 'get the 4 bytes of a Long value
    GetLongString = String$(4, Chr$(0))
    Call CopyMemory(ByVal GetLongString, LongValue, 4)
End Function

Private Function GetStringLong(ByVal StringString As String) As Long
    'on error resume next
    Call CopyMemory(GetStringLong, ByVal StringString, 4)
End Function

Private Function GetSingleString(ByVal SingleValue As Single) As String
    'on error resume next 'get the 4 bytes of a Single value
    GetSingleString = String$(4, Chr$(0))
    Call CopyMemory(ByVal GetSingleString, SingleValue, 4)
End Function

Private Function GetStringSingle(ByVal StringString As String) As Single
    'on error resume next
    Call CopyMemory(GetStringSingle, ByVal StringString, 4)
End Function

Private Function GetFileName(ByVal GetFileNameName As String) As String
    'on error Resume Next 'returns chars after last backslash or nothing
    Dim GetFileNameLoop As Integer
    GetFileName = "" 'reset
    For GetFileNameLoop = Len(GetFileNameName) To 1 Step (‑1)
        If Mid$(GetFileNameName, GetFileNameLoop, 1) = "\" Then
            GetFileName = Right$(GetFileNameName, Len(GetFileNameName) ‑ GetFileNameLoop)
            Exit For
        End If
    Next GetFileNameLoop
End Function

Public Function GetDirectoryName(ByVal GetDirectoryNameName As String) As String
    'on error Resume Next 'returns chars from string beginning to (including) last backslash or nothing
    Dim GetDirectoryNameLoop As Integer
    GetDirectoryName = "" 'reset
    For GetDirectoryNameLoop = Len(GetDirectoryNameName) To 1 Step (‑1)
        If Mid$(GetDirectoryNameName, GetDirectoryNameLoop, 1) = "\" Then
            GetDirectoryName = Left$(GetDirectoryNameName, GetDirectoryNameLoop)
            Exit For
        End If
    Next GetDirectoryNameLoop
End Function



[END OF FILE]