ActiveX

Листинг для Урока 2

ActiveX Control "DosWin"

Option Explicit

'*****************************************************************
'Объявление API-функций
'*****************************************************************
Private Declare Function CharToOem Lib "user32" Alias "CharToOemA" _
(ByVal lpszSrc As String, ByVal lpszDst As String) As Long
Private Declare Function OemToChar Lib "user32" Alias "OemToCharA" _
(ByVal lpszSrc As String, ByVal lpszDst As String) As Long
Private Declare Function GetACP Lib "kernel32" () As Long
Private Declare Function GetOEMCP Lib "kernel32" () As Long

'*****************************************************************
'Методы
'*****************************************************************
Public Sub ConvertToDOS(PathStartingFile As String, PathConvertedFile As String)
Dim InputStr$, OutputStr$, NewFile$
Dim Code&
If Verification = True Then Exit Sub
On Error GoTo ErrDOSWin
Open PathStartingFile For Input As #1
Do While Not EOF(1)
Line Input #1, InputStr
OutputStr = Space$(Len(InputStr))
Code = CharToOem(InputStr, OutputStr)
NewFile = NewFile & OutputStr & vbCrLf
Loop
Close #1

Dim F%
F = FreeFile
Open PathConvertedFile For Output As #F
Write #F, NewFile
Close #F
Exit Sub

ErrDOSWin:
MsgBox "<" & Err.Number & "> - " & Err.Description
End Sub

Public Sub ConvertToWin(PathStartingFile As String, PathConvertedFile As String)
Dim InputStr$, OutputStr$, NewFile$
Dim Code&
If Verification = True Then Exit Sub
On Error GoTo ErrWinDOS
Open PathStartingFile For Input As #1
Do While Not EOF(1)
Line Input #1, InputStr
OutputStr = Space$(Len(InputStr))
Code = OemToChar(InputStr, OutputStr)
NewFile = NewFile & OutputStr & vbCrLf
Loop
Close #1

Dim F%
F = FreeFile
Open PathConvertedFile For Output As #F
Write #F, NewFile
Close #F
Exit Sub

ErrWinDOS:
MsgBox "<" & Err.Number & "> - " & Err.Description
End Sub

Public Sub About()
frmAbout.Show vbModal
End Sub

'*****************************************************************
'Обработка событий UserControl'a
'*****************************************************************
Private Sub UserControl_Resize()
UserControl.Size Image1.Width, Image1.Height
End Sub

'*****************************************************************
'Внутренние функции
'*****************************************************************
Private Function Verification() As Boolean
Dim OemCP&, AnsiCP&
OemCP = GetOEMCP
AnsiCP = GetACP
If OemCP <> 866 Or AnsiCP <> 1251 Then
MsgBox "Несоответствие кодовых таблиц", vbExclamation + vbOKOnly, "Ошибка!"
Verification = True
Exit Function
End If
Verification = False
End Function

К статье