קוד לדוגמא: קובץ שיוצר קובץ במס"ב.

[רחמים]

תודה רבה, והעליתי לפרוג.

פורסם במקור בפורום CODE613 ב19/02/2014 07:58 (+02:00)

[macroshadow]

ClickOne תודותי נתונים לך על שיפור קובץ המס"ב לתועלת הכלל.

מצורפת הדוגמא שלי, יש בו כמה שיפורים על פני הפרסום שלך. להלן השינויים המהותיים:

1. עיצוב הטופס מחדש.
2. ניקוי הזכרון בסוף הפונקציות ע"י Set Object = Nothing, אני יודע שיש דעות בדבר הצורך בדבר, אך בכל מקרה אם לא יועיל לא יזיק.
3. תיבה משולבת לבחירת סוג הקובץ זיכוי/חיוב. (לא ניתן לשלב את שניהם בקובץ אחד).
4. יצירת הקובץ רק אם אין שדות ריקים בטופס.
5. שינוי בבדיקת חוקיות חשבון בנק, כל חשבון בבנק ירושלים חוקי.
6. סידור מחדש של חלק מהקוד, מחיקת שורות מיותרות, שינוי שנות פונקציות ומשתנים בהתאמה לשאר הקובץ.
7. תיקון שיבוש בקוד המקורי rs.clone במקום rs.close.
8. PadString(CStr(!Amount * 100), 13, "0", False) & _ במקום PadString(Replace(IIf(InStr(!Amount, ".") < 1, !Amount & String(2, "0"), IIf(InStr(StrReverse(!Amount), ".") = 2, !Amount & "0", !Amount)), ".", ""), 13, "0", False) & _

ועוד כמה שינויים קטנים.

בהצלחה לכולם.

דוגמא למס''ב.zip

פורסם במקור בפורום CODE613 ב19/02/2014 20:19 (+02:00)

[רחמים]

ברוך הבא לפורום שלנו
ותודה על התיקונים החשובים.

פורסם במקור בפורום CODE613 ב19/02/2014 20:40 (+02:00)

[clickone]

מצטרף לברכות. (ותודה על העידכונים...)
הכישרון ממש צף החוצה!
נשמח אם תישאר איתנו עוד...
ClickOne

פורסם במקור בפורום CODE613 ב19/02/2014 20:51 (+02:00)

[שמואל]

תודה לכולם!

פורסם במקור בפורום CODE613 ב19/02/2014 20:58 (+02:00)

[מלא 0]

יש בעיה אחת בקובץ, סינון התאריך.
הinputbox שרושמים שם התאריך לא מסנן אותו בפועל, והוא מייצא את כל הרשומות.

פורסם במקור בפורום CODE613 ב20/02/2014 16:17 (+02:00)

[macroshadow]

התאריך שמכניסים בinput box הוא לא לצורך סינון, הוא רק ערך יום החיוב/זיכוי לצורך מס"ב.

ניתן להוסיף סינון אם יש בכל צורך, אבל לצורך כך נצטרך לסנן את הrecord set בתחילת הקוד.

פורסם במקור בפורום CODE613 ב20/02/2014 16:23 (+02:00)

[clickone]

ובהחלט צריך שכולנו נזכור, זהו קוד להתחלת גבייה במס"ב , ולא תוכנה שלמה. ולכן תצטרכו לעשות לו התאמה לתוכנה שאתם כותבים + את התוספות שלכם.
לדוגמא: בדוגמא הנ"ל אין הסטוריית חיובים, (ובצדק, צריך להשאיר משהו גם לכם...)

פורסם במקור בפורום CODE613 ב20/02/2014 20:34 (+02:00)

[יאירמשה]

יש בעיה בקבלת סניפים מבנק ישראל, הוא מוחק את הסניפים ולא מביא אחרים, מה עושים?
תודה רבה

פורסם במקור בפורום CODE613 ב23/04/2014 09:00 (+03:00)

[clickone]

@יאירמשה

