CodeKeep VBA Feed

NAddrB

Sat, 26 Sep 2009 07:01:52 GMT

Description: NAddrDB macro work with names as arg in A and value in B. Will accept Arguments in any order within blank row delimited ranges

Link: http://www.codekeep.net/snippets/9ea7169a-9e92-4a2d-8e7c-64fc601d5bf0.aspx

Public Sub nAddrDB()
'Convert 1-Up Name and Address labels to Spread Sheet format.
'NAddrDB macro work with names as arg in A and value in B
'will accept Arguments in any order within blank row delimited ranges
Dim nCol As Long, nRow As Long, cRow As Long, lastrow As Long
Dim insureCol As Long
Dim wsSource As Worksheet, wsNew As Worksheet
Dim lastcell As Range
nCol = 0
nRow = 2
Dim Desc(50) As Variant
Dim Dsub  As Long
Dsub = 0
Dim I As Long
Set lastcell = Cells.SpecialCells(xlLastCell)
lastrow = lastcell.Row + 1  'adjustment to help with insureCol
Set wsSource = ActiveSheet
Set wsNew = Worksheets.Add
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For cRow = 1 To lastrow
   If Trim(wsSource.Cells(cRow, 1).Value) = "" Then
     If nCol <> 0 Then nRow = nRow + 1
     nCol = 0
   Else
     nCol = 1  'not zero
     For I = 1 To Dsub
        If wsSource.Cells(cRow, 1) = Desc(I) Then
           wsNew.Cells(nRow, I).Value = wsSource.Cells(cRow, 2).Value
           GoTo nextcrow
        End If
     Next I
     Dsub = Dsub + 1
     wsNew.Cells(1, Dsub) = wsSource.Cells(cRow, 1).Value
     Desc(Dsub) = wsSource.Cells(cRow, 1).Value
     wsNew.Cells(nRow, Dsub).Value = wsSource.Cells(cRow, 2).Value
     wsNew.Cells(nRow, Dsub).NumberFormat = wsSource.Cells(cRow, 2).NumberFormat
     GoTo nextcrow
   End If
nextcrow:
Next cRow
Cells.EntireColumn.AutoFit
Application.ScreenUpdating = True     'place at end when debugged
Application.DisplayAlerts = True
End Sub

Hide Access Menus & Toolbars

Mon, 10 Aug 2009 06:18:20 GMT

Description: Hide Access Menus & Toolbars. Key words: toolbars, tool bars, menubar, menu bars, hide, unhide, enable, disable, right click, right-click, database window, hide database window,

Link: http://www.codekeep.net/snippets/e4585e14-4a2c-4e79-9417-8b742b997a67.aspx

http://www.access-programmers.co.uk/forums/showthread.php?t=97578

The below code will hide ALL menu bars and ALL tool bars. Ensure that you have a way to unhide the menu bars and tool bars before you hide them! You should place the hide all tool bars routine in your opening splash screen form for it only needs to be run once when the db is first opened.

This will hide all menu bars and tool bars
Dim i As Integer
For i = 1 To CommandBars.Count
CommandBars(i).Enabled = False
Next i

This will unhide all menu bars and tool bars
Dim i As Integer
For i = 1 To CommandBars.Count
CommandBars(i).Enabled = True
Next i

An added bonus is the right-click mouse button option is disabled if the menu bars are disabled with the above code.

Use the 'ShowToolbar' command if you need to display a tool bar or menu bar...
DoCmd.ShowToolbar "YourToolBarNameHere", acToolbarYes

This will hide a tool bar or menu bar when needed...
DoCmd.ShowToolbar "YourToolBarNameHere", acToolbarNo

This will hide the menu bar...
DoCmd.ShowToolbar "Menu Bar", acToolbarNo

You can also hide/unhide the database window with code...

Hide the database window
DoCmd.SelectObject acTable, , True
DoCmd.RunCommand acCmdWindowHide

Unhide the database window
DoCmd.SelectObject acTable, , True

Remove the "Type a question for help" on the default menu bar in Access 2002 or 2003
Application.CommandBars.DisableAskAQuestionDropdow n = True

This command will prevent the db from opening up a separate window tab on the Taskbar
Application.SetOption "ShowWindowsinTaskbar", False

The above commands have been successfully tested with Access 97 and Access 2003.

Read this if you do not understand where to post your questions! >>> Please Read Before Posting (http://www.access-programmers.co.uk/...ad.php?t=63576)

Please do not directly PM me with any questions related to my Hide all Access Toolbars and Menubars code. Please do not post any questions related to my Hide all Access Toolbars and Menubars code in the Code Repository forum. If you have a question related to the Hide all Access Toolbars and Menubars code... Please post your questions in the appropriate forum and include a link to this thread if you have a question or problem related to my Hide all Access Toolbars and Menubars code. I will be glad to help if I see your post and if I am available.

Key words: toolbars, tool bars, menubar, menu bars, hide, unhide, enable, disable, right click, right-click, database window, hide database window,
__________________

How to get a list of the slide titles and notes text in PowerPoint?

Sat, 11 Jul 2009 16:11:55 GMT

Description: Paste all of the code below into a new module and run it to get a listing of the slide titles and notes text in your presentation. This version includes the option to output only entries for slides WITH notes or ALL slides.

Link: http://www.codekeep.net/snippets/51d2ad5c-e825-4238-809d-f9471f15f02d.aspx

Option Explicit

Dim fOnlyEmptyNotes As Boolean

Sub ExportNotesText()

    Dim oSlides As Slides
    Dim oSl As Slide
    Dim oSh As Shape
    Dim strNotesText As String
    Dim strFileName As String
    Dim intFileNum As Integer
    Dim lngReturn As Long
    Dim results As VbMsgBoxResult
    
    
    ' Get a filename to store the collected text
    strFileName = Replace(ActivePresentation.FullName, ".ppt", ".txt")
    strFileName = InputBox("Enter the full path and name of file to extract notes text to", "Output file?", strFileName)
    strNotesText = "Slide Notes from PowerPoint presentation:" & vbCrLf & _
                    ActivePresentation.FullName & vbCrLf & vbCrLf
    
    ' Include only slides with notes in output file?
    results = MsgBox("Would you like to ONLY include Slides that actually have Notes in your output file?", _
        vbQuestion + vbYesNoCancel, "Output Results")
    If results = vbYes Then
        fOnlyEmptyNotes = True
        strNotesText = strNotesText & _
            "IMPORTANT:  This file contains only the slides that have Notes!" & vbCrLf & vbCrLf
    Else
        fOnlyEmptyNotes = False
    End If
    
    

    ' did user cancel?
    If strFileName = "" Or results = vbCancel Then
        Exit Sub
    End If

    ' is the path valid?  crude but effective test:  try to create the file.
    intFileNum = FreeFile()
    On Error Resume Next
    Open strFileName For Output As intFileNum
    If Err.Number <> 0 Then     ' we have a problem
        MsgBox "Couldn't create the file: " & strFileName & vbCrLf _
            & "Please try again."
        Exit Sub
    End If
    Close #intFileNum  ' temporarily

    ' Get the notes text
    Set oSlides = ActivePresentation.Slides
    
    For Each oSl In oSlides
        If fOnlyEmptyNotes = True Then
            ' Only output notes for slides with actual note text
            If NotesText(oSl) <> vbNullString Then
                strNotesText = strNotesText & "-----------------------------------" & vbCrLf
                strNotesText = strNotesText & "TITLE:  " & SlideTitle(oSl) & vbCrLf
                strNotesText = strNotesText & "NUMBER: " & oSl.SlideNumber & vbCrLf
                strNotesText = strNotesText & "NOTES:  " & NotesText(oSl) & vbCrLf & vbCrLf
            End If
        Else
            ' Output all slides
            strNotesText = strNotesText & "-----------------------------------" & vbCrLf
            strNotesText = strNotesText & "TITLE:  " & SlideTitle(oSl) & vbCrLf
            strNotesText = strNotesText & "NUMBER: " & oSl.SlideNumber & vbCrLf
            strNotesText = strNotesText & "NOTES:  " & NotesText(oSl) & vbCrLf & vbCrLf
        End If
        
    Next oSl

    ' now write the text to file
    Open strFileName For Output As intFileNum
    Print #intFileNum, strNotesText
    Close #intFileNum

    ' show what we've done
    lngReturn = Shell("NOTEPAD.EXE " & strFileName, vbNormalFocus)

End Sub
Function SlideTitle(oSl As Slide) As String
    Dim oSh As Shape
    For Each oSh In oSl.Shapes
        If oSh.Type = msoPlaceholder Then
            If oSh.PlaceholderFormat.Type = ppPlaceholderTitle _
                Or oSh.PlaceholderFormat.Type = ppPlaceholderCenterTitle Then
                If Len(oSh.TextFrame.TextRange.Text) > 0 Then
                    SlideTitle = oSh.TextFrame.TextRange.Text
                Else
                    SlideTitle = "Slide " & CStr(oSl.SlideIndex)
                End If
                Exit Function
            End If
        End If
    Next
End Function

Function NotesText(oSl As Slide) As String
' Only looking for Shape.Type = PlaceHolder which contains notes
    Dim oSh As Shape
    
    For Each oSh In oSl.NotesPage.Shapes
        If oSh.Type = msoPlaceholder Then
            If oSh.PlaceholderFormat.Type = ppPlaceholderBody Then
                If oSh.HasTextFrame Then
                    If oSh.TextFrame.HasText Then
                        NotesText = oSh.TextFrame.TextRange.Text
                    End If
                End If
            Else
                NotesText = vbNullString
            End If
        End If
    Next oSh
    
End Function

Export the notes text of a PowerPoint presentation

Sat, 11 Jul 2009 16:08:39 GMT

Description: This macro will export the notes text from each slide in your presentation to the file you specify.

Link: http://www.codekeep.net/snippets/cb8ebde1-c1cf-48d2-9b4c-579f016198a5.aspx

Sub ExportNotesText()

    Dim oSlides As Slides
    Dim oSl As Slide
    Dim oSh As Shape
    Dim strNotesText As String
    Dim strFileName As String
    Dim intFileNum As Integer
    Dim lngReturn As Long

    ' Get a filename to store the collected text
    strFileName = InputBox("Enter the full path and name of file to extract notes text to", "Output file?")

    ' did user cancel?
    If strFileName = "" Then
        Exit Sub
    End If

    ' is the path valid?  crude but effective test:  try to create the file.
    intFileNum = FreeFile()
    On Error Resume Next
    Open strFileName For Output As intFileNum
    If Err.Number <> 0 Then     ' we have a problem
        MsgBox "Couldn't create the file: " & strFileName & vbCrLf _
            & "Please try again."
        Exit Sub
    End If
    Close #intFileNum  ' temporarily

    ' Get the notes text
    Set oSlides = ActivePresentation.Slides
    For Each oSl In oSlides
        For Each oSh In oSl.NotesPage.Shapes
        If oSh.PlaceholderFormat.Type = ppPlaceholderBody Then
            If oSh.HasTextFrame Then
                If oSh.TextFrame.HasText Then
                    strNotesText = strNotesText & "Slide: " & CStr(oSl.SlideIndex) & vbCrLf _
                    & oSh.TextFrame.TextRange.Text & vbCrLf & vbCrLf
                End If
            End If
        End If
        Next oSh
    Next oSl

    ' now write the text to file
    Open strFileName For Output As intFileNum
    Print #intFileNum, strNotesText
    Close #intFileNum

    ' show what we've done
    lngReturn = Shell("NOTEPAD.EXE " & strFileName, vbNormalFocus)

End Sub

Allow user to pick a folder

Mon, 10 Nov 2008 16:39:47 GMT

Description: Must set s reference to the Microsoft Object model library

Link: http://www.codekeep.net/snippets/f98906a0-8f16-46a7-8bed-2b883401fee6.aspx

ublic Function GetUserFolder(strCaption As String, _
    Optional InitialFile As String, _
    Optional bMultiSelect As Boolean = False) As String
    
On Error GoTo eh

Const PROC_NAME As String = "GetUserFolder"

Dim FD As FileDialog

'Create a FileDialog object as a File Picker dialog box.
Set FD = Application.FileDialog(msoFileDialogFolderPicker)

With FD
    If Not Len(strCaption) = 0 Then
        .Title = strCaption
    End If
    If Len(InitialFile) > 0 Then
        .InitialFileName = InitialFile
    End If
    .AllowMultiSelect = bMultiSelect
    

    'Use the Show method to display the File Picker dialog box and return the user's action.
    'The user pressed the action button.
    If .Show = -1 Then
        GetUserFolder = .SelectedItems(1)
    Else
    End If
End With

exitProc:
    Set FD = Nothing
    Exit Function
eh:
    'will log the error and then raise an error back to client
    Resume exitProc
    

End Function

Prompt the user for a file name

Sun, 02 Nov 2008 03:36:44 GMT

Description: Uses the Office 2003 Object libary By adding customized filters, the user will be allowed to search for either text files or Excel workbooks.

Link: http://www.codekeep.net/snippets/d5447579-5e1d-4236-8028-62f7e9adc288.aspx

Public Function GetUserFileName(strCaption As String, _
    Optional InitialFile As String, _
    Optional bMultiSelect As Boolean = False, _
    Optional Filetype As MsoFileType = MsoFileType.msoFileTypeNoteItem) As String
    
On Error GoTo EH

Const PROC_NAME As String = "GetUserFileName"

Dim FD As FileDialog

'Create a FileDialog object as a File Picker dialog box.
Set FD = Application.FileDialog(msoFileDialogOpen)

With FD
    If Not Len(strCaption) = 0 Then
        .Title = strCaption
    End If
    If Len(InitialFile) > 0 Then
        .InitialFileName = InitialFile
    End If
    .AllowMultiSelect = bMultiSelect
    'Add a filter that includes GIF and JPEG images and make it the first item in the list.
    .Filters.Clear
    'will work for text files only
    If Filetype = MsoFileType.msoFileTypeNoteItem Then
        '.Filters.Add "Text", "*.txt; *.csv; *.dat", 1
        .Filters.Add "Text", "*.txt; *.csv; *.dat"
        
    Else
        'will work with Excel workbooks only
        .Filters.Add "Excel workbooks", "*.xls", 1
    End If

    'Use the Show method to display the File Picker dialog box and return the user's action.
    'The user pressed the action button.
    If .Show = -1 Then
        GetUserFileName = .SelectedItems(1)
    Else
    End If
End With

exitProc:
    Set FD = Nothing
    Exit Function
EH:
    'will log the error and then raise an error back to client
    
    

End Function

Confirm w/user before overwriting a file

Sun, 02 Nov 2008 02:51:43 GMT

Description: Prompt the user that file exists and asks before continuing

Link: http://www.codekeep.net/snippets/fb0ee7d8-71d3-4151-91d0-e4793f1eb0ae.aspx

Public Function bOkToOverwrite(strFileName As String) As Boolean
Dim strUserMsg As String

strUserMsg = strFileName & " already exists.  Do you want to overwrite it?"


bOkToOverwrite = (vbYes = MsgBox(strUserMsg, vbYesNoCancel Or vbExclamation Or vbDefaultButton2, "Overwrite File?"))
End Function

Execute an action query with line items

Sun, 02 Nov 2008 02:44:42 GMT

Description: Note doesn't use transactions

Link: http://www.codekeep.net/snippets/665b5d62-2a18-4b1b-aca0-74a78a9db8dd.aspx

Executing a stored with no results set expect.  Generally , will be used ithe Execute queries
(a) with command object
Private Sub CustomerNewOrder(ByVal CustomerId As Long, _
    ItemsToPurchase As Integer, _
    OrderDate As Date)
     
Dim strProcName As String
Dim objConn As ADODB.Connection
Dim objCmd As ADODB.Command
Dim objLineItem As ADODB.Command
Dim lngOrderId As Long
Dim lngProductId As Long
Dim intQuantity As Integer
Dim lngRV As Long
Dim lngNewRowId As Long
Dim iProductIdSubscript As Integer
Dim i As Integer

On Error GoTo EH
strProcName = "uspCustOrderAdd"
Const PROC_NAME As String = "CustomerNewOrder"
Const QUALIFIEDCLASSNAME = PROC_NAME


Set objConn = New ADODB.Connection
With objConn
    '.ConnectionString = gConnectString
    .ConnectionString = GetConnectionString()
    .Open
End With

Set objCmd = New ADODB.Command
With objCmd
    .CommandText = strProcName
    .CommandType = ADODB.CommandTypeEnum.adCmdStoredProc
    .ActiveConnection = objConn
    
    'CREATE PARAMETERS/SET THE VALUES OF THE PAREMETERS
    .Parameters.Append objCmd.CreateParameter("@RETURN_VALUE", adInteger, adParamReturnValue, 4)
    .Parameters.Append objCmd.CreateParameter("@OrderDate", adDate, adParamInput, , OrderDate)
    .Parameters.Append objCmd.CreateParameter("@CustomerId", adInteger, adParamInput, , CustomerId)
    .Parameters.Append objCmd.CreateParameter("@AdditionalDeliveryInstructions", adVarChar, adParamInput, 254, Null)
    .Execute lngRV, Options:=adExecuteNoRecords
    lngOrderId = .Parameters("@RETURN_VALUE").Value
End With
' load line items
Set objCmd = Nothing 'release resources

strProcName = "uspCustOrderLineItemAdd"

For i = 1 To ItemsToPurchase
    lngProductId = m_aProductId(RandomProductID())
    intQuantity = RandomQuantity()
    Set objLineItem = New ADODB.Command
    With objLineItem
        .CommandText = strProcName
        .CommandType = ADODB.CommandTypeEnum.adCmdStoredProc
        .ActiveConnection = objConn
        
        'CREATE PARAMETERS/SET THE VALUES OF THE PAREMETERS
        .Parameters.Append objLineItem.CreateParameter("@RETURN_VALUE", adInteger, adParamReturnValue, 4)
        .Parameters.Append objLineItem.CreateParameter("@OrderId", adInteger, adParamInput, 4, lngOrderId)
        .Parameters.Append objLineItem.CreateParameter("@ProductId", adInteger, adParamInput, 4, lngProductId)
        .Parameters.Append objLineItem.CreateParameter("@LineItemNumber", adInteger, adParamInput, 4, i)
        .Parameters.Append objLineItem.CreateParameter("@Quantity", adInteger, adParamInput, 4, intQuantity)
        .Execute lngRV, Options:=adExecuteNoRecords
        'lngNewRowId = .Parameters("@RETURN_VALUE").Value
    End With
    Set objLineItem = Nothing 'destroy resources
Next

ExitProc:
    Set objCmd = Nothing
    If CBool(objConn.State And adstateopen) Then Set objConn = Nothing
    Exit Sub
    
EH:
    'will log the error and then raise an error back to client
    'On Error GoTo 0
    #If APP_MODE = DEBUG_MODE Then
        'Call LogError(strUserName:=UserName, _
            strSource:=QUALIFIEDCLASSNAME, _
            intErrorNumber:=Err.Number, _
            strDescription:=Err.Description)
    #End If
    
    Err.Raise Err.Number, _
        PROC_NAME, _
        Err.Description
