Ανανέωση ιστοσελίδας
ms-office.gr > Forum > Microsoft Access > Access - Ερωτήσεις / Απαντήσεις > [ Συναρτήσεις ] Συνάρτηση μέσα σε Module,Απορία

Access - Ερωτήσεις / Απαντήσεις Access + VBA... Εδώ δεν υπάρχουν όρια!

Απάντηση στο θέμα

 

Εργαλεία Θεμάτων Τρόποι εμφάνισης
  #1  
Παλιά 10-07-20, 14:34
Όνομα: ΙΩΑΝΝΗΣ
Έκδοση λογισμικού Office: Ms-Office 2007
Γλώσσα λογισμικού Office: Ελληνική
 
Εγγραφή: 27-01-2020
Μηνύματα: 83
Προεπιλογή Συνάρτηση μέσα σε Module,Απορία

Kαλησπερα.Μια απορια αν μπορει να λυθει βεβαια

εχω αυτον τον κωδικα μεσα σε μια αναφορα

Option Compare Database
Option Explicit
Const strParentFolder As String = "C:\test"
Private Function MakeNameFolder() As String
Dim strname As String
If dir(strParentFolder, vbDirectory) = "" Then
MkDir strParentFolder
End If
If Len(Me.ΟΝΟΜΑ) * Len(Me.ΕΠΙΘΕΤΟ) Then
strname = Replace(Me.ΟΝΟΜΑ, " ", "_") & "_" & _
Replace(Me.ΕΠΙΘΕΤΟ, " ", "_")
End If
MakeNameFolder = strParentFolder & strname

End Function

Γινεται με καποιο τροπο να μπει σε module γιατι οπως θα δειτε στον παρακατω κωδικα που ειναι σε module η function MakeNameFolder() καλειται απο την function pdfSave()
.Αν βαλω την function MakeNameFolder() στο module εχω error λογω του If Len(Me.ΟΝΟΜΑ) * Len(Me.ΕΠΙΘΕΤΟ) Then
strname = Replace(Me.ΟΝΟΜΑ, " ", "_") & "_" & _
Replace(Me.ΕΠΙΘΕΤΟ, " ", "_")


Ο κωδικας στο module

Function CreateReportShortcutMenu()
Dim MenuName As String
Dim CB As CommandBar
Dim CBB As CommandBarButton

MenuName = "vbaShortCutMenu"

On Error Resume Next
Application.CommandBars(MenuName).Delete
On Error GoTo 0

Set CB = Application.CommandBars.Add(MenuName, msoBarPopup, False, False)

''''''''''''''''''''''''''''''''''''''
Set CBB = CB.Controls.Add(msoControlButton, 25, , , True)
CBB.Caption = "Zoom"

Set CBB = CB.Controls.Add(msoControlButton, 5, , , True)
CBB.Caption = "Μία σελίδα"

''''''''''''''''''''''''''''''''''''''

Set CBB = CB.Controls.Add(msoControlButton, 247, , , True)
CBB.BeginGroup = True
CBB.Caption = "Διαμόρφωση σελίδας"

Set CBB = CB.Controls.Add(msoControlButton, 15948, , , True)
CBB.Caption = "Εκτύπωση"

''''''''''''''''''''''''''''''''''''''
Set CBB = CB.Controls.Add(msoControlButton, 11723, , , True)
CBB.BeginGroup = True
CBB.Caption = "Εξαγωγή σε Excel"

Set CBB = CB.Controls.Add(msoControlButton, 12951, , , True)
CBB.Caption = "Εξαγωγή σε Pdf / Xps"
'CBB.FaceId = 3
CBB.OnAction = "=pdfSave()" 'create a public function for the Action

Set CBB = CB.Controls.Add(msoControlButton, 2188, , , True)
CBB.Caption = "Αποστολή με E-mail"