יש בעיה בקבלת סניפים מבנק ישראל, הוא מוחק את הסניפים ולא מביא אחרים, מה עושים?
תודה רבה

אתה צודק.
הסיבה:
בנק ישראל שינה את כותרות העמודות בקובץ הXML לאנגלית במקום עברית.

מצ"ב התיקון:

צריך להכנס למודול בשם ModDownloadWeb ולהחליף את הINSERT

INSERT INTO tblBanks ( [קוד בנק], [שם בנק], [מס סניף], [שם סניף], [כתובת סניף], יישוב, מיקוד, טלפון, פקס ) SELECT BRANCH.Bank_Code, BRANCH.Bank_Name, BRANCH.Branch_Code, BRANCH.Branch_Name, BRANCH.Branch_Address, BRANCH.City, BRANCH.Zip_Code, BRANCH.Telephone, BRANCH.Fax FROM BRANCH;

בנוסף, הנה כל המודול למי שאין כח לחפש מה צריך להחליף.... (פשוט להחליף את כל הקוד)

Option Compare Database
Option Explicit

Sub DownloadFile(myURL As String, FileNameSave As String)

'myURL = "http://www.bankisrael.gov.il/he/BankingSupervision/BanksAndBranchLocations/Lists/BoiBankBranchesDocs/snifim.xls"
    Dim WinHttpReq As Object
    Dim oStream As Object
    
    Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
    WinHttpReq.Open "GET", myURL, False, "", ""
    WinHttpReq.send

    myURL = WinHttpReq.responseBody
    If WinHttpReq.Status = 200 Then
        Set oStream = CreateObject("ADODB.Stream")
        oStream.Open
        oStream.Type = 1
        oStream.Write WinHttpReq.responseBody
        oStream.SaveToFile FileNameSave, 2    ' 1 = no overwrite, 2 = overwrite
        oStream.Close
    End If
    
    Set WinHttpReq = Nothing
    Set oStream = Nothing
    
End Sub

Public Function ImportBranchXml()
    On Error Resume Next
    Dim sFile As String
    DoCmd.DeleteObject acTable, "Branch"
    sFile = CurrentProject.Path & "\" & Format(Now, "ddmmyyyynnss") & ".xml"
    DownloadFile "http://www.bankisrael.gov.il/he/BankingSupervision/BanksAndBranchLocations/Lists/BoiBankBranchesDocs/snifim_he.xml", sFile
    ImportXML sFile
    Kill sFile
    CurrentDb.Execute "DELETE * FROM TblBanks"
    CurrentDb.Execute "INSERT INTO tblBanks ( [קוד בנק], [שם בנק], [מס סניף], [שם סניף], [כתובת סניף], יישוב, מיקוד, טלפון, פקס ) SELECT BRANCH.Bank_Code, BRANCH.Bank_Name, BRANCH.Branch_Code, BRANCH.Branch_Name, BRANCH.Branch_Address, BRANCH.City, BRANCH.Zip_Code, BRANCH.Telephone, BRANCH.Fax FROM BRANCH;"
    DoCmd.DeleteObject acTable, "Branch"
End Function

בהצלחה!!
ותודה על הפניית תשומת הלב.....

פורסם במקור בפורום CODE613 ב23/04/2014 10:25 (+03:00)

[macroshadow]

והנה עוד הצעת שיפור, להחליף את הקוד הנ"ל בזה.

1. הוא בודק אם ישנו חיבור לאינטרמת לפני נסיון הייבוא, ומבטל את הפעולה במידה ואינו קיים.

