ארכיון הקטגוריה: VBA

פרוצדורת VBA למחיקת עיצובים מותאמים אישית ב-Excel

יש הטוענים שעיצובים אלו יוצרים בעיות

להלן פונקציה שמוחקת אותם

השורה On error resume next מיועדת בין השאר, למצבים שהגיליון שמכיל עיצוב כזה – נעול, במצב כזה, תתקבל תקלה.

Sub StyleKill()
     Dim styT As Style
     Dim intRet As Integer
     On Error Resume Next
     For Each styT In ActiveWorkbook.Styles
         If Not styT.BuiltIn Then
             If styT.name <> "1" Then styT.Delete
         End If
     Next styT
 End Sub

מקור כאן

פונקצית VBA לחישוב ערכים באמצעות אקסל חיצוני (למשל מאקסס או מוורד)

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

להלן פונקציה שכתבתי ששולחת נתונים לאקסל, ומקבלת בחזרה נתונים לאחר החישוב

פונקציה זו נועדה לחשב דברים באמצעות אקסל
יש לספק 3 פרמטרים:
1. שם הקובץ
2. מערך המכיל את המידע שיש לשתול באקסל
3. מערך המכיל את התאים שיש לקבל מאקסל
הפונקציה שותלת את המערך מהפרמטר השני
ואז ממלאת את המערך מהפרמטר השלישי ומחזירה אותו
כלומר תוצאה הפונקציה היא מערך!
במקרה של תקלה – תוצאה הפונקציה תהיה בוליאנית – שקר

מבנה המערכים –
שתי המערכים באותו מבנה – דו מימדי, כאשר תיאור העמודות נשמר ב
ENUM = E_XL_DataAry

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

הערה : הפונקציה שמוזכרת פה IsArrayAllocated, היא פונקציה רק שבודקת האם זהו מערך תקין, ואינה מחויבת (היא לא חלק מ-VBA, אלא בנפרד).

Public Enum E_XL_DataAry
    
    SheetNameCol = 0
    CellAddressCol = 1
    ValueCol = 2

End Enum


Public Function CalculateByExcel(file_name As String, DataToPutAry As Variant, DataToGetAry As Variant) As Variant
    
    Dim xl As Object, wb As Object, ws As Object, I As Integer
    'open the xl
    Set xl = CreateObject("Excel.Application")
    xl.Visible = False
    Set wb = xl.Workbooks.Open(file_name, 2, True)
    
    If (Not IsArrayAllocated(DataToPutAry)) Or (Not IsArrayAllocated(DataToGetAry)) Then GoTo Err_Handel
    
    'Put Data into cells
    For I = LBound(DataToPutAry) To UBound(DataToPutAry)
            wb.Worksheets(DataToPutAry(I, E_XL_DataAry.SheetNameCol)).range(DataToPutAry(I, E_XL_DataAry.CellAddressCol)).Value = DataToPutAry(I, E_XL_DataAry.ValueCol)
    Next I
    
    For I = LBound(DataToGetAry) To UBound(DataToGetAry)
            DataToGetAry(I, E_XL_DataAry.ValueCol) = wb.Worksheets(DataToGetAry(I, E_XL_DataAry.SheetNameCol)).range(DataToGetAry(I, E_XL_DataAry.CellAddressCol)).Value
    Next I
     
    CalculateByExcel = DataToGetAry
     
    wb.Close False ' close the source workbook without saving any changes
    Set wb = Nothing
    xl.Quit
    Set xl = Nothing

Exit_Func:
    Exit Function


Err_Handel:
    CalculateByExcel = False
    Resume Exit_Func
    
End Function

דוגמא לשימוש פשוט – כאשר מוחזר רק תא אחד בודד


Sub TryIt()
Dim x As Variant, a As Variant, b As Variant
ReDim a(0, 3)
a(0, 0) = "Sheet1"
a(0, 1) = "A1"
a(0, 2) = "1"
ReDim b(0, 3)
b(0, 0) = "Sheet1"
b(0, 1) = "A2"


x = CalculateByExcel("YourXLFile.xlsx", a, b)
Debug.Print x(0, 2)

End Sub

ודוגמא לשימוש מורכב יותר, כאשר מוחזר טווח של 2 תאים לדוגמא


Dim x As Variant, a As Variant, b As Variant
ReDim a(0, 3)
a(0, 0) = "Sheet1"
a(0, 1) = "A1"
a(0, 2) = "1"
ReDim b(0, 3)
b(0, 0) = "Sheet1"
b(0, 1) = "A2:A3"


