Saving a graphic file as a BMP from the clipboard.

[bigdavidt]

Good morning. I am working on an application that will take a graphic file that is copied to the clipboard and save it as a bitmap file. After I came up with this code I figured out how to add a line that determines what the default folder is, but I do not know how to determine the default file extension.

Thank you in advance for your help.


Option Compare Database

Private Declare Sub keybd_event Lib "User32" (ByVal bVk As Byte, ByVal _
bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, _
RefIID As Guid, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "User32" (ByVal wFormat As Long) As Long
Private Declare Function CloseClipboard Lib "User32" () As Long
Private Declare Function EmptyClipboard Lib "User32" () As Long
Private Const VK_MENU = &H12
Private Const VK_SNAPSHOT = &H2C
Private Const KEYEVENTF_KEYUP = &H2
Private Const CF_BITMAP = 2
Private Type PicBmp
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type
Private Type Guid
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type

Public Function SaveBitmap() As String
On Error GoTo errorEncountered

Dim Pic As PicBmp, IPic As IPicture, IID_IDispatch As Guid, strFileName As String
Dim theCnt As Integer, theMsg As String

Dim fDialog As Office.FileDialog

strFileName = ""

' Set up the File Dialog.
Set fDialog = Application.FileDialog(msoFileDialogSaveAs)

theCnt = 0

'startOver:
' theCnt = theCnt + 1
' keybd_event VK_MENU, 0, 0, 0 'press Alt
' keybd_event VK_SNAPSHOT, 0, 0, 0 'press PrintScrnOffice.FileDialog

' keybd_event VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0 'release it
' keybd_event VK_MENU, 0, KEYEVENTF_KEYUP, 0 'release it
' DoEvents

With fDialog
' Allow user to make multiple selections in dialog box
.AllowMultiSelect = False

' 'Add a filter that includes GIF and JPEG images and make it the second item in the list.
' .Filters.Add "Images", "*.bmp", 2

' 'Sets the initial file filter to number 2.
' .FilterIndex = 2

' Set the title of the dialog box.
.title = "Please give your file a name."


' Show the dialog box. If the .Show method returns True, the
' user picked at least one file. If the .Show method returns
' False, the user clicked Cancel.
If .Show = True Then
strFileName = .SelectedItems(1)

With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With

With Pic
Call OpenClipboard(0&)
.Size = Len(Pic)
.Type = 1
.hBmp = GetClipboardData(CF_BITMAP)
End With

OleCreatePictureIndirect Pic, IID_IDispatch, 1, IPic ' Create the picture object

If theCnt = 1 Then
theMsg = MsgBox("Click ok to save the file.", vbOKOnly + vbInformation)
DoEvents
'If theMsg = 1 Then GoTo startOver
End If

stdole.SavePicture IPic, strFileName ' Save the file
Else
MsgBox "You clicked Cancel in the file dialog box."
End If
End With

SaveBitmap = strFileName

Exit Function

errorEncountered:
If Err.Number <> 0 Then
Call LogError(Err.Number, Err.description, "SaveBitmap")
End If

Call EmptyClipboard ' Empty the clipboard
Call CloseClipboard ' Close the clipboard
End Function




Private Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "User32" () As Long
Private Declare Function EmptyClipboard Lib "User32" () As Long

Private Sub AddGraphicFileButton_Click()
On Error GoTo Err_SomeName

Dim fDialog As Office.FileDialog
Dim varFile As Variant
Dim Source As String
Dim sField As String
Dim db As Database
Dim rs As Recordset
Dim FileLength As Long
Dim CNCProgramID As Long

Set db = CurrentDb

Set rs = db.OpenRecordset("SELECT GraphicLocation FROM CNCProgrammingSheetQuery WHERE CNCProgramID = " & Me.CNCProgramID.value, dbOpenDynaset)

Source = SaveBitmap()

If Len(Trim(Source)) > 0 And rs.RecordCount = 1 Then
rs.MoveFirst
rs.Edit
rs!GraphicLocation = Source
rs.Update
End If

rs.Close
Set rs = Nothing

Call OpenClipboard(0&)
EmptyClipboard
CloseClipboard

Me.Refresh

Exit Sub

Err_SomeName:
'Any unexpected error.
Call LogError(Err.Number, Err.description, "CNCProgrammingSheetForm.AddGraphicFileButton_Click")
Resume Next
End Sub

 

[Andrzejek]

That's just my opinion, but very few people will be willing to decipher your code when you do not use TGML tags to show your code:

See how much easier it is to see your logic?

With fDialog[green]
    ...
    ' Show the dialog box. If the .Show method returns True, the
    ' user picked at least one file. If the .Show method returns
    ' False, the user clicked Cancel.[/green]
    If .Show = True Then
        strFileName = .SelectedItems(1)
        
        With IID_IDispatch
            .Data1 = &H20400
            .Data4(0) = &HC0
            .Data4(7) = &H46
        End With
    
        With Pic
        Call OpenClipboard(0&)
            .Size = Len(Pic)
            .Type = 1
            .hBmp = GetClipboardData(CF_BITMAP)
        End With
    
        OleCreatePictureIndirect Pic, IID_IDispatch, 1, IPic [green]' Create the picture object[/green]
    
        If theCnt = 1 Then
            theMsg = MsgBox("Click ok to save the file.", vbOKOnly + vbInformation)
            DoEvents[green]
            'If theMsg = 1 Then GoTo startOver[/green]
        End If
    
        stdole.SavePicture IPic, strFileName ' Save the file
     Else
        MsgBox "You clicked Cancel in the file dialog box."
     End If
 End With

 SaveBitmap = strFileName

---- Andy

There is a great need for a sarcasm font.