2. הודעה נשלחת לשורת הסטטוס בכל שלב, למען ידע המשתמש מה מתרחש.

   Option Compare Database
   Option Explicit

   #If Win64 And VBA7 Then
   Public Declare PtrSafe Function InternetGetConnectedState Lib "wininet.dll" (lpdwFlags As LongPtr, ByVal dwReserved As Long) As Boolean
   #Else
   Public Declare Function InternetGetConnectedState Lib "wininet.dll" (lpdwFlags As Long, ByVal dwReserved As Long) As Boolean
   #End If

   Sub DownloadFile(myURL As String, FileNameSave As String)

   'myURL = "http://www.bankisrael.gov.il/he/BankingSupervision/BanksAndBranchLocations/Lists/BoiBankBranchesDocs/snifim.xls"
   Dim WinHttpReq As Object
   Dim oStream As Object

    ' בדיקה אם קיים חיבור לאינטרמת
    If InternetGetConnectedState(0, 0) Then
        Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
        WinHttpReq.Open "GET", myURL, False, "", ""
        WinHttpReq.send
   
        myURL = WinHttpReq.responseBody
        If WinHttpReq.Status = 200 Then
            Set oStream = CreateObject("ADODB.Stream")
            oStream.Open
            oStream.Type = 1
            oStream.Write WinHttpReq.responseBody
            oStream.SaveToFile FileNameSave, 2    ' 1 = no overwrite, 2 = overwrite
            oStream.Close
        End If
   
        Set WinHttpReq = Nothing
        Set oStream = Nothing
    Else
        MsgBox "לא זוהה חיבור לאינטרמת!" & "לא ניתן לעדכן את רשימת הסניפים.", vbCritical + vbMsgBoxRight + vbMsgBoxRtlReading, "מנותק!"
    End If
   

   End Sub

   Public Function ImportBranchXml()
   On Error Resume Next
   Dim sFile As String
   SysCmd acSysCmdSetStatus, "מוחק טבלה זמנית..."
   DoCmd.DeleteObject acTable, "Branch"
   sFile = CurrentProject.Path & "" & Format(Now, "ddmmyyyynnss") & ".xml"
   SysCmd acSysCmdSetStatus, "מוריד קובץ מאתר בנק ישראל..."
   DownloadFile "http://www.bankisrael.gov.il/he/BankingSupervision/BanksAndBranchLocations/Lists/BoiBankBranchesDocs/snifim_he.xml", sFile
   SysCmd acSysCmdSetStatus, "מייבא רשימת סניפים מהקובץ הזמני..."
   ImportXML sFile
   SysCmd acSysCmdSetStatus, "מוחק קובץ זמני..."
   Kill sFile
   SysCmd acSysCmdSetStatus, "מוחק את הסניפים מהטבלה"
   CurrentDb.Execute "DELETE * FROM TblBanks"
   SysCmd acSysCmdSetStatus, "מייבא רשימת סניפים מהטבלה הזמנית..."
   CurrentDb.Execute "INSERT INTO tblBanks ( [קוד בנק], [שם בנק], [מס סניף], [שם סניף], [כתובת סניף], יישוב, מיקוד, טלפון, פקס ) SELECT BRANCH.Bank_Code, BRANCH.Bank_Name, BRANCH.Branch_Code, BRANCH.Branch_Name, BRANCH.Branch_Address, BRANCH.City, BRANCH.Zip_Code, BRANCH.Telephone, BRANCH.Fax FROM BRANCH;"
   SysCmd acSysCmdSetStatus, "מוחק טבלה זמנית..."
   DoCmd.DeleteObject acTable, "Branch"
   SysCmd acSysCmdClearStatus
   End Function

פורסם במקור בפורום CODE613 ב23/04/2014 17:37 (+03:00)

[מלא 0]

אולי מישהו יואיל ויועיל, להסביר לי מה פשרה של הפונקציה הזאת, ומה מטרתה.
תודה רבה

Public Function NullCheck(frm As Form) As Boolean

    Dim ctl As Control

    For Each ctl In frm
        If ctl.ControlType = acTextBox Then
            If ctl.Visible = True And ctl.Locked = False Then
                If IsNull(ctl) Then
                    NullCheck = True
                    Exit Function
                End If
            End If
        ElseIf ctl.ControlType = acSubform Then
            NullCheck = NullCheck(ctl.Form)
            If NullCheck = True Then Exit Function
        End If
    Next ctl

End Function

פורסם במקור בפורום CODE613 ב08/05/2014 23:12 (+03:00)

[ארכיטקט]

