Page 2 of 2 FirstFirst 12
Results 11 to 13 of 13

Thread: Load UserForm InkPicture with Ink saved in Excel worksheet
Thanks Thanks: 0 Likes Likes: 0

  1. #11
    New Member
    Join Date
    Dec 2003
    Posts
    44
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Load UserForm InkPicture with Ink saved in Excel worksheet

    ok, thank you for your responses. I'll keep trying and if i find the solution, I'll post what I discover.

  2. #12
    Board Regular Jaafar Tribak's Avatar
    Join Date
    Dec 2002
    Location
    Larache--Morocco
    Posts
    7,353
    Post Thanks / Like
    Mentioned
    39 Post(s)
    Tagged
    3 Thread(s)

    Default Re: Load UserForm InkPicture with Ink saved in Excel worksheet

    Quote Originally Posted by zeus View Post
    ok, thank you for your responses. I'll keep trying and if i find the solution, I'll post what I discover.
    Stay tuned ... I'll post some code later when I get home.
    Office/Excel 2010 64Bits -- Win10 64Bits

    Common sense is not so common.


    http://photo-larache.blogspot.com/

  3. #13
    Board Regular Jaafar Tribak's Avatar
    Join Date
    Dec 2002
    Location
    Larache--Morocco
    Posts
    7,353
    Post Thanks / Like
    Mentioned
    39 Post(s)
    Tagged
    3 Thread(s)

    Default Re: Load UserForm InkPicture with Ink saved in Excel worksheet

    Ok- This worked for me but may need some tweaking .

    Workbook example

    Code goes in the UserForm Module :

    Code:
    Option Explicit
    
    Private Type uPicDesc
        Size As Long
        Type As Long
        #If  VBA7 Then
            hPic As LongPtr
            hPal As LongPtr
        #Else 
           hPic As Long
           hPal As Long
        #End  If
    End Type
    
    Private Type GUID
        Data1 As Long
        Data2 As Integer
        Data3 As Integer
        Data4(0 To 7) As Byte
    End Type
    
    
    #If  VBA7 Then
        
        Private Declare PtrSafe Function OleCreatePictureIndirectAut Lib "oleAut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
        Private Declare PtrSafe Function OleCreatePictureIndirectPro Lib "olepro32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
        Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
        Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
        Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
        Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
        Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
        Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As LongPtr
        Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As LongPtr) As Long
    
        Private hCopy As LongPtr, hPtr As LongPtr, hLib As LongPtr
    
    #Else 
    
        Private Declare Function OleCreatePictureIndirectAut Lib "oleAut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
        Private Declare Function OleCreatePictureIndirectPro Lib "olepro32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
        Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
        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 Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
        Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
        Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
    
        Private hCopy As Long, hPtr As Long, hLib As Long
    #End  If
    
    
    Private Const IMAGE_BITMAP = 0
    Private Const PICTYPE_BITMAP = 1
    Private Const LR_COPYRETURNORG = &H4
    Private Const CF_BITMAP = 2
    Private Const S_OK = 0
    
    Private oInitPic As IPicture
    Private oCurrentShape As Object
    
    
    
    Private Sub UserForm_Initialize()
        InkPicture1.DefaultDrawingAttributes.Color = vbRed
        Set oInitPic = CreatePicture(Me.InkPicture1)
    End Sub
          
    
    Private Sub UserForm_Terminate()
        If Not oCurrentShape Is Nothing Then oCurrentShape.Delete
    End Sub
    
    
    Private Sub Cmd_CopyToSheet_Click()
    
        If Me.InkPicture1.Ink.Strokes.Count Then
            Me.InkPicture1.Ink.ClipboardCopy
            Range("B2").PasteSpecial xlPasteAll
            Set oCurrentShape = Selection
            oCurrentShape.TopLeftCell.Select
            Me.InkPicture1.Ink.DeleteStrokes
        Else
            If Not oCurrentShape Is Nothing Then
                Set Me.InkPicture1.Picture = oInitPic
                oCurrentShape.Visible = True
            End If
        End If
        Me.InkPicture1.AutoRedraw = True
    
    End Sub
    
    
    Private Sub Cmd_CopyFromSheet_Click()
    
        InkPicture1.SizeMode = IPSM_CenterImage
        Set InkPicture1.Picture = CreatePicture(oCurrentShape)
        If Me.InkPicture1.Ink.Strokes.Count = 0 Then
            If Not oCurrentShape Is Nothing Then
                oCurrentShape.Visible = False
            End If
        End If
        
    End Sub
    
    
    Private Function CreatePicture(ByVal Shape As Object) As IPicture
    
        Dim IID_IDispatch As GUID, uPicinfo As uPicDesc
        Dim iPic As IPicture, lRet As Long
        
        On Error GoTo errHandler
    
        Shape.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
        OpenClipboard 0
        hPtr = GetClipboardData(CF_BITMAP)
        hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
        With IID_IDispatch
            .Data1 = &H20400
            .Data4(0) = &HC0
            .Data4(7) = &H46
        End With
        With uPicinfo
            .Size = Len(uPicinfo)
            .Type = PICTYPE_BITMAP
            .hPic = hCopy
            .hPal = 0
        End With
        hLib = LoadLibrary("oleAut32.dll")
        If hLib Then
            lRet = OleCreatePictureIndirectAut(uPicinfo, IID_IDispatch, True, iPic)
        Else
            lRet = OleCreatePictureIndirectPro(uPicinfo, IID_IDispatch, True, iPic)
        End If
        FreeLibrary hLib
        If lRet = S_OK Then
            Set CreatePicture = iPic
        End If
    errHandler:
        EmptyClipboard
        CloseClipboard
        
    End Function
    Office/Excel 2010 64Bits -- Win10 64Bits

    Common sense is not so common.


    http://photo-larache.blogspot.com/

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •