Программирование на Visual Basic

Для проверки ваших знаний  в Excel VBA Вы можете попробовать решить следующую тестовую задачу (кейс).  Она может потребоваться при приеме на работу как разработчика VBA и SQL Server.  Вот  её содержание.

1. Необходимо создать таблицу на сервере MSSQL с 3 столбцами
2. Реализовать загрузку данных на сервер из Excel (200 000 записей) через VBA или Python через UI. При реализации на Python можно использовать любой UI framework
3. Сделать хранимую процедуру на MS SQL сервере для выгрузки данных за определенный период.
4. Реализовать возможность указывать период от до (на форме VBA или значения в Excel, на выбранной UI framework форме) и результат хранимой процедуры из 3 пункта выгружать в новую книгу Excel. Так же реализовать форматирование отчета (закрепление шапки и формат столбцов)
5. Отчет должен содержать столбцы: Год, Месяц, Артикул, средние продажи за год и месяц, доля продаж артикула за выбранный период
6. Логика отчета с расчетом средних продаж и доли продаж должна быть реализована в хранимой процедуре
7. Приложение. Файл data.xlsb с 200 тысяч записей.

Оценка работы

На первый взгляд задание простое, исходных данных не много, но есть нюансы. Их придется учитывать, а также то, что конкурсное задание могут решить правильно ваши конкуренты. Работодателю придется выбирать между вами и ими. Выход из этого такой. Надо уделить внимание качеству интерфейса, попытаться сделать его профессионально, например, с инсталляцией. Для решения задачи, я выбрал 3 этапа работы, которые и отобразил на форме Excel.

1. Этап. Настройка интерфейса .
2. Этап. Загрузка в базу данных из Excel.
3. Этап. Создание отчёта за период

Ещё...

Данный пример показывает как можно редактировать тексты rtf в Microsoft Access.

'сохранение текущей записи в файле в формате RTF
Private Sub cmdSave_Click()
    Me.RichTextBox1.SaveFile CurrentProject.Path  "\rtftemp"  Me.ID  ".rtf"
End Sub

'сохранение всех записей в файле в формате RTF
Private Sub cmdSaveAll_Click()
Dim i As Long, p As Long
Dim strtemp As String, strrtf As String
    'разделитель записей (по желанию)
    Const spl = "\rtf1\ansi\ansicpg1251\deff0\deflang1049{\fonttbl{\f0\fnil\fcharset0 Tahoma;}}"  _
    "\viewkind4\uc1\pard\f0\fs24 ************************************"  _
    "\par"
    
    'сведем все записи воедино
    DoCmd.GoToRecord , , acFirst
    DoCmd.Echo False
    For i = 1 To DCount("[ID]", "T1")
         strtemp = Me.RichTextBox1.TextRTF
         'для "нормального" склеивания фрагментов текста надо удалить лишние "}" "{"
         p = InStrRev(strtemp, "}")
         strtemp = Left(strtemp, p - 1)
         p = InStr(strtemp, "{")
         strtemp = Right(strtemp, Len(strtemp) - p)
         strrtf = strrtf  strtemp  spl
         DoCmd.GoToRecord , , acNext
    Next i
    DoCmd.GoToRecord , , acFirst
    DoCmd.Echo True
    
    'восстановим начальные и конечные "{"
    strrtf = "{"  strrtf  "}"
    
    'чтобы полученный не влиял на данные, отключим RichTextBox от данных
    strtemp = Me.RichTextBox1.ControlSource
    Me.RichTextBox1.ControlSource = ""
    Me.RichTextBox1.TextRTF = strrtf
    
    Me.RichTextBox1.SaveFile CurrentProject.Path  "\rtftempall.rtf"
    
    'восстановим нормальную работу
    Me.RichTextBox1.ControlSource = strtemp
End Sub

'управление насыщенностью
Private Sub ctlBold_AfterUpdate()
    Select Case Me.ctlBold.Value
    Case -1
    Me.RichTextBox1.SelBold = True
    Case 0
    Me.RichTextBox1.SelBold = False
    End Select
    Me.RichTextBox1.SetFocus
End Sub

03. Это делается в конструкторе отчетов, поэтому для понимания этого примера откройте mdb файл