End Sub

- another example put will retrieve the value of an output query (SQL)

Private Function CustomerAdd(ByVal strFirstName As String, _
    ByVal strLastName As String) As Long
    

Dim strProcName As String
Dim objConn As ADODB.Connection
Dim objCmd As ADODB.Command
Dim lngRV As Long

On Error GoTo EH
strProcName = "uspCustomerUpdate"
Const PROC_NAME As String = "CustomerAdd"
Const QUALIFIEDCLASSNAME = PROC_NAME


Set objConn = New ADODB.Connection
With objConn
    '.ConnectionString = gConnectString
    .ConnectionString = GetConnectionString()
    .Open
End With

Set objCmd = New ADODB.Command
With objCmd
    .CommandText = strProcName
    .CommandType = ADODB.CommandTypeEnum.adCmdStoredProc
    .ActiveConnection = objConn
    
    'CREATE PARAMETERS/SET THE VALUES OF THE PAREMETERS
    .Parameters.Append objCmd.CreateParameter("@RETURN_VALUE", adInteger, adParamReturnValue, 4)
    .Parameters.Append objCmd.CreateParameter("@FirstName", adVarChar, adParamInput, 20, strFirstName)
    .Parameters.Append objCmd.CreateParameter("@LastName", adVarChar, adParamInput, 40, strLastName)
    .Execute lngRV, Options:=adExecuteNoRecords
    CustomerAdd = .Parameters("@RETURN_VALUE").Value
