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
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