03. Первая часть - при загрузке формы скрывается ее заголовок. Средствами Access можно убрать строку меню и границу, но тогда форма не имеет четко выраженной границы. Вторая часть - рисование полилиний разного цвета. При построении графиков для наглядности удобно представлять данные разными цветами в зависимости от уровня стандартные средства этого почему-то не поддерживают. Третья часть - пример использования регионов.

'константы для функции пересчета твипов
'значения 88 и 90 могут отличаться!
Public Const LOGPIXELSX = 88
Public Const LOGPIXELSY = 90

'константы для функции скрытия заголовка
Public Const STYLE = (-16)
Public Const CAPTION = HC00000
Public Const BORDER = H800000
Public Const NOMOVE = H2
Public Const NOSIZE = H1
Public Const NOZODER = H4
Public Const ShowWindow = H40
Public Const NOACTIVE = H10
Public Const FRAMECHANGED = H20

'вычисление коэффициента пересчета Twip в Pixel
Public Function TwipToPixel(i As Long) As Long
    Dim hDc As Long
    'получение идентификатора контеста устройства
    hDc = GetDC(0)
    Select Case i
    Case 1
    TwipToPixel = 1440 / GetDeviceCaps(hDc, LOGPIXELSX)
    Case 2
    TwipToPixel = 1440 / GetDeviceCaps(hDc, LOGPIXELSY)
    End Select
    'освобождение идентификатора
    ReleaseDC 0, hDc

End Function
'--
'GetDC возвращает контекст устройства (DC) окна
Public Declare Function GetDC Lib "user32" (ByVal hw As Long) As Long
'ReleaseDC освобождает ресурсы,которые были заняты
'при использовании GetDC для получения контекста устройства
Public Declare Function ReleaseDC Lib "user32" (ByVal hw As Long, ByVal hDc As Long) As Long

'получение характеристик дисплея
Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDc As Long, _
   ByVal iCapability As Long) As Long

'функция позволяет получить используемый стиль окна
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
 (ByVal hwnd As Long, ByVal nIndex As Long) As Long

'функция позволяет установить новый стиль окна
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
 (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
 
'функция отображает окно в указанном месте
Public Declare Function SetWindowPos Lib "user32.dll" _
(ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, _
ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal _
wFlags As Long) As Long

' Функция используется для поиска окна
 Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
  (ByVal hWndParent As Long, _
   ByVal hWndChildAfter As Long, _
   ByVal lpClassname As String, _
   ByVal lpWindowName As String) As Long

' Функция рисует ломаную с помощью выбранного "пера"
Public Declare Function Polygon Lib "gdi32" (ByVal hDc As Long, _
     lpPoint As POINTAPI, ByVal nCount As Long) As Long

' Функция рисует ломаную с помощью выбранного "пера"
Public Declare Function Polyline Lib "gdi32" (ByVal hDc As Long, _
     lpPoint As POINTAPI, _
     ByVal nCount As Long) As Long



' Структура координаты точки
Public Type POINTAPI
    x As Long
    Y As Long
End Type


'функция выбирает устройство для рисования
Public Declare Function SelectObject Lib "gdi32.dll" (ByVal hDc _
As Long, ByVal hObject As Long) As Long

'функция удаляет созданный объект для освобождения ресурсов
Public Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject _
As Long) As Long

'функция создает новое "перо"
Public Declare Function CreatePen Lib "gdi32.dll" (ByVal fnPenStyle _
As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long

'функция создает новую "кисть"
Public Declare Function CreateSolidBrush Lib "gdi32.dll" (ByVal _
crColor As Long) As Long

'функция создает прямоугольный регион
Public Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, _
ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long

'функция создает комбинацию из двух регионов
Public Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As _
Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal _
nCombineMode As Long) As Long

'функция отображает регион на окно
Public Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As _
Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long

'функция позволяет получить размеры и положение окна
Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As _
Long, lpRect As Rect) As Long

'структура для данных, получаемых GetWindowRect
 Public Type Rect
  left As Long
  top As Long
  right As Long
  bottom As Long
End Type

'функция управляет "показом" окна
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As _
Long, ByVal nCmdShow As Long) As Long
'--



Public Function Скрыть_Заголовок(frm As Form, IndexX As Long, IndexY As Long)
    Dim OldStyle As Long, NewStyle As Long
    Dim x As Long, Y As Long
    
    'получение текушего стиля окна
    OldStyle = GetWindowLong(frm.hwnd, STYLE)
    
    'определение и установка нового стиля окна
    NewStyle = (OldStyle And Not CAPTION) Or BORDER
    SetWindowLong frm.hwnd, STYLE%, NewStyle
    
    'настройка размеров окна
    x = frm.Width \ IndexX
    Y = frm.Section(acDetail).Height \ IndexY
    
    'отображение окна с новыми свойствами
    SetWindowPos frm.hwnd, 0, 0, 0, x, Y, NOMOVE Or NOZODER Or FRAMECHANGED

End Function

16. Этот код очень часто используется при разработке бухгалтерских систем, где требуется не только написать сумму, но и вывести ее прописью. Инструкция центробанка требует еще и разделение цифр не точкой, а дефисом -.

Const SPACE As String = " " 'Определяет число пробелов между словами

'==============================================================
' Назначение:
'    Перевод числа в строковую константу
' Параметры
'    curMoney - сумма, которую надо перевести в строку
'    flagBank - указывает какую сумму надо вернуть
' Приме��:
'    funRusMoney(678.56) = "Шестьсот семьдесят восемь рублей 56 копеек"
'
Public Function funRusMoney(curMoney As Currency, flagBank) As String
Dim myMoney As Currency 'Все деньги
Dim myRoubles As Long 'Только рубли
Dim myCopecks As Long 'Только копейки
Dim iGroup As Long 'Группировка по разрядам
Dim s As String 'Промежуточная переменная
    
    On Error GoTo 999
    'Проведем округление абслютного результата до 2х разрядов.
    'Иногда бывает в функцию передается результат: -678,56001,
    'а нам нужен 678,56
    myMoney = Format(Abs(curMoney), "0.00")
    
    'Проверка входящей суммы
    If myMoney  2147483647.99 Then
        MsgBox "Очень большое число: "  Format(curMoney, "Currency")  vbCrLf  _
               "Максимальное число: 2 147 483 647,99", vbExclamation, "Сумма прописью"
               funRusMoney = "Слишком большое число: "  curMoney
        Exit Function
    End If
    
    'Определяем рубли и копейки
    myRoubles = CLng(Fix(myMoney))
    myCopecks = (myMoney - Fix(myMoney)) * 100
    
    If myRoubles  0 Then 'Есть рубли
        'Миллиарды рублей
        s = funTextMoney(myRoubles, myCopecks, 1000000000, "М", iGroup)
        'Миллионы рублей
        s = s  funTextMoney(myRoubles, myCopecks, 1000000, "М", iGroup)
        'Тысячи рублей
        s = s  funTextMoney(myRoubles, myCopecks, 1000, "Ж", iGroup)
        'Cотни рублей
        s = s  funTextMoney(myRoubles, myCopecks, 1, "М", iGroup)
        'Дописываем рубли
        s = s  strRoubles(iGroup)
    Else 'Нет рублей
        s = "0 рублей"  SPACE
    End If
    'Добавляем копейки прописью
    If (flagBank = True) And (myCopecks = 0) Then
        'не добавляем копеек по инструкции Центробанка
    Else
        s = s  strCopecks(myCopecks) 'Дописываем копейки
    End If
    
    'Вывод текста c Заглавной буквы
    funRusMoney = UCase(Mid(s, 1, 1))  Mid(s, 2)
    Exit Function
999:
    MsgBox Err.Description, vbCritical, "Сумма прописью"
    funRusMoney = "Ошибка в прописи суммы: "  curMoney
    Err.Clear
End Function

'==============================================================
' Назначение:
'    Перевод для разных групп чисел в строковую константу
' Параметры
'    myRoubles - рубли
'    myCopecks - копейки
'    iSize - размер группы (1, 1000, ...)
'    sSex - пол группы (М - мужской, Ж - женский)
' Пример:
'    funTextMoney(678,25,1,"М") = _
'                "шестьсот семьдесят восемь рублей 25 копеек"
'
Public Function funTextMoney( _
    myRoubles As Long, _
    myCopecks As Long, _
    iSize As Long, _
    sSex As String, _
    iGroup As Long _
    ) As String