End With

ExitProc:
    Set objCmd = Nothing
    If CBool(objConn.State And adstateopen) Then Set objConn = Nothing
    Exit Function
    
EH:
    'will log the error and then raise an error back to client
    'On Error GoTo 0
    #If APP_MODE = DEBUG_MODE Then
        'Call LogError(strUserName:=UserName, _
            strSource:=QUALIFIEDCLASSNAME, _
            intErrorNumber:=Err.Number, _
            strDescription:=Err.Description)
    #End If
    
    Err.Raise Err.Number, _
        PROC_NAME, _
        Err.Description
End Function

execute a SQL server stored procedure with ADO

Sun, 02 Nov 2008 02:40:22 GMT

Description: From a VBA execute a SQL Server stored procedure uspCustomerUPdate, passit 2 input variables and get the stored procedures RETURN VALUE

Link: http://www.codekeep.net/snippets/2c89e622-4202-4126-bcd1-dcfc676933bb.aspx

Private Function CustomerAdd(ByVal strFirstName As String, _
    ByVal strLastName As String) As Long
    

Dim strProcName As String
Dim objConn As ADODB.Connection
Dim objCmd As ADODB.Command
Dim lngRV As Long

On Error GoTo EH
strProcName = "uspCustomerUpdate"
Const PROC_NAME As String = "CustomerAdd"
Const QUALIFIEDCLASSNAME = PROC_NAME