'''''''''''''''''''''''''''''''''''''''''''''''''' '''

Set CBB = CB.Controls.Add(msoControlButton, 14782, , , True)
CBB.BeginGroup = True
CBB.Caption = "Κλείσιμο"

Set CB = Nothing
Set CBB = Nothing

End Function
Function name()
MakeNameFolder


End Function
Function FileExist(FileFullPath As String) As Boolean
Dim value As Boolean
value = False
If dir(FileFullPath) <> "" Then
value = True
End If
FileExist = value
End Function
Public Function pdfSave() As String
Dim strNewFolder As String
Dim fileName As String, fldrPath As String, filePath As String
Dim answer As Integer
Dim strFolder As String

On Error GoTo err_Hander
strFolder = MakeNameFolder()
strNewFolder = MakeNameFolder()
fileName = "Αίθουσα_Τοκετών" & "_" & Format(date, "dd-mm-yyyy")
filePath = strNewFolder & "\" & fileName & ".pdf"

If strNewFolder <> "" Then
If dir(strNewFolder, vbDirectory) = "" Then
MkDir strNewFolder
MsgBox "Δημιουργήθηκε φάκελος" & vbCrLf & strNewFolder, vbOKOnly + vbInformation, "Φάκελος Ειδικευόμενου"
End If

If FileExist(filePath) Then
answer = MsgBox("Tο αρχείο υπάρχει ήδη" & vbNewLine & filePath & vbNewLine & vbNewLine & _
"Να γίνει αντικατάσταση;", vbYesNo + vbInformation, "Αντικατάσταση")


If answer = vbNo Then
Exit Function
Else
DoCmd.OutputTo acReport, "Αίθουσα_Τοκετών", acFormatPDF, filePath
MsgBox "Το αρχείο αντικαταστάθηκε στον φάκελο " & vbCrLf & filePath, vbOKOnly + vbInformation, "Αποθήκευση αναφοράς"
Shell "EXPLORER.EXE" & " " & Chr(34) & strFolder & Chr(34), vbNormalFocus
End If

Else
DoCmd.OutputTo acReport, "Αίθουσα_Τοκετών", acFormatPDF, filePath
MsgBox "Το αρχείο αποθηκεύτηκε στον φάκελο " & vbCrLf & filePath, vbOKOnly + vbInformation, "Αποθήκευση αναφοράς"
Shell "EXPLORER.EXE" & " " & Chr(34) & strFolder & Chr(34), vbNormalFocus



End If
End If
Exit Function
err_Hander:
MsgBox "Error #" & Err.Number & vbCrLf & Err.Description
End Function

Τελευταία επεξεργασία από το χρήστη Tasos : 10-07-20 στις 17:22.
Απάντηση με παράθεση
  #2  
Παλιά 10-07-20, 16:12
Super Moderator
Όνομα: ΓΙΩΡΓΟΣ
Έκδοση λογισμικού Office: Ms-Office 2010, Ms-Office 2013, Ms-Office 2016, Ms-Office 365
Γλώσσα λογισμικού Office: Ελληνική, Αγγλική
 
Εγγραφή: 14-01-2014
Μηνύματα: 234
Προεπιλογή

Καλησπέρα Γιάννη,

Τον παρακάτω κώδικα (Function) μπορείς να τον βάλεις στο ίδιο Module:

Public Function MakeNameFolder(ByVal sEpitheto As String, ByVal sOnoma As String) As String
Const strParentFolder As String = "C:\test"
Dim strname As String
If Dir(strParentFolder, vbDirectory) = "" Then
MkDir strParentFolder
End If
If Len(sOnoma) * Len(sEpitheto) Then
strname = Replace(sOnoma, " ", "_") & "_" & _
Replace(sEpitheto, " ", "_")
End If
MakeNameFolder = strParentFolder & strname
End Function

Αντικατέστησε των κώδικα που έχεις στην αναφορά με:

str=MakeNameFolder(Me.ΕΠΙΘΕΤΟ, Me.ΟΝΟΜΑ)

Ευχαριστώ.
__________________
Βραχνάκης Γιώργος
vrahnakisg@gmail.com
Απάντηση με παράθεση
  #3  
Παλιά 10-07-20, 17:05
Όνομα: ΙΩΑΝΝΗΣ
Έκδοση λογισμικού Office: Ms-Office 2007
Γλώσσα λογισμικού Office: Ελληνική
 
Εγγραφή: 27-01-2020
Μηνύματα: 83
Προεπιλογή

Γιωργο θα το δοκιμασω και θα σε ενηνερωσω.Επθσης γιβεται κατα την εξαγωγη σε pdf να παιρνει δυναμικα το τιτλο της αναφορας;

fileName = "Αίθουσα_Τοκετών" & "_" & Format(date, "dd-mm-yyyy")
Απάντηση με παράθεση
Απάντηση στο θέμα


Δικαιώματα - Επιλογές
Δε μπορείτε να δημοσιεύσετε νέα μηνύματα
Δε μπορείτε να δημοσιεύσετε απαντήσεις
Δεν μπορείτε να επισυνάψετε αρχεία
Δεν μπορείτε να επεξεργαστείτε τα μηνύματα σας

Ο κώδικας ΒΒ είναι σε λειτουργία
Τα Smilies είναι σε λειτουργία
Ο κώδικας [IMG] είναι σε λειτουργία
Ο κώδικας HTML είναι εκτός λειτουργίας
Trackbacks are εκτός λειτουργίας
Pingbacks are εκτός λειτουργίας
Refbacks are εκτός λειτουργίας


Παρόμοια Θέματα

Θέμα Δημιουργός Forum Απαντήσεις Τελευταίο Μήνυμα
[VBA] Χρησιμοποίηση μεταβλητής σε διαφορετικό module Βασίλης Καραχάλιος Excel - Ερωτήσεις / Απαντήσεις 3 01-07-20 23:34
[Συναρτήσεις] Συνάρτηση μέσα στο αποτέλεσμα της IF alex7 Excel - Ερωτήσεις / Απαντήσεις 7 28-01-16 11:47
Kώδικας σε module alex Access - Ερωτήσεις / Απαντήσεις 0 22-10-12 14:50
[Συναρτήσεις] Απορία για συνάρτηση KostasKJ7 Excel - Ερωτήσεις / Απαντήσεις 5 21-02-12 15:47
Διόρθωση κώδικα σε Module alex Access - Ερωτήσεις / Απαντήσεις 2 12-08-11 14:01


Η ώρα είναι 14:50.