Dim iBlock As Long 'Блок данных
Dim sOut As String 'Выходная строка

    sOut = "" 'Инициализация переменной
    iGroup = myRoubles \ iSize 'Возвращем число 0-999
    If (iGroup  0) Then
        iBlock = iGroup \ 100 'Вернуть сотни
        sOut = sOut  strHundreds(iBlock) 'Вернуть текст
        myRoubles = myRoubles - iBlock * 100 * iSize 'Оставшаяся сумма
        
        iGroup = iGroup - iBlock * 100 'Возвращем число 0-99
        If iGroup  19 Then
            iBlock = iGroup \ 10 'Вернуть десятки
            sOut = sOut  strTens(iBlock) 'Вернуть текст
            myRoubles = myRoubles - iBlock * 10 * iSize 'Оставшаяся сумма
            iGroup = iGroup - iBlock * 10 'Возвращем число 0-9
        End If

        sOut = sOut  strOne(iGroup, sSex) 'Вернуть текст
        myRoubles = myRoubles - iGroup * iSize  'Оставшаяся сумма
        
        'Добавляем текст в конец строки
        Select Case iSize
            Case 1000000000: sOut = sOut  strBillions(iGroup)
            Case 1000000: sOut = sOut  strMillions(iGroup)
            Case 1000: sOut = sOut  strThousand(iGroup)
        End Select
    End If
    
    'Возвращаем текст
    funTextMoney = sOut
End Function

'==============================================================
' Назначение:
'       вернуть миллиарды прописью
' Пример:
'       strBillions(2) = "миллиард"
'
Function strBillions(iBlock As Long) As String
    Select Case iBlock
        Case 1:      strBillions = "миллиард"
        Case 2 To 4: strBillions = "милиарда"
        Case Else:   strBillions = "миллиардов"
    End Select
    strBillions = strBillions  SPACE
End Function

'==============================================================
' Назначение:
'       вернуть миллионы прописью
' Пример:
'       strMillions(2) = "миллиона"
'
Public Function strMillions(iBlock As Long) As String
    Select Case iBlock
        Case 1:      strMillions = "миллион"
        Case 2 To 4: strMillions = "миллиона"
        Case Else:   strMillions = "миллионов"
    End Select
    strMillions = strMillions  SPACE
End Function

'==============================================================
' Назначение:
'       вернуть тысячи прописью
' Пример:
'       strThousand(2) = "тысячи"
'
Public Function strThousand(iBlock As Long) As String
    Select Case iBlock
        Case 1:      strThousand = "тысяча"
        Case 2 To 4: strThousand = "тысячи"
        Case Else:   strThousand = "тысяч"
    End Select
    strThousand = strThousand  SPACE
End Function

'==============================================================
' Назначение:
'       вернуть сотни прописью
' Пример:
'       strHundreds(2)="двести"
'
Public Function strHundreds(iBlock As Long) As String
    Select Case iBlock
         Case 1:  strHundreds = "сто"
         Case 2:  strHundreds = "двести"
         Case 3:  strHundreds = "триста"
         Case 4:  strHundreds = "четыреста"
         Case 5:  strHundreds = "пятьсот"
         Case 6:  strHundreds = "шестьсот"
         Case 7:  strHundreds = "семьсот"
         Case 8:  strHundreds = "восемьсот"
         Case 9:  strHundreds = "девятьсот"
    End Select
    If iBlock  0 Then strHundreds = strHundreds  SPACE
End Function

'==============================================================
' Назначение:
'       вернуть десятки прописью
' Пример:
'       strTens(3) = "тридцать"
'
Public Function strTens(iBlock As Long) As String
    Select Case iBlock
         Case 2: strTens = "двадцать"
         Case 3: strTens = "тридцать "
         Case 4: strTens = "сорок"
         Case 5: strTens = "пятьдесят"
         Case 6: strTens = "шестьдесят"
         Case 7: strTens = "семьдесят"
         Case 8: strTens = "восемьдесят"
         Case 9: strTens = "девяносто"
    End Select
    If iBlock  0 Then strTens = strTens  SPACE
End Function

