TPE

http://bayanbox.ir/view/263405954590585756/2mobile.png

Tavvafi@gmail.com


≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡

Sub PutImageOnClipboard()

    Dim oPres As Presentation
    Dim oSh As Shape
    Dim strIconFile As String

    ' Edit this to point to the file you want to put on clipboard
    strIconFile = "C:\Pictures\SomeImage.GIF"

    ' Add a new presentation (WithWindow set to False)
    Set oPres = Presentations.Add(msoFalse)
    ' add a slide
    Call oPres.Slides.Add(1, ppLayoutBlank)

    ' Import the picture at any arbitrary size
    Set oSh = oPres.Slides(1).Shapes.AddPicture(FileName:=strIconFile, _
        LinkToFile:=msoFalse, _
        SaveWithDocument:=msoTrue, _
        Left:=0, Top:=0, width:=10, height:=10)

    ' Set the picture back to its rightful size, then copy and delete it
    With oSh
        .Scaleheight 1, msoTrue
        .Scalewidth 1, msoTrue
        .Copy
        .Delete
    End With

    ' clean up
    oPres.Close
    Set oPres = Nothing

End Sub

  1. Create a form "UserForm1" with an image control named "Image1"
  2. Load a picture in the image control.
  3. Create a module and add the following code to it:

Public Sub CreateCommandBar()
   Dim oComBar As CommandBar
   Const COMMANDBAR_NAME As String = "Test toolbar"

   ' Delete old toolbar:
   For Each oComBar In CommandBars
      If oComBar.Name = COMMANDBAR_NAME Then
         oComBar.Delete
      End If
   Next oComBar

   ' Create new toolbar:
   Set oComBar = Application.CommandBars.Add(COMMANDBAR_NAME)
   Call AddButton(oComBar, "Button Caption", _
          "CMDBAR_FunctionDoSomething", UserForm1.Image1.Picture, True)
   oComBar.Visible = True
End Sub

Private Sub AddButton(oComBar As CommandBar, sButtonName As String,
sMakroName As String, oIcon As IPictureDisp, bBeginGroup As Boolean)
   Dim oComBarButton As CommandBarButton

   Set oComBarButton = oComBar.Controls.Add(msoControlButton)
   With oComBarButton
      .Caption = sButtonName
      .OnAction = sMakroName
      .BeginGroup = bBeginGroup
      .Style = msoButtonIcon
      .Picture = oIcon
   End With
End Sub

Public Sub CMDBAR_FunctionDoSomething()
   MsgBox "Hello toolbar"
End Sub