Descargar

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

Descargar