Set objConn = New ADODB.Connection
With objConn
    '.ConnectionString = gConnectString
    .ConnectionString = GetConnectionString()
    .Open
End With

Set objCmd = New ADODB.Command
With objCmd
    .CommandText = strProcName
    .CommandType = ADODB.CommandTypeEnum.adCmdStoredProc
    .ActiveConnection = objConn
    
    'CREATE PARAMETERS/SET THE VALUES OF THE PAREMETERS
    .Parameters.Append objCmd.CreateParameter("@RETURN_VALUE", adInteger, adParamReturnValue, 4)
    .Parameters.Append objCmd.CreateParameter("@FirstName", adVarChar, adParamInput, 20, strFirstName)
    .Parameters.Append objCmd.CreateParameter("@LastName", adVarChar, adParamInput, 40, strLastName)
    .Execute lngRV, Options:=adExecuteNoRecords
    CustomerAdd = .Parameters("@RETURN_VALUE").Value
End With

ExitProc:
    Set objCmd = Nothing
    If CBool(objConn.State And adstateopen) Then Set objConn = Nothing
    Exit Function
    
EH:
    'will log the error and then raise an error back to client
    'On Error GoTo 0
    #If APP_MODE = DEBUG_MODE Then
        'Call LogError(strUserName:=UserName, _
            strSource:=QUALIFIEDCLASSNAME, _
            intErrorNumber:=Err.Number, _
            strDescription:=Err.Description)
    #End If
    
    Err.Raise Err.Number, _
        PROC_NAME, _
        Err.Description
End Function

column integer to string

Thu, 15 May 2008 20:32:29 GMT

Description: Pass the column integer and get equivalent column name in string

Link: http://www.codekeep.net/snippets/1f5693f7-390e-4c9e-ac10-240f5d8b30a6.aspx

Function ColumnLetter(ColumnNumber As Integer) As String
  If ColumnNumber > 26 Then

    ' 1st character:  Subtract 1 to map the characters to 0-25,
    '                 but you don't have to remap back to 1-26
    '                 after the 'Int' operation since columns
    '                 1-26 have no prefix letter

    ' 2nd character:  Subtract 1 to map the characters to 0-25,
    '                 but then must remap back to 1-26 after
    '                 the 'Mod' operation by adding 1 back in
    '                 (included in the '65')

    ColumnLetter = Chr(Int((ColumnNumber - 1) / 26) + 64) & _
                   Chr(((ColumnNumber - 1) Mod 26) + 65)
  Else
    ' Columns A-Z
    ColumnLetter = Chr(ColumnNumber + 64)
  End If
End Function

Named Ranges Helper function

Thu, 15 May 2008 19:47:51 GMT

Description: different helpful named range related functions.

Link: http://www.codekeep.net/snippets/36b28b0f-6dd4-454e-9c1e-787c123283ab.aspx

ThisWorkbook.Names.Add Name:="NewName", _ 
        RefersTo:="=$A$1:$C$10", Visible:=True



Function NameExists(TheName As String) As Boolean
On Error Resume Next
NameExists = Len(ThisWorkbook.Names(TheName).Name) <> 0
End Function



Function NameOfParentRange(Rng As Range) As String
Dim Nm As Name
For Each Nm In ThisWorkbook.Names
    If Rng.Parent.Name = Nm.RefersToRange.Parent.Name Then
        If Not Application.Intersect(Rng, Nm.RefersToRange) _ 
            Is Nothing Then
            NameOfParentRange = Nm.Name
            Exit Function
        End If
    End If
Next Nm
NameOfParentRange = ""
End Function


Function ExactRangeName(Rng As Range) As String
On Error Resume Next
ExactRangeName = Rng.Name.Name
End Function

VBA Macro iterate thrrough Document fields

Fri, 18 Apr 2008 13:38:18 GMT

Description: VBA Macro iterate thrrough Document fields

Link: http://www.codekeep.net/snippets/b19e9429-5872-4d55-9d84-780f2bb3d00f.aspx

Dim l As Field
Dim s As String
For Each l In ActiveDocument.Fields
If l.Index = 10 Then
    s = s + Str(l.Index) + "(" + l.Code + ")" + " ----- " + l.Result + "  " + vbCrLf
    End If
    
