Zainteresovala me je tema :) (mozda si nasla Bug u MS VB bibliotekama ... ) a i da se odmorim od c++-a
Probao sam sa bmp slikom u koju sam na kraj dodao 128 * i fajlom od 128 bajtova koji ima nekoliko znakova koji su kod tebe problematicni i radi.
Slika koja se dobije moze da se otvori a * na kraju su zamenjene sadrzajem hex fajla.
Inace koriscen je Win API , kao sto se i vidi ...
poz
Code:
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const CREATE_NEW = 1
Private Const OPEN_EXISTING = 3
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const CREATE_ALWAYS = 2
Private Const INVALID_HANDLE_VALUE = -1
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Any) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, ByVal lpOverlapped As Any) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetFileSize Lib "kernel32" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long
Option Base 1 ' baza nizova je index 1 ... a ne 0
Private Function CopyHex(CrFile As String, InFile As String, OutFile As String) As Boolean
CopyHex = False
Dim hCr As Long, hIn As Long, hOut As Long
Dim CrBuffer() As Byte, InBuffer() As Byte, OutBuffer() As Byte
Dim bWrote As Long, bRead As Long
Dim fSz As Long, I As Long, n As Long, m As Long
'I
bRead = 0
hCr = CreateFile(CrFile, GENERIC_READ, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, 0, 0)
If hCr = INVALID_HANDLE_VALUE Then Debug.Print "Greska u otvaranju HEX fajla": Exit Function
fSz = GetFileSize(hCr, 0)
If fSz <> 128 Then Debug.Print "HEX fajl nema 128 bajtova": Exit Function
ReDim CrBuffer(fSz)
ReadFile hCr, CrBuffer(1), fSz, bRead, ByVal 0&
CloseHandle hCr
If bRead <> fSz Then Debug.Print "Greska u citanju fajla " & CrFile: Exit Function
'II
bRead = 0
hIn = CreateFile(InFile, GENERIC_READ, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, 0, 0)
If hIn = INVALID_HANDLE_VALUE Then Debug.Print "Greska u otvaranju fajla " & InFile: Exit Function
fSz = GetFileSize(hIn, 0)
If fSz = 0 Then Debug.Print "Greska u otvaranju fajla " & InFile: Exit Function
ReDim InBuffer(fSz)
ReadFile hIn, InBuffer(1), fSz, bRead, ByVal 0&
CloseHandle hIn
If bRead <> fSz Then Debug.Print "Greska u citanju fajla " & InFile: Exit Function
ReDim OutBuffer(fSz)
'Prepisujemo bajtove i nalazimo ***
n = 0: m = 0
For I = 1 To fSz
If I <= fSz - 127 And m = 0 Then
If InBuffer(I) = CByte(Asc("*")) And InBuffer(I + 127) = CByte(Asc("*")) Then ' mali trik :)
Dim b As Boolean
b = True
For n = I To I + 127
If Not Chr(InBuffer(I)) = "*" Then b = False
Next n
If b = True Then m = I
End If
End If
OutBuffer(I) = InBuffer(I)
Next I
If m = 0 Then Debug.Print "Nemamo niz ****": Exit Function
For I = m To m + 127
OutBuffer(I) = CrBuffer(I - m + 1)
Next I
'III
hOut = CreateFile(OutFile, GENERIC_WRITE, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, CREATE_ALWAYS, 0, 0)
If hOut = INVALID_HANDLE_VALUE Then Debug.Print "Greska u kreiranju fajla " & OutFile: Exit Function
WriteFile hOut, OutBuffer(1), fSz, bWrote, ByVal 0&
CloseHandle hOut
If fSz <> bWrote Then Debug.Print "Greska pri upisu u fajl " & OutFile: Exit Function
CopyHex = True
End Function
Private Sub Form_Load()
'CrFile je HEX fajl od 128 bajtova, InFile je fajl sa 128 * a OutFile je proizvod gde su zvezdice iz InFile zamenjena sadrzajem HEX fajla
Dim CrFile As String, InFile As String, OutFile As String
CrFile = "": InFile = "": OutFile = "" ' popuniti
If CopyHex(CrFile, InFile, OutFile) Then MsgBox "Ok"
End Sub
[Ovu poruku je menjao Eurora3D Team dana 28.08.2008. u 23:20 GMT+1]