Nombre: Guardar / Imprimir una imagen almacenada en mysql con la ayuda de VB
Descripción:
CREATE TABLE `fotopedido` (
`file_id` smallint(5) unsigned NOT NULL auto_increment,
`idempresa` varchar(10) default NULL,
`idorden` varchar(10) default NULL,
`file_name` varchar(64) NOT NULL,
`file_size` mediumint(8) unsigned NOT NULL,
`file` mediumblob NOT NULL,
PRIMARY KEY (`file_id`)
) ENGINE=InnoDB DEFAULT CHARSET=latin1;
URL: http://www.mygnet.net/codigos/mysql/graficacion/guardar_imprimir_una_imagen_almacenada_en_mysql_con_la_ayuda_de_vb.2461
Código Fuente:
Dim WithEvents RsFoto As ADODB.Recordset
Dim MyStream As ADODB.Stream
Dim xPath As String
Dim xNomFoto As String
Dim xNewPath As String
Dim rNew As Boolean
Dim rEdit As Boolean
Private Sub CmdCancelar_Click()
sBoton TRUE
END Sub
Private Sub CmdCerrar_Click()
RsFoto.Close
SET RsFoto = Nothing
Unload Me
END Sub
Private Sub CmdEliminar_Click()
On Error GoTo DeleteErr
If MsgBox("Realmente desea Eliminar el Registro Actual", vbExclamation + vbYesNo, "Eliminar Registro") = vbYes THEN
RsFoto.DELETE
RsFoto.UPDATE
Cargar
END If
Exit Sub
DeleteErr:
MsgBox Err.Description
END Sub
Private Sub CmdFoto_Click()
CDFoto.ShowOpen
xNewPath = ""
AbrirFoto TRIM(CDFoto.FileName)
END Sub
Function AbrirFoto(ByVal xCad As String)
If xCad <> "" THEN: PctFoto.Picture = LoadPicture(xCad): xNewPath = xCad
END Function
Private Sub CmdImprimir_Click()
'rutina creada por jair mamani calizaya
' el 27 de mayo del 2007
'despues de varios intentos ..
'jajajja bueno despues de varios intentos fallidos
'akki la rutina ke te sacara de problemas si kieres imprimir imagenes desde vb
'este codigo esta libre para ke los utilizen los amantes de vb
'aki el codigo:
'dibiertanse ----
'recomendable trabajar a una resolucion de 1024 x 768
Dim ImageLeft, ImageTop As Single
'enviamos un mensage para ke el cliente decida emprimir o no
If xPath = "" THEN Exit Sub
Answer = MsgBox("Imprimir Imagen .... " & Printer.DeviceName, vbYesNo)
If Answer = vbNo THEN Exit Sub
'We decide to measure in centimeters
Printer.ScaleMode = vbCentimeters
'inicializamos la impresion de imagen
'imprimimos la imagen ke deseemos
'cargamos la imagen en el picture box, desde el cual el sistema
'tomara los pixeles y el tamaño (en centimetros) de la imagen par luego procesarla
PctFoto.ScaleMode = vbCentimeters
PctFoto.Picture = LoadPicture(xPath)
PctFoto.AutoSize = True
PctFoto.Refresh
PctFoto.AutoSize = False
'la imagen se centrara de acuerdo a esta formula: (21 - Picture Width) / 2
ImageLeft = (21 - PctFoto.ScaleWidth) / 2
'imprimir a 1.5 centimetros del inicio de pagina
ImageTop = 1.5
'locolizamos la imagen para imprimir
Printer.ScaleMode = vbCentimeters
Printer.PaintPicture PctFoto.Picture, ImageLeft, ImageTop
'finalizamos el documento
Printer.EndDoc
End Sub
Private Sub CmdModificar_Click()
sBoton False
rNew = False
rEdit = True
End Sub
Private Sub CmdNuevo_Click()
sBoton False
rNew = True
rEdit = False
End Sub
Private Sub CmdSaveFoto_Click()
Dim xNI As String
If xNewPath = "" Then Exit Sub
If rNew Then
If RsFoto.RecordCount >= 1 Then RsFoto.MoveLast
RsFoto.AddNew
RsFoto!idorden = BDORDEN
RsFoto!idempresa = xEmpresa
End If
MyStream.Open
MyStream.LoadFromFile xNewPath
xNI = BDORDEN & Extension(xNewPath)
RsFoto!file_name = xNI
RsFoto!file_size = MyStream.Size
RsFoto!File = MyStream.Read
RsFoto.Update
MyStream.Close
sBoton True
Cargar
End Sub
Function Extension(ByVal xNP As String) As String
Dim Longitud As Integer
Dim xImg As String
Dim j As Integer
Longitud = Len(Trim(xNP))
xImg = StrReverse(xNP)
'MsgBox xImg
For j = 1 To Longitud
If MID(xImg, j, 1) = "." THEN
xExt = LEFT(xImg, j)
Exit For
END If
Next
Extension = StrReverse(xExt)
END Function
Private Sub Form_Load()
Cargar
END Sub
Sub Cargar()
SET RsFoto = New ADODB.Recordset
SET MyStream = New ADODB.Stream
MyStream.Type = adTypeBinary
LimpiarTxt
Consultar "fotopedido where idempresa='" & xEmpresa & "' and idorden='" & BDORDEN & "'", RsFoto
If RsFoto.RecordCount < 1 THEN
'no hay nada
Else 'mas de 1 registro
MostrarInfo
AbrirFoto xPath
END If
END Sub
Sub MostrarInfo()
Text1(0).TEXT = RsFoto!idorden 'idorden
Text1(1).Text = RsFoto!file_name 'nombre
xNomFoto = TRIM(RsFoto!file_name)
Text1(2).TEXT = RsFoto!file_size 'size
EscribirFoto xNomFoto
End Sub
Sub EscribirFoto(ByVal xNom As String)
MyStream.Open
MyStream.Write RsFoto!File
xPath = App.Path & "Fotos" & xNom
MyStream.SaveToFile xPath, adSaveCreateOverWrite
MyStream.Close
End Sub
Sub LimpiarTxt()
Dim i As Integer
For i = 0 To 2
Text1(i).Text = ""
Next i
PctFoto.Picture = LoadPicture(App.Path & "fotosb.bmp")
End Sub
Function sBoton(ByVal xW As Boolean)
Me.CmdSaveFoto.Visible = Not xW
Me.CmdCancelar.Visible = Not xW
Me.CmdFoto.Visible = Not xW
'Me.CmdImprimir.Enabled = NOT xW
Me.CmdCerrar.Visible = xW
Me.CmdEliminar.Visible = xW
Me.CmdModificar.Visible = xW
Me.CmdNuevo.Visible = xW
END Function
Private Sub Form_Resize()
Me.PctFoto.Width = Me.Width - 400
Me.PctFoto.Height = Me.Height - 400
END Sub