'==============================================================
' Назначение:
'       вернуть единицы прописью
' Пример:
'       strOne(2, "М")="два"
Public Function strOne(iBlock As Long, sSex As String) As String
    Select Case iBlock
        Case 1, 2
            Select Case iBlock  sSex 'Определяем пол
            Case "1М": strOne = "один" 'Мужской пол
            Case "2М": strOne = "два" 'Мужской пол
            Case "1Ж": strOne = "одна" 'Женский пол
            Case "2Ж": strOne = "две" 'Женский пол
            End Select
        Case 3:   strOne = "три"
        Case 4:   strOne = "четыре"
        Case 5:   strOne = "пять"
        Case 6:   strOne = "шесть"
        Case 7:   strOne = "семь"
        Case 8:   strOne = "восемь"
        Case 9:   strOne = "девять"
        Case 10:  strOne = "десять"
        Case 11:  strOne = "одиннадцать"
        Case 12:  strOne = "двенадцать"
        Case 13:  strOne = "тринадцать"
        Case 14:  strOne = "четырнадцать"
        Case 15:  strOne = "пятнадцать"
        Case 16:  strOne = "шестнадцать"
        Case 17:  strOne = "семнадцать"
        Case 18:  strOne = "восемнадцать"
        Case 19:  strOne = "девятнадцать"
    End Select
    If iBlock  0 Then strOne = strOne  SPACE
End Function

'==============================================================
' Назначение:
'       вернуть копейки прописью
' Пример:
'       strCopecks(56) = "56 копеек"
'
Public Function strCopecks(myCopecks As Long) As String
Dim r As Integer 'разряд копеек
    'Записываем копейки
    strCopecks = Format(myCopecks, "00")  SPACE
    
    'Определяем разряд копеек
    r = myCopecks
    If myCopecks  20 Then r = r - Fix(r / 10) * 10
    Select Case r 'Составляем текст
        Case 1:      strCopecks = strCopecks  "копейка"
        Case 2 To 4: strCopecks = strCopecks  "копейки"
        Case Else:   strCopecks = strCopecks  "копеек"
    End Select
End Function

'==============================================================
' Назначение:
'       вернуть название рублей прописью
' Пример:
'       strRoubles(2) = "рубля"
'
Public Function strRoubles(iBlock As Long) As String
    Select Case iBlock
        Case 1:      strRoubles = "рубль"
        Case 2 To 4: strRoubles = "рубля"
        Case Else:   strRoubles = "рублей"
    End Select
    strRoubles = strRoubles  SPACE
End Function

'==============================================================
' Назначение:
'       вернуть сумму по инструкции центробанка
'
Public Function strConvBank(curMoney As Currency) As String
Dim myCopecks As Long
'    strConvBank = Format(curMoney, "0") 'Формат рублей
    myCopecks = (curMoney - Fix(curMoney)) * 100
    strConvBank = CStr(curMoney - myCopecks / 100)
    If myCopecks = 0 Then
        strConvBank = strConvBank  "=" 'Без копеек
    Else
        strConvBank = strConvBank  "-"  Format(myCopecks, "00") 'С копейками
    End If
End Function

14. Бывает при разработке интерфейса необходимо не только провести сортировку формы, но и сохранить текущую запись. Это делается с помощью этого кода

'    Сортировка
Private Sub butSort_Click()
Dim frm As Form, rst As Recordset, myBook As String
    On Error Resume Next
    Set frm = [Form_Пример 14 пдч] 'Выбираем форму
    
    myBook = frm.Книга
    frm.OrderBy = "[Книга] asc" 'Сортируем по возрастанию
    frm.OrderByOn = True 'Включаем сортировку
    
    'Ищем запись
    Set rst = frm.Recordset
    rst.FindFirst "[Книга]='"  myBook  "'"
    frm.Bookmark = rst.Bookmark   'Возвращаем позицию
    Err.Clear
End Sub

'==============================================================
'    Сортировка
Private Sub Form_Open(Cancel As Integer)
Dim frm As Form
    Set frm = [Form_Пример 14 пдч] 'Выбираем форму
    frm.OrderBy = "[Книга] desc" 'Сортируем по убыванию
    frm.OrderByOn = True 'Включаем сортировку
End Sub

15. Некоторые виды интерфейса требуют, чтобы в полях показывался результат выполнения нескольких полей. Например, итоговая сумма по заказу. Это делается следующим способом.

Private Sub Form_Open(Cancel As Integer)
    Me.Итого.ControlSource = "=[Сумма]*[Наценка]"
End Sub

13. Если Вы разрабатываете интерфейс в зависимости от разных ролей пользователей, которым нужно разрешить или запретить редактирование формы, то используйте этот пример.