Next

VBA Macro code to output the entire list of fields in a post Mail Merged document

Thu, 17 Apr 2008 17:26:27 GMT

Description: This code creates a text box all so you can tell what is what.

Link: http://www.codekeep.net/snippets/9b2c831b-d857-4191-bd1b-5ff568a3a53f.aspx

Dim l As Field
Dim S As String
For Each l In ActiveDocument.Fields
    S = S + Str(l.Index) + " ----- " + l.Result + "  " + vbCrLf
    
Next
    MsgBox S

Macros for exporting current sheet or current selection to CSV

Thu, 13 Mar 2008 17:13:53 GMT

Description: These macros allow you to quickly export the current worksheet, or the current selection in Excel to a CSV file.

Link: http://www.codekeep.net/snippets/0dc17088-3e7b-4d80-a683-d6767de824c5.aspx

Option Explicit

Sub CurrentSheetToCSV()
'
' CurrentSheetToCSV Macro
' Saves the current worksheet to a CSV file Macro recorded 4/2/2007 by Andrew Ransom
'
' Keyboard Shortcut: Ctrl+w
'
    Dim currWS As Worksheet
    Dim savePath As String
    Dim saveFilename As String
    Dim wbName As String
    Dim rng As Range
    
    'The folder where we want to save
    savePath = ActiveWorkbook.Path & "\csv"
    If Len(Dir(savePath, vbDirectory)) = 0 Then
        MkDir savePath
    End If
    
    'The file name
    wbName = Replace(ActiveWorkbook.Name, ".xls", "")
    Set currWS = ActiveWorkbook.ActiveSheet
    
    saveFilename = savePath & "\" & wbName & "_" & currWS.Name & ".csv"
    
    Call ExportToTextFile(saveFilename, ",", False)
    
End Sub

Sub CurrentSelectionToCSV()
'
' CurrentSheetToCSV Macro
' Saves the current worksheet to a CSV file Macro recorded 4/2/2007 by Andrew Ransom
'
' Keyboard Shortcut: Ctrl+e
'
    Dim currWS As Worksheet
    Dim savePath As String
    Dim saveFilename As String
    Dim wbName As String
    Dim rng As Range
    
    'The folder where we want to save
    savePath = ActiveWorkbook.Path & "\csv"
    If Len(Dir(savePath, vbDirectory)) = 0 Then
        MkDir savePath
    End If
    
    'The file name
    wbName = Replace(ActiveWorkbook.Name, ".xls", "")
    Set currWS = ActiveWorkbook.ActiveSheet
    
    saveFilename = savePath & "\" & wbName & "_" & currWS.Name & ".csv"
    
    Call ExportToTextFile(saveFilename, ",", True)
    
End Sub

Public Sub ExportToTextFile(FName As String, Sep As String, SelectionOnly As Boolean)

    Dim WholeLine As String
    Dim FNum As Integer
    Dim RowNdx As Long
    Dim ColNdx As Integer
    Dim StartRow As Long
    Dim EndRow As Long
    Dim StartCol As Integer
    Dim EndCol As Integer
    Dim CellValue As String
    
    
    Application.ScreenUpdating = False
    On Error GoTo EndMacro:
    FNum = FreeFile
    
    If SelectionOnly = True Then
        With Selection
            StartRow = .Cells(1).Row
            StartCol = .Cells(1).Column
            EndRow = .Cells(.Cells.Count).Row
            EndCol = .Cells(.Cells.Count).Column
        End With
    Else
        With ActiveSheet.UsedRange
            StartRow = .Cells(1).Row
            StartCol = .Cells(1).Column
            EndRow = .Cells(.Cells.Count).Row
            EndCol = .Cells(.Cells.Count).Column
        End With
    End If
    
    Open FName For Output Access Write As #FNum
    
    For RowNdx = StartRow To EndRow
        WholeLine = ""
        For ColNdx = StartCol To EndCol
            If Cells(RowNdx, ColNdx).Value = "" Then
                CellValue = ""
            Else
               CellValue = Cells(RowNdx, ColNdx).Text
            End If
            WholeLine = WholeLine & CellValue & Sep
        Next ColNdx
        WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep))
        Print #FNum, WholeLine
    Next RowNdx
    
EndMacro:
    On Error GoTo 0
    Application.ScreenUpdating = True
    Close #FNum
End Sub

Create Labels using Word VBA

Sat, 08 Mar 2008 00:03:31 GMT

Description: This code is the key to creating labels using VBA. In addition to the labels, logos are automatically added to each label. (If someone has a better way to do this, please let me know!)

Link: http://www.codekeep.net/snippets/ec5aacca-596f-4a93-b7f9-74180f297d4d.aspx

Private Sub GenerateLabels()
    Const LabelName = "5164" 'Specify the label type.  This can be defined here or come from a variable.
    dim AddressString as string
    ' Set AddressString in code, form, or wherever is appropriate
    Application.MailingLabel.DefaultPrintBarCode = False
    Application.MailingLabel.CreateNewDocument LabelName, AddressString & vbCrLf & vbCrLf & txtMessage.Text
    DoEvents
    ' Add logo to each label
    Dim z As Integer
    For z = 1 To 6 ' Iterate through each label.  This number will depend on the label type.
        Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
            "INCLUDEPICTURE  ""http://webAddress/logo.jpg"" ", PreserveFormatting:=True
        ' Be sure logo source is on the web so others will have access to it.  This
        ' section of the macro only works if users have access to the logo.
        Selection.TypeParagraph
        Selection.EndKey unit:=wdLine
        Selection.Find.ClearFormatting
        With Selection.Find
            .Text = Left(AddressString, 10)
            .Forward = True
            .Wrap = wdFindContinue
            .MatchWholeWord = False
        End With
        Selection.Find.Execute
        Selection.HomeKey unit:=wdLine
    Next
    Unload Me