x = CalculateByExcel("YourXLFile.xlsx", a, b)
Debug.Print x(0, 2)(1,1)

End Sub

בהצלחה!

המתנה ב-ACCESS VBA באמצעות WINDOWS API

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

להלן קוד.

#If VBA7 Then
    Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
#Else
    Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If


Sub SleepVBA(ms As Integer)
'ms = milisecondes
Sleep ms
End Sub

העברת ADO RECORDSET אל מערך ב-VBA

קורה לפעמים שעדיף לרוץ על מערך בזיכרון מאשר על רקורדסט – זה הרבה הרבה יותר מהיר

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


Public Function RecordsetToArray(ByRef rs As Object) As Variant
    Dim tmp As Variant, cols_num As Integer, K As Integer, rows_num As Integer, J As Integer
    
    If Not (rs.EOF And rs.BOF) Then
    
        rs.MoveFirst
        cols_num = rs.fields.Count
        rows_num = rs.RecordCount
        
        ReDim tmp(rows_num, cols_num)
            
            J = 0
            Do While Not rs.EOF
                For K = 0 To cols_num - 1
                      tmp(J, K) = Nz(rs.fields(K).Value, "")
                Next K
                J = J + 1
                rs.MoveNext
            Loop
    
    Else
        tmp = Array("")
    
    End If
    
    RecordsetToArray = tmp
    
End Function




יצירת קיצור דרך (קובץ lnk) באמצעות VBA

הקוד הבא שוכלל על ידי מעט

הוא יוצר קובץ קיצור דרך
FileName – שם קובץ מלא, כולל תיקיה של קיצור הדרך שיווצר
Target – הקובץ שנרצה לפתוח
YourArgumentFile – אם יש ארגומנטים אחרי שם הקובץ, הם חייבים לבא כאן
working directory + descrption – אפשרי למלא – ואז הם יהיו מאפיינים בתור קיצור הדרך

Sub CreateAShortcut(FileName As String, Target As String, YourArgumentFile As String, Optional WorkingDirectory As String, _
                        Optional WindowStyle As Integer = vbNormalFocus, _
                        Optional Description As String)


With CreateObject("WScript.Shell").CreateShortcut(FileName)
    .TargetPath = Target
    .Arguments = YourArgumentFile 
    .WindowStyle = WindowStyle
    .Description = Description
    .WorkingDirectory = WorkingDirectory
    .Save
End With
End Sub

מקור
http://windowssecrets.com/forums/showthread.php/62044-Creating-File-Shortcuts-(VBA-Office-XP)

פתיחת קובץ דרך שורת הפקודה של Windows ב-VBA ( באמצעות WSscript)

בדרך כלל אם רוצים להריץ פקודה ב-Shell, יש לשם כך את הפקודה Shell

אלא מה – זוהי פקודה מאוד נכה, שלא תמיד עובדת.

נניח – אם תנסו להריץ קובץ lnk, זה לא יעבוד, כנ"ל לגבי קבצי pdf, וכדומה.

ולכן,
משתמשים ב-wsScript

הערה – אם הפקודה מכילה ארגומנטים או רווחים, תכפילו את המרכאות ב-4, או לחלופין יש להשתמש ב-chr(34)

Dim objshell As Object

Set objshell = CreateObject("WScript.Shell")
    
objshell.Run "C:YouPathYourFile.lnk"

שימוש ב-Web Control המובנה של Access (דפדפן) ב-VBA

בגירסאות האחרונות של Microsoft Access יש Web Control מובנה

זה נוח מאוד כי הוא יכול להיות קשור לשדה, ולהשתנות בהתאם.

ב-VBA הגישה היא כזו :

.YourWebControl.ControlSource = "=" & Chr(34) & file_name & Chr(34)

לחלופין אם זו כתובת קבועה אפשר כך (ההכפלה של המרכאות היא כדי ליצור מופע אחד של מרכאות בתוך המחרוזת).

YourWebControl.ControlSource = "=""www.google.co.il""

הצגת מונה רשומות בתוך טופס Access

באקסס , פעמים מסוימות נרצה להציג מונה רשומות בתוך הטופס עצמו

ולא להשתמש במונה המובנה של אקסס

 

השיטה הכי פשוטה היא לעשות תיבת טקסט ובתוכה

=" Record  " & [CurrentRecord] & " From  " & Count(*)


