Εμφάνιση ενός μόνο μηνύματος
  #3  
Παλιά 17-07-12, 13:18
Το avatar του χρήστη Tasos
Tasos Ο χρήστης Tasos δεν είναι συνδεδεμένος
Διαχειριστής
Όνομα: Τάσος Φιλοξενιδης
Έκδοση λογισμικού Office: Ms-Office 365
Γλώσσα λογισμικού Office: Ελληνική, Αγγλική, Γερμανική
 
Εγγραφή: 21-10-2009
Μηνύματα: 2.011
Προεπιλογή

Καλησπέρα!

Δημήτρη, δοκίμασε τον παρακάτω κώδικα στη φόρμα σου (test).

Ο κώδικας αυτός λειτουργεί αυτόνομα (δεν εξαρτάται από τις συναρτήσεις των άλλων λειτουργικών μονάδων της εφαρμογής):

Πρόσθεσε πρώτα την αναφορά Microsoft Scripting Runtime (Tools > References)

Κώδικας:
Option Compare Database
Option Explicit

Private Const strOpenTitle = "Εισαγωγή"
Private Const strDlgTitle = "Επιλογή αρχείου..."
Private Const DlgClass = "#32770"
Private Const SW_MAXIMIZE = 3&
Private Const SW_SHOWNORMAL = 1&
Private hw As Long

Private Const strFilter = "Όλα τα αρχεία (*.*)|Αρχεία Word (*.doc)|Αρχεία Excel (*.xls)|Αρχεία Pdf (*.pdf)|Αρχεία (*.rtf)"

Private Declare Function ShowWindow Lib "user32" (ByVal _
                                                  hwnd As Long, ByVal nCmdShow As Long) As Long

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
                                    (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation _
                                      As String, ByVal lpFile As String, ByVal lpParameters As String, _
                                      ByVal lpDirectory As String, ByVal nShowCmd _
                                      As Long) As Long

Private fso As New Scripting.FileSystemObject

Private Function GetFilePath() As String
    Dim strFile As String, strInitialDir As String
    strInitialDir = CurrentProject.Path    'ή πχ. "C:\"
    WizHook.Key = 51488399
    Me.TimerInterval = 1000 
    WizHook.GetFileName 0, "", strDlgTitle, strOpenTitle, strFile, strInitialDir, strFilter, 0, 0, 64, True
    GetFilePath = strFile
End Function

Private Sub Form_Timer()
    If hw Then Me.TimerInterval = 0: hw = 0: Exit Sub
    hw = FindWindow(DlgClass, strDlgTitle)
    ShowWindow hw, SW_MAXIMIZE
End Sub

Private Sub cmdAddSmall_Click()
    On Error GoTo cmdAddSmall_Err
    Dim strFilename As String
    strFilename = GetFilePath
    If Len(strFilename) Then
        Me![FilePath] = strFilename
        Me.DocumentTitle = fso.GetFileName(strFilename)
        Me.FolderName = fso.GetParentFolderName(strFilename)
    End If
cmdAddSmall_End:
    Exit Sub
cmdAddSmall_Err:
    MsgBox Err & vbLf & Err.Description
    Resume cmdAddSmall_End
End Sub

Private Sub cmdOpenWordDoc_Click()
    Dim strFilename As String, lp_Directory As String
    strFilename = Nz(Me.FilePath, "")
    If Len(Trim(strFilename)) = 0 Then
        MsgBox "Παρακαλώ βεβαιωθείτε ότι η διαδρομή για αυτό το έγγραφο είναι σωστή.", vbInformation, "Προσοχή!"
    ElseIf Not fso.FileExists(strFilename) Then
        MsgBox "Το έγγραφο δεν βρέθηκε." & vbCrLf & "Παρακαλώ αναζητήστετο ξανά.", vbExclamation, "Λυπάμαι!"
    Else
        lp_Directory = Nz(Me.FolderName, "")
        If Not fso.FolderExists(lp_Directory) Then lp_Directory = "C:\"
        ShellExecute 0, "open", strFilename, "", lp_Directory, SW_SHOWNORMAL
    End If
End Sub
Φιλικά

Τάσος
__________________
Ms-Office Development Team
Ανάπτυξη επαγγελματικών εφαρμογών

Τελευταία επεξεργασία από το χρήστη Tasos : 17-07-12 στις 13:28.
Απάντηση με παράθεση