MaximoAccess

Caro Usuário, antes de postar pela primeira vez, leia as regras do fórum.

https://www.maximoaccess.com/t48-regras-do-forum

Obrigado

Administração


Participe do fórum, é rápido e fácil

MaximoAccess

Caro Usuário, antes de postar pela primeira vez, leia as regras do fórum.

https://www.maximoaccess.com/t48-regras-do-forum

Obrigado

Administração

MaximoAccess

Gostaria de reagir a esta mensagem? Crie uma conta em poucos cliques ou inicie sessão para continuar.

Dicas Ms Access, Exemplos Ms Access, Codigos VBA Ms Access, SQL Ms Access


    [Resolvido]Dúvidas com imagem

    Mylton
    Mylton
    VIP
    VIP


    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 1014
    Registrado : 23/08/2010

    [Resolvido]Dúvidas com imagem Empty [Resolvido]Dúvidas com imagem

    Mensagem  Mylton 15/6/2016, 13:25

    Bom dia a todos.
    nesta aplicação que retirei do forum utter access, mostra uma aplicação voltada para recolher uma assinatura em tablet e/ou monitor touch captando a assinatura para um relatório.
    Copiei o form principal e troquei a imagem da esquerda por outra com igual nome e formato bmp.
    Todavia a mesma não abre, permanecendo a formatação original.

    Alguem poderia explicar como tento abrir com a figura que escolhi?

    Abaixo código do form...

    Private Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long
    Option Compare Database
    Option Explicit
    ' Our PictureBox class
    Private pb As clsPictureBox
    ' For scaling function
    Private ScaleAmt As Single
    Private Type POINTAPI
    x As Long
    y As Long
    End Type

    Private Sub Box45_Click()
    colorpickerColor = 0
    'DoCmd.ShowAllRecords
    pb.ForeColor = colorpickerColor
    colorpickerColor.BackColor = colorpickerColor
    End Sub

    Private Sub Box46_Click()
    colorpickerColor = 255
    'DoCmd.ShowAllRecords
    pb.ForeColor = colorpickerColor
    colorpickerColor.BackColor = colorpickerColor
    End Sub

    Private Sub Box47_Click()
    colorpickerColor = 65535
    'DoCmd.ShowAllRecords
    pb.ForeColor = colorpickerColor
    colorpickerColor.BackColor = colorpickerColor
    End Sub

    Private Sub Box48_Click()
    colorpickerColor = 16711680
    'DoCmd.ShowAllRecords
    pb.ForeColor = colorpickerColor
    colorpickerColor.BackColor = colorpickerColor
    End Sub

    Private Sub Box49_Click()
    colorpickerColor = 65280
    'DoCmd.ShowAllRecords
    pb.ForeColor = colorpickerColor
    colorpickerColor.BackColor = colorpickerColor
    End Sub

    Private Sub Box50_Click()
    colorpickerColor = 16777215
    'DoCmd.ShowAllRecords
    pb.ForeColor = colorpickerColor
    colorpickerColor.BackColor = colorpickerColor
    End Sub

    Private Sub colorpicker_GotFocus()
    colorpicker.Dropdown
    End Sub

    Private Sub Command217_Click()
    DoCmd.OpenForm "MouseActivator"
    'Command3.Visible True
    End Sub

    Private Sub Command44_Click()
    DoCmd.Close
    'DoCmd.OpenForm "NARRATIVEADDER"
    End Sub

    Private Sub Command63_Click()
    colorpicker = 4
    Refresh
    pb.DrawWidth = colorpicker
    End Sub

    Private Sub Command64_Click()
    colorpicker = 6
    Refresh
    pb.DrawWidth = colorpicker
    End Sub

    Private Sub Command65_Click()
    colorpicker = 10
    Refresh
    pb.DrawWidth = colorpicker
    End Sub

    Private Sub Command66_Click()
    colorpicker = 13
    Refresh
    pb.DrawWidth = colorpicker
    End Sub

    Private Sub Command67_Click()
    colorpicker = 16
    Refresh
    pb.DrawWidth = colorpicker
    End Sub

    Private Sub Command68_Click()
    colorpicker = 20
    Refresh
    pb.DrawWidth = colorpicker
    End Sub

    Private Sub Command69_Click()
    DoCmd.OpenForm "imagechooser"
    End Sub

    Private Sub Command71_Click()
    colorpicker = 3
    Refresh
    pb.DrawWidth = colorpicker
    End Sub

    Private Sub Command72_Click()
    pb.OutputTextMulti date & ";" & TIME
    End Sub

    Private Sub Form_Resize()
    Dim emrx
    emrx = DLookup("[netpat]", "Localpathq")
    [shortdesc] = [Patidnum] & "\SOAPGr\" & DatePart("m", Now) & "-" & DatePart("d", Now) & "-" & DatePart("yyyy", Now) & "-" & DatePart("h", Now) & "-" & DatePart("n", Now) & "-" & DatePart("s", Now)
    ImageSaver = emrx & "pictures\" & [Patidnum] & "\SOAPGr\" & DatePart("m", Now) & "-" & DatePart("d", Now) & "-" & DatePart("yyyy", Now) & "-" & DatePart("h", Now) & "-" & DatePart("n", Now) & "-" & DatePart("s", Now)
    Refresh
    On Error GoTo ErrHandler
    Dim fso1, fldr
    Set fso1 = CreateObject("Scripting.FileSystemObject")
    Set fldr = fso1.CreateFolder(emrx & "pictures\" & [Patidnum] & "\SOAPGr")
    Exit_Sub:
    Exit Sub
    ErrHandler:
    'MsgBox "You already have a folder created"
    Resume Exit_Sub
    End Sub

    Private Sub cmdCopyClip_Click()
    pb.PictureDataToClipBoard
    End Sub

    Private Sub cmdLoad_Click()
    ' Load an Image
    pb.LoadImageControl
    End Sub

    Private Sub cmdReset_Click()
    ' Reset buffers to size of Image control
    Me.Image0.Picture = ""
    DoEvents
    pb.Create True, True
    pb.OutputText ""
    End Sub

    Private Sub cmdSave_Click()
    On Error GoTo ErrHandler
    Dim fso1, fldr
    Set fso1 = CreateObject("Scripting.FileSystemObject")
    Set fldr = fso1.CreateFolder([ImageSaver])
    ' Save to a disk based Bitmap file
    Refresh
    pb.SavetoFile
    Dim fs
    Set fs = CreateObject("Scripting.FileSystemObject")
    Dim lp
    Dim pate
    pate = CurrentDBDir
    lp = pate & "onfile\test.jpg"
    Dim fp
    'fp = "C:\qnotex\picture\" & [Patidnum] & "\"
    Dim np
    np = DLookup("[timestampid]", "SoapSave")
    fs.moveFile lp, ImageSaver & "\" & np & ".jpg"
    'fs.copyfile lp & filex, fp & np
    'DoCmd.OpenQuery "image2up"
    'DoCmd.OpenQuery "addimagesx2"
    DoCmd.SetWarnings True
    'DoCmd.Close
    'DoCmd.Close acForm, "soapsaverpop"
    'DoCmd.OpenForm "soapsaverpop"
    Exit_Sub:
    Exit Sub
    ErrHandler:
    MsgBox "This may not be set up right!", vbCritical, "FastSoap"
    DoCmd.SetWarnings True
    Resume Exit_Sub
    End Sub

    Private Sub cmdSaveToBuffer_Click()
    ' Hey I'm not kidding!
    ' This sub does nothing!
    ' :-)
    End Sub

    Private Sub colorpicker_AfterUpdate()
    Refresh
    pb.DrawWidth = colorpicker
    End Sub

    Private Sub colorpickerColor_Click()
    colorpickerColor = ShowColorDialog(pb.ForeColor)
    pb.ForeColor = colorpickerColor
    colorpickerColor.BackColor = colorpickerColor
    End Sub

    Private Sub Form_Current()
    colorpickerColor.BackColor = colorpickerColor
    pb.OutputTextMulti IIf(timestampdef = True, date & ";" & TIME, "")
    End Sub

    Private Sub Form_Load()
    [computerx] = ComputerName_FX
    'Dim pttx
    'pttx = DLookup("pnum", "dater")
    'Patidnum = pttx

    'DoCmd.Maximize
    'Notes = Null
    Refresh
    'DoCmd.MoveSize 0, 0, 10500, 6350
    ' Realize an instance of our class
    Set pb = New clsPictureBox
    ' You MUST set the ImageControl prop
    pb.ImageControl = Me.Image0
    ' You MUST set the ImageForm prop
    pb.ImageForm = Me
    ' Clear the Image control to FillColor
    pb.BackColor = 16777215
    'pb.ForeColor = 0
    colorpickerColor = 0
    pb.ForeColor = colorpickerColor

    ' Set Unbound Text control
    '"" = ""
    ' Set Rotation Degree
    'Me.txtRotate = 0
    ' Set our module Scale variable
    ScaleAmt = 1

    ' Draw some text
    pb.OutputText ""
    If pb.MouseDraw = True Then
    Me.CmdMouse.Caption = "Start Drawing with Mouse"
    pb.MouseDraw = False

    Else
    Me.CmdMouse.Caption = "STOP Drawing with Mouse"
    pb.MouseDraw = True

    End If
    'Caption = NAME1 & " " & StorageFolder
    colorpicker = 4
    Refresh
    pb.DrawWidth = colorpicker
    'pb.LoadImageControl
    End Sub

    Private Sub Form_Unload(Cancel As Integer)
    Set pb = Nothing
    End Sub

    Private Sub cmdBackColor_Click()
    pb.BackColor = ShowColorDialog(pb.BackColor)
    pb.OutputText ""
    End Sub

    Private Sub CmdSetForeColor_Click()
    'pb.ForeColor = ShowColorDialog(pb.ForeColor)
    pb.ForeColor = 255
    pb.OutputText ""
    End Sub

    Private Sub CmdClear_Click()
    pb.Clear
    End Sub

    Private Sub CmdText_Click()
    pb.OutputText ""
    End Sub

    Private Sub Image0_Click()
    Dim x As Integer
    x = 1
    End Sub

    Private Sub Image0_MouseDown(Button As Integer, shift As Integer, x As Single, y As Single)
    'pb.SavetoFile
    End Sub

    Private Function RndInt(Range As Integer) As Integer
    RndInt = Int(Rnd(1) * Range)
    End Function

    Private Sub CmdMouse_Click()
    If pb.MouseDraw = True Then
    Me.CmdMouse.Caption = "Start Drawing with Mouse"
    pb.MouseDraw = False
    Else
    Me.CmdMouse.Caption = "STOP Drawing with Mouse"
    pb.MouseDraw = True
    End If
    End Sub

    Function CurrentDBDir() As String
    Dim strDBPath As String
    Dim strDBFile As String
    strDBPath = CurrentDb.Name
    strDBFile = Dir(strDBPath)
    CurrentDBDir = Left$(strDBPath, Len(strDBPath) - Len(strDBFile))
    End Function

    Private Sub Image80_Click()
    On Error Resume Next
    Dim blRet As Boolean
    blRet = ConvertReportToPDF("rptSign", vbNullString, _
    "Contract" & ".pdf", True, True, 0, "", "", 0, 0)
    End Sub
    'You can also specify a location to send it to down below.
    'blRet = ConvertReportToPDF("test", vbNullString, _
    '"C:\test" & "SNote" & ".pdf", False, True, 0, "", "", 0, 0)
    'the first true false will give you a popup to save it somewhere, the second one will open it to view.

    Private Sub OLEUnbound19_Click()
    On Error Resume Next
    Dim blRet As Boolean
    blRet = ConvertReportToPDF("test", vbNullString, _
    "Contract" & ".pdf", True, False, 0, "", "", 0, 0)
    End Sub



    Mylton
    Mylton
    VIP
    VIP


    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 1014
    Registrado : 23/08/2010

    [Resolvido]Dúvidas com imagem Empty Re: [Resolvido]Dúvidas com imagem

    Mensagem  Mylton 15/6/2016, 19:47

    Reparei que existe um tópico já aberto semelhante a esse.
    vou finalizar e concentrar por lá.
    Obrigado

      Data/hora atual: 17/5/2024, 10:49