אבל  הבעיה היא שהשיטה הזו מחזיקה מעמד רק עד שפותחים רשומה חדשה

ברגע שפותחים רשומה חדשה – מקבלים דברים מוזרים כמו "רשומה 7 מתוך 6" וכדומה.

 

אז שיטה יותר טובה היא לשים באירוע של OnCurrent ( בנוכחי) קוד שבמידה והטופס נמצא על רשומה קימת – נשתמש ב-DCount כדי למנות את מספר הרשומות הקיים.

 

 If Me.NewRecord Then
 Me.txtCounter.Value = "New Record ( " & DCount("[PolicyID]", "tblPolicies", "[linkID]='" & Nz(Me.linkID, "") & "'") & " Exists Records "
 
 Else
 Me.txtCounter.Value = "Record " & Me.CurrentRecord & " Of " & DCount("[PolicyID]", "tblPolicies", "[linkID]='" & Nz(Me.linkID, "") & "'")
 End If

כמובן שתשנו את ה-Dcount לטבלה הרלוונטית עבורכם.

 

מקור להרחבה ושיטות נוספות : http://www.fontstuff.com/mailbag/qaccess04.htm

 

בדיקה אם שאילתא קיימת, ומחיקת שאילתא דרך VBA ב- Access

ב- Access פעמים מסויימות צריך ליצור שאילתא תוך כדי ריצה

למשל כאשר רוצים ליצור שאילתת Pivot / Transpose  מותאמת למצב מסוים.

להלן 2 פונקציות Access VBA שמטפלות בשאילתות.

בדיקה אם שאילתא קיימת

 

Public Function isQueryExists(qryName As String) As Boolean

    On Error GoTo ErrorHandel


 Dim db As Database
 Dim qry As QueryDef
 Dim I As Integer
 Set db = CurrentDb()
 isQueryExists = False
 
 
 For Each qry In db.QueryDefs
               If qry.Name = qryName Then
                    isQueryExists = True
                    Exit Function
               End If
          Next qry

ExitHere:
    Exit Function
ErrorHandel:
    Err.Clear
    isQueryExists = False
    Resume ExitHere
End Function

מחיקת שאילתא

Public Sub DeleteQuery(qryName As String)
On Error Resume Next
    

    If isQueryExists(qryName) Then
        DoCmd.DeleteObject acQuery, qryName
        DoEvents
    End If

If Err.Number <> 0 Then Err.Clear
End Sub

יצירת טבלה זמנית ב-Access באמצעות VBA ומילוי שלה מתוך Recordset

לפעמים בשימוש ב-Access צריך להשתמש בטבלה זמנית.

ולפעמים הטבלה הזמנית צריכה להיות מבוססת על Recordset ADO

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

להלן המודול, ללא יותר מדי הסברים,

בקצרה – שולחים אליו רקורדסט ADO קיים, ואת השם הרצוי של הטבלה שתיווצר, והטבלה נוצרת מייד.

תוך כדי יצירת הטבלה, הפרוצדורה בודקת את השדות השונים, והגדרות השדות עוברות המרה מהפורמט של ADO אל הפורמט של Access .

 

Public Enum ETempTableActions
    CreateNewTableAndFillIt = 1
    OnlyFillExistsTable = 2
End Enum

Public Sub CreateTempLocalTable(tblName As String, ByRef rec As Object)
'                                                           פרוצדורה שיוצרת טבלה מקומית זמנית
'                                                                  על סמך רקורדסט שהועבר אליה
'                                         בהתחלה בודקים אם הטבלה קיימת ואם כן ננסה למחוק אותה
'                                                      אם היא נעולה, אז נמחק רק את תוכן הטבלה
'                                          במידה ומחקנו את הטבלה, ניצור אותה מחדש + נמלא אותה
'                                                 במידה ורק רוקנו את תוכנה, אז נמלא אותה מחדש
    On Error GoTo Error_Handel
      
    Dim dbs As Database, tdfNew As TableDef, fldTemp As Field, rst As DAO.Recordset, DAOfld As Variant, fld As Object, Proccess As Integer
    
    Set dbs = CurrentDb
    
    If isTableExists(tblName) Then
        
        If DeleteTable(tblName) = True Then
            Proccess = ETempTableActions.CreateNewTableAndFillIt
        Else
            Proccess = ETempTableActions.OnlyFillExistsTable
        End If
    
    Else
        
        Proccess = ETempTableActions.CreateNewTableAndFillIt
    
    End If
    
    Select Case Proccess
        
        Case ETempTableActions.CreateNewTableAndFillIt
            
            Call CreateNewTable(dbs, tdfNew, rec, tblName)
            Call InsertRecToTable(rec, tblName)
        
        Case ETempTableActions.OnlyFillExistsTable
            
            Call InsertRecToTable(rec, tblName)
    
    End Select
             