מטרה של פונקציה צריך לבדוק היכן נעשה בה שימוש, אבל מה שהיא עושה זה עוברת על הפקדים שיש בטופס ובודקת אם אחד מהם מכיל ערך null, ברגע שהיא נתקלת באחד הפקדים שמכיל ערך null היא מחזירה תשובה חיובית.

פורסם במקור בפורום CODE613 ב08/05/2014 23:19 (+03:00)

[clickone]

@מלא

אולי מישהו יואיל ויועיל, להסביר לי מה פשרה של הפונקציה הזאת, ומה מטרתה.
תודה רבה

Public Function NullCheck(frm As Form) As Boolean

    Dim ctl As Control

    For Each ctl In frm
        If ctl.ControlType = acTextBox Then
            If ctl.Visible = True And ctl.Locked = False Then
                If IsNull(ctl) Then
                    NullCheck = True
                    Exit Function
                End If
            End If
        ElseIf ctl.ControlType = acSubform Then
            NullCheck = NullCheck(ctl.Form)
            If NullCheck = True Then Exit Function
        End If
    Next ctl

End Function

ואני בכלל לא ידעתי שיש שם כזו פונקצייה.. :lol: :lol: :lol: :lol: (אני רק שיפרתי את מה שמוישי מפרוג [MacroShadow?] עשה..)

פורסם במקור בפורום CODE613 ב08/05/2014 23:58 (+03:00)

[תלת]

]שלום רב,
הגעתי לכאן עם הפניה מאתר פרוג.
ראשית תודה רבה על כל ההשקעה.
אני מקבל הודעת שגיאה שהקובץ אינו מתאים ל64 ביט.
האם מישהו יוכל להעלות קובץ מותאים ל-64 ביט. וכן אם אפשר עם התיקונים שהובאו בסוף האשכול.
תודה רבה

לכידה.PNG

פורסם במקור בפורום CODE613 ב21/06/2015 13:14 (+03:00)

[hubhcbh]

כדי שזה יעבוד גם ב 32 וגם ב64 צריך להוסיף תנאי, ומילת קוד.
מילת המפתח היא PtrSafe
לדוגמה הקוד הבא

#If VBA7 Then
  'הקוד הזה יעבוד על 64 ביט
  'בין Declare ל Function הוספנו PtrSafe

    Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

#Else

'הקוד הזה יעבוד על 32 ביט
    Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
#End If

אל תשכח להוסיף את התנאי...

פורסם במקור בפורום CODE613 ב21/06/2015 13:24 (+03:00)

[תלת]

HUBHCBH, תודה רבה!

פורסם במקור בפורום CODE613 ב21/06/2015 21:16 (+03:00)

[macroshadow]

@HUBHCBH

כדי שזה יעבוד גם ב 32 וגם ב64 צריך להוסיף תנאי, ומילת קוד.
מילת המפתח היא PtrSafe
לדוגמה הקוד הבא

#If VBA7 Then
  'הקוד הזה יעבוד על 64 ביט
  'בין Declare ל Function הוספנו PtrSafe

    Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

#Else

'הקוד הזה יעבוד על 32 ביט
    Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
#End If

אל תשכח להוסיף את התנאי...

כמעט מדוייק...

#If Win64 And VBA7 Then

Private Type BROWSEINFO
    hOwner As LongPtr
    pidlRoot As LongPtr
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As LongPtr
    lParam As LongPtr
    iImage As Long
End Type

Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As LongPtr
Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

#Else

Private Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

#End If

פורסם במקור בפורום CODE613 ב22/06/2015 18:41 (+03:00)

[תלת]

מה הבעיה כאן?
תודה

32.PNG
31.PNG

פורסם במקור בפורום CODE613 ב22/06/2015 21:28 (+03:00)

[hubhcbh]

למה לא עשית פה תנאי ל 64?

כל מקום שיש שורה אדומה (שהיא בגלל 64ביט) תוסיף את התנאי

פורסם במקור בפורום CODE613 ב23/06/2015 01:39 (+03:00)