Private Sub butEdit_Click()
Dim frm As Form
    Set frm = [Form_Пример 13 пдч]
    frm.AllowAdditions = Me.butEdit 'Разрешить добавление
    frm.AllowDeletions = Me.butEdit 'Разрешить удаление
    frm.AllowEdits = Me.butEdit     'Разрешить редактирование
    If Me.butEdit = True Then 'Если разрешено редактирование
        Me.butEdit.Caption = "Отменить редактирование" 'Текст кнопки
        Me.butEdit.ForeColor = 255 'Цвет символов
    Else
        Me.butEdit.Caption = "Включить редактирование"
        Me.butEdit.ForeColor = 0
    End If
End Sub

12. При разработке баз данных очень часто встречаются случаи, когда необходимо автоматическим способом заполнить поля в форме. Это показано в этом примере

'==============================================================
' Заполнение реквизитов
Private Sub allFirms_AfterUpdate()
Dim rst As Recordset
    On Error GoTo 999
    Set rst = CurrentDb.OpenRecordset("SELECT * FROM [Фирмы] WHERE [Фирма]='"  Me.allFirms  "'")
    If rst.RecordCount  0 Then
        With rst
            'Форму Вы можете связать с таблицей
            Me.Фирма = rst!Фирма
            Me.Банк = rst!Банк
            Me.Счет = rst!Счет
            Me.КорСЧЕТ = rst!КорСчет
        End With
    End If
    rst.Close
    Exit Sub
999:
    MsgBox Err.Description
    Err.Clear
End Sub

' Определяем максимальный номер документа
Private Sub Form_Current()
    If Me.NewRecord = True Then
       Me.Nдок.DefaultValue = 1 + funGetMaxNumber("SELECT Max([Nдок]) as NN FROM [Пример 12]")
    End If
End Sub

'==============================================================
' Получаем максимальное число
Function funGetMaxNumber(sSQL As String) As Long
Dim dbs As Database, rst As Recordset
    funGetMaxNumber = 0
    On Error GoTo 999
    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset(sSQL)
    If rst.RecordCount  0 Then
        funGetMaxNumber = rst![NN]
    End If
    rst.Close
    Exit Function
999:
    Err.Clear
End Function

08. Это типовой диалог Windows, который позволяет выбрать файл. Есть диалог и Microsoft Office с аналогичными целями. Его смотрите в других примерах (14 Файлы).

'Структура файла, описание дано ниже
Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As Long
    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 Long
End Type

'Функция открытия файла
Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" ( _
        FILENAME As OPENFILENAME) As Boolean

'Функция сохранения файла
Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" ( _
        FILENAME As OPENFILENAME) As Boolean

'Флажки для параметра OPENFILENAME.Flags
'  (например, OFN_FILEMUSTEXIST Or OFN_READONLY)
Const OFN_READONLY = H1
Const OFN_OVERWRITEPROMPT = H2
Const OFN_HIDEREADONLY = H4
Const OFN_NOCHANGEDIR = H8
Const OFN_SHOWHELP = H10
Const OFN_ENABLEHOOK = H20
Const OFN_ENABLETEMPLATE = H40
Const OFN_ENABLETEMPLATEHANDLE = H80
Const OFN_NOVALIDATE = H100
Const OFN_ALLOWMULTISELECT = H200
Const OFN_EXTENSIONDIFFERENT = H400
Const OFN_PATHMUSTEXIST = H800
Const OFN_FILEMUSTEXIST = H1000
Const OFN_CREATEPROMPT = H2000
Const OFN_SHAREAWARE = H4000
Const OFN_NOREADONLYRETURN = H8000
Const OFN_NOTESTFILECREATE = H10000

Const OFN_SHAREFALLTHROUGH = 2
Const OFN_SHARENOWARN = 1
Const OFN_SHAREWARN = 0

Dim OFNAME As OPENFILENAME 'Назначаем переменную для файла

'==============================================================
'   Назначение
'        Открытие окна диалога файлов
'   Параметры:
'        strFilter - строка фильтра
'        strIniFile - файл инициализации
'        strTitleDlg - заголовок окна
'        strDefExt - расширение по умолчанию
'        strCurDir - текущая папка
'
Public Function funGetOpenFileName( _
    hWnd As Long, _
    strFilter As String, _
    strIniFile As String, _
    strTitleDlg As String, _
    strDefExt As String, _
    strCurDir As String) As String
