Consulting

Results 1 to 2 of 2

Thread: Import picture file ActiveX

  1. #1
    VBAX Newbie
    Joined
    Jul 2008
    Posts
    5
    Location

    Cool Import picture file ActiveX

    I need to add pictures to a certain slide. However the pictures file location , may change so I can't just write hard copy for the pictures location[FONT='Arial','sans-serif'].[/FONT]
    Is there an ActiveX I can add to a form, that will enable the user to choose the file location[FONT='Arial','sans-serif']?[/FONT]
    [FONT='Arial','sans-serif']I know such an ActiveX exists in vb6, but what about v.b.a, and more specifically in power-point , thought I assume such ActiveX is generic for all office applications[/FONT]
    [FONT='Arial','sans-serif'][/FONT]
    [FONT='Arial','sans-serif'][/FONT][FONT='Arial','sans-serif']Thanks in advance[/FONT]

  2. #2
    VBAX Contributor
    Joined
    May 2008
    Posts
    198
    Location
    Here are the functions I am using now (I found them elsewhere online, I don't recall where)[vba]
    Option Explicit
    Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
    Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
    Private Declare Function GetActiveWindow Lib "user32" () As Long
    Private Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    Flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
    End Type
    Private Const OFN_OVERWRITEPROMPT = &H2
    Private Const OFN_ALLOWMULTISELECT = &H200
    Private Const OFN_EXPLORER = &H80000
    'UDT that makes calling the commondialog easier
    Public Type CMDialog
    Ownerform As Long
    Filter As String
    Filetitle As String
    FilterIndex As Long
    fileName As String
    DefaultExtension As String
    OverwritePrompt As Boolean
    AllowMultiSelect As Boolean
    Initdir As String
    Dialogtitle As String
    Flags As Long
    End Type
    Public cmndlg As CMDialog
    'General Declarations
    Private OpenDir As String
    Private SaveDir As String
    Public Function ShowOpen(Optional Dialogtitle As String = "Open a PowerPoint File:", Optional initialDirectory As String = "C:\") As String
    Dim OFName As OPENFILENAME
    Dim temp As String
    With cmndlg
    OFName.lStructSize = Len(OFName)
    OFName.hwndOwner = .Ownerform
    OFName.hInstance = OFName.hInstance 'App.hInstance
    OFName.lpstrFilter = Replace(.Filter, "|", Chr(0))
    OFName.lpstrFile = Space$(254)
    OFName.nMaxFile = 255
    OFName.lpstrFileTitle = Space$(254)
    OFName.nMaxFileTitle = 255
    OFName.lpstrInitialDir = .Initdir
    OFName.lpstrTitle = .Dialogtitle
    OFName.nFilterIndex = .FilterIndex
    OFName.Flags = .Flags Or OFN_EXPLORER Or IIf(.AllowMultiSelect, OFN_ALLOWMULTISELECT, 0)
    If GetOpenFileName(OFName) Then
    .FilterIndex = OFName.nFilterIndex
    If .AllowMultiSelect Then
    temp = Replace(Trim$(OFName.lpstrFile), Chr(0), ";")
    If Right(temp, 2) = ";;" Then temp = Left(temp, Len(temp) - 2)
    .fileName = temp
    Else
    .fileName = StripTerminator(Trim$(OFName.lpstrFile))
    .Filetitle = StripTerminator(Trim$(OFName.lpstrFileTitle))
    End If
    Else
    .fileName = ""
    End If
    ' Need to set return value to .fileName
    ShowOpen = .fileName
    End With
    End Function
    Public Function ShowSave(Optional Dialogtitle As String = "Open a PowerPoint File:", Optional initialDirectory As String = "C:\", Optional ByVal fileName As String) As String
    Dim OFName As OPENFILENAME
    With cmndlg
    OFName.lStructSize = Len(OFName)
    OFName.hwndOwner = .Ownerform
    OFName.hInstance = OFName.hInstance 'App.hInstance
    OFName.lpstrFilter = Replace(.Filter, "|", Chr(0))
    OFName.nMaxFile = 255
    OFName.lpstrFileTitle = Space$(254)
    OFName.nMaxFileTitle = 255
    OFName.lpstrInitialDir = .Initdir
    OFName.lpstrTitle = .Dialogtitle
    OFName.nFilterIndex = .FilterIndex
    OFName.lpstrDefExt = .DefaultExtension
    OFName.lpstrFile = .fileName & Space$(254 - Len(.fileName))
    OFName.Flags = .Flags Or IIf(.OverwritePrompt, OFN_OVERWRITEPROMPT, 0)

    ' Is there a way to prevent user from entering '\' in save dialog??
    If GetSaveFileName(OFName) Then
    .fileName = StripTerminator(Trim$(OFName.lpstrFile))
    .Filetitle = StripTerminator(Trim$(OFName.lpstrFileTitle))
    ' Need to validate name of file (here it's .Filetitle)
    ' Note - substitute any '\' characters in filename, then rebuild filepath with directory
    .FilterIndex = OFName.nFilterIndex
    Else
    .fileName = ""
    End If
    ' Need to set return value to .fileName
    ShowSave = .fileName
    End With
    End Function
    Public Function StripTerminator(ByVal strString As String) As String
    'Removes chr(0)'s from the end of a string
    'API tends to do this
    Dim intZeroPos As Integer
    intZeroPos = InStr(strString, Chr$(0))
    If intZeroPos > 0 Then
    StripTerminator = Left$(strString, intZeroPos - 1)
    Else
    StripTerminator = strString
    End If
    End Function

    '// Example usage
    Private Function testSaveDialog()
    Dim newFilePath As String
    With cmndlg
    .AllowMultiSelect = False
    .DefaultExtension = ".ppt"
    .Dialogtitle = "Save a PowerPoint as:"

    '.Filter = "All files (*.*)|*.*"
    .Filter = "PowerPoint File|*.ppt|PowerPoint Show|*.pps"
    .Flags = 5
    .Initdir = Application.ActivePresentation.Path
    .Ownerform = GetActiveWindow 'HWND
    '// prefill the dialog box with the files' name
    .fileName = "Im_a_file.txt"
    .OverwritePrompt = False ' True
    newFilePath = ShowSave
    If Len(.fileName) = 0 Then Exit Function
    '// save file code
    Debug.Print newFilePath
    ' Dim strFile As String
    ' strFile = .fileName
    '
    ' Open strFile For Output As #1
    ' Print #1, "Example......"
    ' Close #1
    End With
    End Function
    Private Function testOpenDialog()
    Dim newFilePath As String
    With cmndlg
    .AllowMultiSelect = False
    .DefaultExtension = ".ppt"
    .Dialogtitle = "Open:"

    '.Filter = "All files (*.*)|*.*"
    .Filter = "PowerPoint File|*.ppt|PowerPoint Show|*.pps"
    .Flags = 5
    .Initdir = Application.ActivePresentation.Path
    .Ownerform = GetActiveWindow 'HWND
    '// prefill the dialog box with the files' name
    '.fileName = "Im_a_file.txt"
    .OverwritePrompt = False ' True
    newFilePath = ShowOpen
    If Len(.fileName) = 0 Then Exit Function
    '// save file code
    Debug.Print newFilePath
    ' Dim strFile As String
    ' strFile = .fileName
    '
    ' Open strFile For Output As #1
    ' Print #1, "Example......"
    ' Close #1
    End With
    End Function

    [/vba]
    The last two functions (testOpenDialog and testSaveDialog) show you how to call the 'Save' and 'Open' dialog functions. You will need to change the parameters (such as .Filter ) when you use them (I am using them to select a PowerPoint file)

Posting Permissions

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