Private Sub cmdOk_Click()
Dim rsFotos As New ADODB.Recordset, Fichero, size As Long
Dim fragment As Long
Dim Chunks
Dim varChunk() As Byte
Dim objFile As Object
Set objFile = CreateObject("Scripting.FileSystemObject")
On Error GoTo Control_errores
If txtFolder.Text = "" Then
MsgBox "Tiene que seleccionar donde quiere que se guarden las fotos", , "CM Image Creator"
Exit Sub
End If
cmdOk.Enabled = False
strSql = "SELECT * FROM ShapeIcons"
rsFotos.Open strSql, "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\Documents and Settings\rgarcia\Desktop\Copy of iconosDFD.mdb;Persist Security Info=False", 3, 1
If rsFotos.EOF Then
MsgBox "No se han encontrado fotos en la base de datos", , "CM Image Creator"
Else
DoEvents
End If
Do While Not rsFotos.EOF
Fichero = FreeFile
size = rsFotos!ShapeIcon.ActualSize
If size = 0 Then Exit Sub
Open txtFolder.Text & "\" & rsFotos("ShapeMasterId") & ".ico" For Binary Access Write As Fichero
Chunks = size \ 16384
fragment = size Mod 16384
ReDim varChunk(fragment)
varChunk() = rsFotos!ShapeIcon.GetChunk(fragment)
Put Fichero, , varChunk()
For i = 1 To Chunks
ReDim varChunk(16384)
varChunk() = rsFotos!ShapeIcon.GetChunk(16384)
Put Fichero, , varChunk()
DoEvents
Next i
Close Fichero
DoEvents
rsFotos.MoveNext
Loop
rsFotos.Close
Set rsFotos = Nothing
cmdSalir.Enabled = True
Control_errores:
If Err Then
MsgBox "Se ha producido un error. Consulte con el administrador." & Err.Number, , "CM Image Creator"
End If
End Sub