Dim Flag As Boolean
     'Заполним структуру перед вызовом GetOpenFileName
     With OFNAME
         .lStructSize = Len(OFNAME) 'Размер структуры в байтах
         .hwndOwner = hWnd 'Указатель окна
         .lpstrFilter = strFilter 'Фильтр отбора
         .nFilterIndex = 1 'Индекс первой пары строк фильтра
         .lpstrFile = strIniFile  String$(512 - Len(strIniFile), 0) 'Полное имя файла
         .nMaxFile = 511 'Размер буфера файла
         .lpstrFileTitle = String$(512, 0) 'Только имя файла окна
         .nMaxFileTitle = 511 'Размер буфера заголовка
         .lpstrTitle = strTitleDlg 'Заголовок окна диалога
         .flags = OFN_FILEMUSTEXIST 'Типы читаемых файлов
         .lpstrDefExt = strDefExt 'Расширение файла по умолчанию
         .lpstrInitialDir = strCurDir 'Каталог файлов по умолчанию
         .hInstance = 0 'Идентификатор блока данных для OFN_ENABLETEMPLATE
         .lpstrCustomFilter = 0 'Дополнительные фильтры, см. ниже
         .nMaxCustFilter = 0 'не менее 40, 0 - игнорируется
         .nFileOffset = 0 'Определяет смещение имени
         .nFileExtension = 0 'Определяет расширение
         .lCustData = 0 'Для собственных окон
         .lpfnHook = 0 'Указатель на функцию фильтра
         .lpTemplateName = 0 'Собственный диалог
         '*** Старт
         'If GetOpenFileName(OFNAME) = True Then  'Win 98 Попробуйте такой вариант
         Flag = GetOpenFileName(OFNAME) 'Общий случай
         If Flag Then  'Открываем диалог и находим имя файла
              funGetOpenFileName = Left(.lpstrFile, InStr(.lpstrFile, Chr(0)) - 1)
         Else
              funGetOpenFileName = ""
         End If
    End With
End Function

'==============================================================
'   Назначение
'        Открытие окна диалога файлов
'   Параметры:
'        strFilter - строка фильтра
'        strIniFile - файл инициализации
'        strTitleDlg - заголовок окна
'        strDefExt - расширение по умолчанию
'        strCurDir - текущая папка
'
Public Function funGetSaveFileName( _
    hWnd As Long, _
    strFilter As String, _
    strIniFile As String, _
    strTitleDlg As String, _
    strDefExt As String, _
    strCurDir As String) As String
Dim Flag As Boolean
     'Заполним структуру перед вызовом GetOpenFileName
     With OFNAME
         .lStructSize = Len(OFNAME) 'Размер структуры в байтах
         .hwndOwner = hWnd 'Указатель окна
         .lpstrFilter = strFilter 'Фильтр отбора
         .nFilterIndex = 1 'Индекс первой пары строк фильтра
         .lpstrFile = strIniFile  String$(512 - Len(strIniFile), 0) 'Полное имя файла
         .nMaxFile = 511 'Размер буфера файла
         .lpstrFileTitle = String$(512, 0) 'Только имя файла окна
         .nMaxFileTitle = 511 'Размер буфера заголовка
         .lpstrTitle = strTitleDlg 'Заголовок окна диалога
         .flags = OFN_FILEMUSTEXIST 'Типы читаемых файлов
         .lpstrDefExt = strDefExt 'Расширение файла по умолчанию
         .lpstrInitialDir = strCurDir 'Каталог файлов по умолчанию
         .hInstance = 0 'Идентификатор блока данных для OFN_ENABLETEMPLATE
         .lpstrCustomFilter = 0 'Дополнительные фильтры, см. ниже
         .nMaxCustFilter = 0 'не менее 40, 0 - игнорируется
         .nFileOffset = 0 'Определяет смещение имени
         .nFileExtension = 0 'Определяет расширение
         .lCustData = 0 'Для собственных окон
         .lpfnHook = 0 'Указатель на функцию фильтра
         .lpTemplateName = 0 'Собственный диалог
         '*** Старт
         'If GetOpenFileName(OFNAME) = True Then  'Win 98 Попробуйте такой вариант
         Flag = GetSaveFileName(OFNAME) 'Общий случай
         If Flag Then  'Открываем диалог и находим имя файла
              funGetSaveFileName = Left(.lpstrFile, InStr(.lpstrFile, Chr(0)) - 1)
         Else
              funGetSaveFileName = ""
         End If
    End With
End Function