End Sub

Remove Duplicate Contacts in Outlook

Fri, 22 Feb 2008 18:51:27 GMT

Description: This code will check Outlook contacts and compare key fields to determine whether or not the record is duplicated. If so, the macro "deletes" the extra record. Be sure to check the comparison criteria to meet your needs.

Link: http://www.codekeep.net/snippets/49ff4e3d-dee1-485a-a9d8-b7753294ebed.aspx

Sub RemoveDuplicateContacts()
    Dim StatusMessage As String
    Dim olApp As Outlook.Application
    Dim olContact1 As Outlook.ContactItem
    Dim olContact2 As Outlook.ContactItem
    Dim olItems As Outlook.Items
    Dim olNS As Outlook.NameSpace
    
    Set olApp = New Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    Set olItems = olNS.GetDefaultFolder(olFolderContacts).Items
    olItems.Sort ("File As")
    Dim DeleteCount As Integer
    Dim z As Integer
    DeleteCount = 0
    StatusMessage = ""
    For z = olItems.Count To 2 Step -1
        On Error GoTo GroupFound:
ContinueAfterGroup:
        Set olContact1 = olItems.Item(z)
        Set olContact2 = olItems.Item(z - 1)
        On Error GoTo Error1:
        DoEvents
        ' Check key fields to make sure this is a duplicate
        ' Compare first and last names, home phone, mobile phone, and
        ' all 3 e-mail addresses to make sure nothing gets overlooked.
        ' Assume all other fields are the same or unimportant
        If olContact1.FileAs = olContact2.FileAs _
            And olContact1.FirstName = olContact2.FirstName _
            And olContact1.LastName = olContact2.LastName _
            And olContact1.Email1Address = olContact2.Email1Address _
            And olContact1.Email2Address = olContact2.Email2Address _
            And olContact1.Email3Address = olContact2.Email2Address _
            And olContact1.HomeTelephoneNumber = olContact2.HomeTelephoneNumber _
            And olContact1.MobileTelephoneNumber = olContact2.MobileTelephoneNumber _
          Then
            'Determine whether or not addresses exist
            If olContact1.MailingAddress = olContact2.MailingAddress Then
                ' Uncomment the following line to actually perform the deletes
                'olContact1.Delete
                StatusMessage = StatusMessage & "Contact item " & olContact2.FileAs & _
                    " deleted" & vbCrLf & vbCrLf
                Debug.Print "Contact item " & olContact2.FileAs & " deleted"
                DeleteCount = DeleteCount + 1
            Else
                StatusMessage = StatusMessage & "Mailing addresses are not the same for contacts " & _
                    olContact1.FileAs & "." & vbCrLf & _
                    "Contact not deleted. You may want to manually update " & _
                    "the contact information." & vbCrLf & vbCrLf
                Debug.Print "Mailing addresses are not the same for contacts " & _
                    olContact1.FileAs & ".  Please investigate."
            End If
        End If
    Next
    MsgBox DeleteCount & " duplicate Outlook Contacts have been removed" & _
        vbCrLf & vbCrLf & StatusMessage
    Exit Sub
GroupFound:
    z = z - 1
    Resume ContinueAfterGroup:
Error1:
    MsgBox "Whoops!  Something went horribly wrong!"
End Sub

Remove Duplicate Outlook Notes

Wed, 20 Feb 2008 16:28:42 GMT

Description: This macro will step through Outlook notes and remove duplicates based on the content of the note body.

Link: http://www.codekeep.net/snippets/390617ab-bb4b-4b00-9625-d2bf54614133.aspx

Sub RemoveDuplicateNotes()
    Dim olApp As Outlook.Application
    Dim olNote1 As Outlook.NoteItem
    Dim olNote2 As Outlook.NoteItem
    Dim olItems As Outlook.Items
    Dim olNS As Outlook.NameSpace
    
    Set olApp = New Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    Set olItems = olNS.GetDefaultFolder(olFolderNotes).Items
    olItems.Sort ("Subject")
    Dim DeleteCount As Integer
    Dim z As Integer
    DeleteCount = 0
    
    For z = olItems.Count To 2 Step -1
        Set olNote1 = olItems.Item(z)
        Set olNote2 = olItems.Item(z - 1)
        DoEvents
        If olNote1.Body = olNote2.Body Then
            olNote1.Delete
            Debug.Print "Note item " & Left(olNote2.Subject, 25) & "..." & " deleted"
            DeleteCount = DeleteCount + 1
        End If
    Next
    MsgBox DeleteCount & " duplicate Outlook Notes have been removed"
End Sub

Update Reminder Times in Outlook 2003

Fri, 08 Feb 2008 16:50:17 GMT

Description: This macro iterates through events in Outlook and updates the reminder time for all day events. The code can be used as a sample to perform all sorts of other tasks.

