Intro: the program below refers to a userform program that pops up with empty fields to be filled 5x left and 5x right
then u can 1. save it and it fills an excel tab (e.g.: client database-tab)
2. delete details (deletes userform - user starts filling it again)
3. print pdf details (printed details-tab)
4. close page
The program GUI is a mechanics (auto-shop company) which takes in name, address (on left side) car details, make, plate, engine, fuel type etc.
Module 1 CODE -------------------------------------------------------------------------------------------------------
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function GetTempPath Lib "KERNEL32" Alias "GetTempPathA" (ByVal nBufferLength As LongLong, ByVal lpBuffer As String) As LongLong
#Else
// problem #1 - I keep getting error here (i tried removing "PtrSafe" but it said ... update 64bit systems) line is all red
Private Declare PrtSafe Function GetTempPath Lib "KERNEL32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
#End If
Const MAX_PATH = 260
Public strText As String
Public blnNew As Boolean
Public strFile As String
Public Function prTmpPath()
Dim sFolder As String ' Name of the folder
Dim lRet As Long ' Return Value
sFolder = String(MAX_PATH, 0)
lRet = GetTempPath(MAX_PATH, sFolder)
If lRet <> 0 Then
prTmpPath = Left(sFolder, InStr(sFolder, _
Chr(0)) - 1)
Else
prTmpPath = vbNullString
End If
End Function
**********************************************************************************
Module 2 CODE -------------------------------------------------------------------------------------------------------
Option Explicit
Private Type GUID
Data1 As LongLong
Data2 As Integer
Data3 As Integer
Data4(8) As Byte
End Type
Private Type PICTDESC
cbSize As LongLong
picType As LongLong
hImage As LongLong
End Type
#If VBA7 Then // the declarations before used to be a problem but i added PtrSafe - we're all good here
Private Declare PtrSafe Function OpenClipboard& Lib "user32" (ByVal hwnd&)
Private Declare PtrSafe Function EmptyClipboard& Lib "user32" ()
Private Declare PtrSafe Function GetClipboardData& Lib "user32" (ByVal wFormat%)
Private Declare PtrSafe Function SetClipboardData& Lib "user32" (ByVal wFormat&, ByVal hMem&)
Private Declare PtrSafe Function CloseClipboard& Lib "user32" ()
Private Declare PtrSafe Function CopyImage& Lib "user32" (ByVal handle&, ByVal un1&, ByVal n1&, ByVal n2&)
Private Declare PtrSafe Function IIDFromString Lib "ole32" (ByVal lpsz As String, ByRef lpiid As GUID) As LongLong
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "olepro32" (pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As LongLong, ByRef ppvObj As IPicture) As LongLong
Private Declare PtrSafe Function DestroyIcon& Lib "user32" (ByVal hIcon&)
#Else
// problem #2 - this declarations below only work if i leave the "PrtSafe" there BUT I already have up to convert it to 4bit so, it shouldn't be needed here right, but IF I take it away, the message about .. update 64bit systems pop up, so I left it here.
Private Declare PtrSafe Function OpenClipboard& Lib "user32" (ByVal hwnd&)
Private Declare PtrSafe Function EmptyClipboard& Lib "user32" ()
Private Declare PtrSafe Function GetClipboardData& Lib "user32" (ByVal wFormat%)
Private Declare PtrSafe Function SetClipboardData& Lib "user32" (ByVal wFormat&, ByVal hMem&)
Private Declare PtrSafe Function CloseClipboard& Lib "user32" ()
Private Declare PtrSafe Function CopyImage& Lib "user32" (ByVal handle&, ByVal un1&, ByVal n1&, ByVal n2&)
Private Declare PtrSafe Function IIDFromString Lib "ole32" (ByVal lpsz As String, ByRef lpiid As GUID) As Long
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "olepro32" (pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long, ByRef ppvObj As IPicture) As Long
Private Declare PtrSafe Function DestroyIcon& Lib "user32" (ByVal hIcon&)
#End If
Public Sub prImage2Print()
Dim hCopy&: OpenClipboard 0&
hCopy = CopyImage(GetClipboardData(2), 0, 0, 0, &H4)
CloseClipboard
If hCopy = 0 Then Exit Sub
Const IPictureIID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
Dim iPic As IPicture, tIID As GUID, tPICTDEST As PICTDESC, Ret&
Ret = IIDFromString(StrConv(IPictureIID, vbUnicode), tIID)
If Ret Then Exit Sub
With tPICTDEST
.cbSize = Len(tPICTDEST)
.picType = 1
.hImage = hCopy
End With
Ret = OleCreatePictureIndirect(tPICTDEST, tIID, 1, iPic)
If Ret Then Exit Sub
SavePicture iPic, prTmpPath & "outputImage.jpg"
Set iPic = Nothing
End Sub
// problem #3 - if I leave everything above as it is, this variable IIDFromString alerts as mismatch which it shouldn't, because the code here is correct (before updating things to 64bit) so I dont know why? (remember in a 32bit program it works fine but, I got excel2016 so I've been updating the variable and declarations, reserved words etc (u know the drill)
Public Sub prClipboardData2Image() // this is Line 61 on vba-dev mode
Dim hCopy&: OpenClipboard 0&
hCopy = CopyImage(GetClipboardData(2), 0, 0, 0, &H4)
CloseClipboard
If hCopy = 0 Then Exit Sub
Const IPictureIID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
Dim iPic As IPicture, tIID As GUID, tPICTDEST As PICTDESC, Ret&
Ret = IIDFromString(StrConv(IPictureIID, vbUnicode), tIID) // <- error here, flashes yellow here: (Line 61)
If Ret Then Exit Sub
With tPICTDEST
.cbSize = Len(tPICTDEST)
.picType = 1
.hImage = hCopy
End With
Ret = OleCreatePictureIndirect(tPICTDEST, tIID, 1, iPic)
If Ret Then Exit Sub
frmEmpDetails.imgEmp.Picture = LoadPicture("")
frmEmpDetails.imgEmp.Picture = iPic
Set iPic = Nothing
End Sub
--------------------------------------- end of program ---------------------------------
Many thanks in advance
Mr Costa
then u can 1. save it and it fills an excel tab (e.g.: client database-tab)
2. delete details (deletes userform - user starts filling it again)
3. print pdf details (printed details-tab)
4. close page
The program GUI is a mechanics (auto-shop company) which takes in name, address (on left side) car details, make, plate, engine, fuel type etc.
Module 1 CODE -------------------------------------------------------------------------------------------------------
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function GetTempPath Lib "KERNEL32" Alias "GetTempPathA" (ByVal nBufferLength As LongLong, ByVal lpBuffer As String) As LongLong
#Else
// problem #1 - I keep getting error here (i tried removing "PtrSafe" but it said ... update 64bit systems) line is all red
Private Declare PrtSafe Function GetTempPath Lib "KERNEL32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
#End If
Const MAX_PATH = 260
Public strText As String
Public blnNew As Boolean
Public strFile As String
Public Function prTmpPath()
Dim sFolder As String ' Name of the folder
Dim lRet As Long ' Return Value
sFolder = String(MAX_PATH, 0)
lRet = GetTempPath(MAX_PATH, sFolder)
If lRet <> 0 Then
prTmpPath = Left(sFolder, InStr(sFolder, _
Chr(0)) - 1)
Else
prTmpPath = vbNullString
End If
End Function
**********************************************************************************
Module 2 CODE -------------------------------------------------------------------------------------------------------
Option Explicit
Private Type GUID
Data1 As LongLong
Data2 As Integer
Data3 As Integer
Data4(8) As Byte
End Type
Private Type PICTDESC
cbSize As LongLong
picType As LongLong
hImage As LongLong
End Type
#If VBA7 Then // the declarations before used to be a problem but i added PtrSafe - we're all good here
Private Declare PtrSafe Function OpenClipboard& Lib "user32" (ByVal hwnd&)
Private Declare PtrSafe Function EmptyClipboard& Lib "user32" ()
Private Declare PtrSafe Function GetClipboardData& Lib "user32" (ByVal wFormat%)
Private Declare PtrSafe Function SetClipboardData& Lib "user32" (ByVal wFormat&, ByVal hMem&)
Private Declare PtrSafe Function CloseClipboard& Lib "user32" ()
Private Declare PtrSafe Function CopyImage& Lib "user32" (ByVal handle&, ByVal un1&, ByVal n1&, ByVal n2&)
Private Declare PtrSafe Function IIDFromString Lib "ole32" (ByVal lpsz As String, ByRef lpiid As GUID) As LongLong
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "olepro32" (pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As LongLong, ByRef ppvObj As IPicture) As LongLong
Private Declare PtrSafe Function DestroyIcon& Lib "user32" (ByVal hIcon&)
#Else
// problem #2 - this declarations below only work if i leave the "PrtSafe" there BUT I already have up to convert it to 4bit so, it shouldn't be needed here right, but IF I take it away, the message about .. update 64bit systems pop up, so I left it here.
Private Declare PtrSafe Function OpenClipboard& Lib "user32" (ByVal hwnd&)
Private Declare PtrSafe Function EmptyClipboard& Lib "user32" ()
Private Declare PtrSafe Function GetClipboardData& Lib "user32" (ByVal wFormat%)
Private Declare PtrSafe Function SetClipboardData& Lib "user32" (ByVal wFormat&, ByVal hMem&)
Private Declare PtrSafe Function CloseClipboard& Lib "user32" ()
Private Declare PtrSafe Function CopyImage& Lib "user32" (ByVal handle&, ByVal un1&, ByVal n1&, ByVal n2&)
Private Declare PtrSafe Function IIDFromString Lib "ole32" (ByVal lpsz As String, ByRef lpiid As GUID) As Long
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "olepro32" (pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long, ByRef ppvObj As IPicture) As Long
Private Declare PtrSafe Function DestroyIcon& Lib "user32" (ByVal hIcon&)
#End If
Public Sub prImage2Print()
Dim hCopy&: OpenClipboard 0&
hCopy = CopyImage(GetClipboardData(2), 0, 0, 0, &H4)
CloseClipboard
If hCopy = 0 Then Exit Sub
Const IPictureIID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
Dim iPic As IPicture, tIID As GUID, tPICTDEST As PICTDESC, Ret&
Ret = IIDFromString(StrConv(IPictureIID, vbUnicode), tIID)
If Ret Then Exit Sub
With tPICTDEST
.cbSize = Len(tPICTDEST)
.picType = 1
.hImage = hCopy
End With
Ret = OleCreatePictureIndirect(tPICTDEST, tIID, 1, iPic)
If Ret Then Exit Sub
SavePicture iPic, prTmpPath & "outputImage.jpg"
Set iPic = Nothing
End Sub
// problem #3 - if I leave everything above as it is, this variable IIDFromString alerts as mismatch which it shouldn't, because the code here is correct (before updating things to 64bit) so I dont know why? (remember in a 32bit program it works fine but, I got excel2016 so I've been updating the variable and declarations, reserved words etc (u know the drill)
Public Sub prClipboardData2Image() // this is Line 61 on vba-dev mode
Dim hCopy&: OpenClipboard 0&
hCopy = CopyImage(GetClipboardData(2), 0, 0, 0, &H4)
CloseClipboard
If hCopy = 0 Then Exit Sub
Const IPictureIID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
Dim iPic As IPicture, tIID As GUID, tPICTDEST As PICTDESC, Ret&
Ret = IIDFromString(StrConv(IPictureIID, vbUnicode), tIID) // <- error here, flashes yellow here: (Line 61)
If Ret Then Exit Sub
With tPICTDEST
.cbSize = Len(tPICTDEST)
.picType = 1
.hImage = hCopy
End With
Ret = OleCreatePictureIndirect(tPICTDEST, tIID, 1, iPic)
If Ret Then Exit Sub
frmEmpDetails.imgEmp.Picture = LoadPicture("")
frmEmpDetails.imgEmp.Picture = iPic
Set iPic = Nothing
End Sub
--------------------------------------- end of program ---------------------------------
Many thanks in advance
Mr Costa