Option Explicit
Declare Function CharToOem Lib "user32" Alias "CharToOemA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long

' ZVI:2009-01-20 http://www.sql.ru/forum/actualthread.aspx?tid=631075
' Перекодировка DBF из Windows-1251 в DOS-866 для работы в Excel
Sub Dbf_Win2Rus()
  Dim FN%, s$, ptrType&, ptrData&, b() As Byte, FileName
  On Error GoTo exit_
  ' Выбрать DBF файл
  ChDrive Mid(ThisWorkbook.Path,  1 ,  1 )
  ChDir ThisWorkbook.Path & "\"
  FileName = Application.GetOpenFilename("DBF File (*.dbf), *.dbf", , _
            "DBF Win2Dos")
  If FileName = False Then GoTo exit_
  ' Открыть DBF файл
  FN = FreeFile
  Open FileName For Binary Access Read Write As #FN
  ' Считать все в байтовый массив
  ReDim b( 0  To LOF(FN) -  1 )
  Get #FN, , b
  ' Проверить флаг перекодировки для исключения двойной
  If CInt(b( 29 )) =  38  Then
    If MsgBox("DOS-кодировка уже установлена," & vbLf _
             & "Все равно продолжить?", _
             vbExclamation + vbOKCancel + vbDefaultButton2, _
             "Не навреди!") <> vbOK Then
      GoTo exit_
    End If
  End If
  ' Установить указатель на начало данных
  ptrData = b( 9 ) *  256  + b( 8 ) +  1 
  ' Считать данные в Unicode
  s = StrConv(MidB(b, ptrData), vbUnicode)
  ' Перекодировать данные в DOS-866
  ReDim b( 0  To Len(s) -  1 )
  b = StrConv(Win2Dos(s), vbFromUnicode)
  ' Переписать данные в DBF
  Put #FN, ptrData, b
  ' Установить флаг DOS-866 в DBF
  Put #FN,  30 ,  38 
exit_:
  Close #FN
  If Err <>  0  Then
    Debug.Print "Error: " & Err.Number & " - " & Err.Description
  Else
    MsgBox "Преобразовано успешно!", vbInformation, "DBF Win2Dos"
  End If
End Sub

Private Function Win2Dos(ByVal sWin As String) As String
  Win2Dos = String(Len(sWin), Chr( 0 ))
  Call CharToOem(sWin, Win2Dos)
End Function