Link: http://www.codekeep.net/snippets/9b267d06-a47d-4b7c-821b-b1c8b34f5ef9.aspx

Option Explicit
Sub SetOutlookReminders()
    Dim olApp As Outlook.Application
    Dim olAppointment As AppointmentItem
    Dim olItems As Outlook.Items
    Dim olNS As Outlook.NameSpace
    Dim updateCount As Integer
    
    Set olApp = New Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    Set olItems = olNS.GetDefaultFolder(olFolderCalendar).Items
    
    updateCount = 0

    Dim z As Integer
    
    For z = 1 To olItems.Count
        Set olAppointment = olItems.Item(z)
        With olAppointment
            ' Check to see if the event is an "all day" event, and whether or not it
            ' already has a reminder set.  If both criteria are true, update the 
            ' reminder time.
            If .ReminderSet And .AllDayEvent Then
                ' Set reminder for 6 hours
                .ReminderMinutesBeforeStart = 360
                .Save
                updateCount = updateCount + 1
                Debug.Print updateCount & " Updated:  " & .Subject
            End If
        End With
    Next
    
    MsgBox "Done!  " & updateCount & " items updated!"
    
    Set olAppointment = Nothing
    Set olItems = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
    
End Sub

aprire una form solo da codice

Fri, 01 Feb 2008 08:43:59 GMT

Description: Form Open OpenArgs

Link: http://www.codekeep.net/snippets/6ab049ce-e164-4759-bbb7-1223e4401f00.aspx

Private Sub Form_Open(Cancel As Integer)
If IsNull(Me.OpenArgs) Then
    MsgBox "xxx"
    Cancel = True
End If

....

End Sub

errore di immissione in una form

Fri, 01 Feb 2008 08:26:22 GMT

Description: Form error

Link: http://www.codekeep.net/snippets/215e2756-662e-4de5-88c5-2f083b25157a.aspx

Private Sub Form_Error(DataErr As Integer, Response As Integer)
    
    Response = acDataErrContinue
    If DataErr = 2113 Then
        MsgBox "Valore non corretto. controllare l'immissione", vbInformation
    End If

End Sub

apertura di una form per l'immissione

Fri, 01 Feb 2008 08:24:12 GMT

Description: docmd acNewRec acDataForm

Link: http://www.codekeep.net/snippets/e58218b3-3c63-4bfd-87ba-ecf648e59769.aspx

Private Sub Form_Load()

    DoCmd.GoToRecord acDataForm, "Nuovo torneo", acNewRec

selezione dell'utlimo record in una form a tabella

Fri, 01 Feb 2008 07:33:58 GMT

Description: bookmark recordsetclone usati per il posizionamento nell'origine dati di una form

Link: http://www.codekeep.net/snippets/d7e3b53c-3dc6-43d5-a5ee-ac33c9a06c41.aspx

Dim rst As Recordset

    Set rst = Me.Turni.Form.RecordsetClone
    rst.MoveLast
    Me.Turni.Form.Bookmark = rst.Bookmark

Sottomaschere e origine dati

Tue, 29 Jan 2008 09:20:10 GMT

Description: definire l'origine dati delle sottomaschere a runtime

Link: http://www.codekeep.net/snippets/2a723965-a5b4-4d21-ba9d-1659597c8caf.aspx

Private rstCoppieSelezionabili As Recordset
Private rstCoppieTorneo As Recordset

Private Sub Form_Load()

Dim qdf As QueryDef
Dim rst As Recordset
    
    Set qdf = CurrentDb.QueryDefs("coppie_selezionabili")
    qdf("par_torneo_id") = Globali.CurrentTorneo.id
    Set rstCoppieSelezionabili = qdf.OpenRecordset
    Set Me.Selezione_Coppie.Form.Recordset = rstCoppieSelezionabili

    Set qdf = CurrentDb.QueryDefs("coppie_torneo")
    qdf("par_torneo_id") = Globali.CurrentTorneo.id
    Set rstCoppieTorneo = qdf.OpenRecordset
    Set Me.Coppie.Form.Recordset = rstCoppieTorneo

Numeri interi casuali

Tue, 29 Jan 2008 09:13:36 GMT

Description: Uso di Randomize e Rnd

Link: http://www.codekeep.net/snippets/a133c0dc-872e-48a6-bf9e-26721bd09754.aspx

Randomize   ' generatore inizializzato tramite l'orologio di sistema
For k = 0 To n
   i = estrai(limite_inferiore, limite_superiore)

Private Function estrai(limite_inf As Integer, limite_sup As Integer) As Integer
    
    estrai = Int((limite_sup - limite_inf + 1) * Rnd + limite_inf)

End Function

Transazioni DAO

Tue, 29 Jan 2008 09:09:34 GMT

Description: BeginTrans CommitTrans Rollback

Link: http://www.codekeep.net/snippets/da2668d0-c165-4429-b33c-6309d5fa527f.aspx

    
On Error GoTo gesterr
    Set wrkCurrent = DBEngine.Workspaces(0)
    wrkCurrent.BeginTrans

    With rst
        While Not .EOF
            qdf_update("par_1") = !par
            qdf_update("par_2") = !par2
            qdf_update.Execute
            .MoveNext
        Wend
    End With
    
    wrkCurrent.CommitTrans
    Exit Sub
        
gesterr:
    wrkCurrent.Rollback
    Err.Raise xxx