ExitHere:
    
    Exit Sub
Error_Handel:
    Err.Clear
    Resume ExitHere
End Sub
Private Sub InsertRecToTable(ByRef rec As Object, tblName As String)
    
    On Error Resume Next

    Dim rst As Recordset, DAOfld As Variant

    If Not rec.EOF Then
        rec.MoveFirst
        Set rst = CurrentDb.OpenRecordset(tblName) 'פותח עוד רקורדסט שיכיל את  הטבלה החדשה שנוצרה
        
        Do While Not rec.EOF
            
            rst.AddNew
            
            For Each DAOfld In rst.fields
                
                If DAOfld.Type = dbBoolean Then
                    rst.fields(DAOfld.Name).Value = CBool(rec.fields(DAOfld.Name).Value)
                Else
                    rst.fields(DAOfld.Name).Value = rec.fields(DAOfld.Name).Value
                End If
            
            Next DAOfld
            
            rst.Update
            
            rec.MoveNext
         Loop
    End If
    
    rst.Close
    Set rst = Nothing

    If Err.Number <> 0 Then Err.Clear

End Sub
Public Function isTableExists(tblName As String) As Boolean
'                       בודק אם טבלה בשם הזה קיימת
'                                מחזיר ערך בוליאני
    On Error GoTo Error_Handel
    Dim db As Database, tbl As TableDef, I As Integer
    Set db = CurrentDb()
    isTableExists = False
        
    For Each tbl In db.TableDefs
        If tbl.Name = tblName Then
             isTableExists = True
             Exit Function
        End If
     Next tbl

ExitHere:
    Exit Function
Error_Handel:
    Err.Clear
    isTableExists = False
    Resume ExitHere
End Function

Private Sub CreateNewTable(ByRef dbs As Object, ByRef tdfNew As TableDef, ByRef rec As Object, tblName As String)
    
    On Error GoTo Error_Handel
    
    Dim fldType As Variant, fld As Object, fldTemp As Field
    
    Set tdfNew = dbs.CreateTableDef(tblName)
    Set fld = CreateObject("ADOX.Column")   'CreateObject("ADODB.Field")
    
    With tdfNew
          ' Create fields and append them to the new TableDef
          ' object. This must be done before appending the
          ' TableDef object to the TableDefs collection of the
          ' database.
          For Each fld In rec.fields
                
                Select Case fld.Type
                    Case 202
                        fldType = dbText
                    Case 201
                        fldType = dbMemo
                    Case 10
                        fldType = dbText
                    Case 135
                        fldType = dbDate
                    Case 11
                        fldType = dbBoolean
                    Case Else
                        fldType = fld.Type
                End Select
        
                Set fldTemp = tdfNew.CreateField(fld.Name, fldType)
                If (fldType = dbText Or fldType = dbMemo) Then fldTemp.AllowZeroLength = True
                
                tdfNew.fields.Append fldTemp
            
            Next fld
    
    End With

    dbs.TableDefs.Append tdfNew
    dbs.TableDefs.Refresh
    DoEvents

ExitHere:
    Exit Sub
Error_Handel:
    Err.Clear
    Resume ExitHere
End Sub

Public Function DeleteTable(tblName As String) As Boolean
     
     On Error Resume Next
     Err.Clear
     Dim DeleteSql As String
     
     DoCmd.DeleteObject acTable, tblName
    
     DoEvents
'           לפעמים הטבלה נעולה ותתקבל במקרה הזה תקלה
        '                  במקרה כזה, נרוקן את הטבלה מרשומות
        '      ונמשיך מייד למילוי הטבלה , בלי ליצור אותה מחדש
     If Err.Number <> 0 Then '= 3211 Or Err.Number = 3021 Then
            
            DeleteSql = "DELETE * FROM " & tblName & ";"
                
                DoCmd.SetWarnings False
                DoCmd.RunSQL DeleteSql
                DoCmd.SetWarnings True
            
            DoEvents
            Err.Clear
            DeleteTable = False
     Else
            DeleteTable = True
     End If
   
End Function