CodeKeep VBScript Feed

WhoIsLoggedIn.vbs

Thu, 19 Apr 2012 19:49:37 GMT

Description: This script will return user detail from active directory for a given IP Address or Host Name.

Link: http://www.codekeep.net/snippets/a4c58b26-3467-482a-8647-576518602de4.aspx

On Error Resume Next

WScript.StdOut.Write("IP Address/Computer Name> ")
WScript.StdIn.Read(0)
strComputer = WScript.StdIn.ReadLine()

If IsHostAlive(strComputer) = False Then Wscript.quit

For Each strComputer In arrComputers
	Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
	Set colItems = objWMIService.ExecQuery("Select * from Win32_ComputerSystem",,48)
  	For Each objItem in colItems
			If IsNull(objItem.UserName) = False Then
    		Wscript.Echo "Computer Name: " & objItem.DNSHostName
    		Wscript.Echo "UserName: " & objItem.UserName
    		GetUserName(objItem.UserName)
    	Else
    		Wscript.Echo "Computer Name: " & objItem.DNSHostName
    		Wscript.Echo "UserName: Null"
    	End If
   	Next
Next

'*******************************************************************************

Function GetUserName(LoginID)
	' Constants for the NameTranslate object.
	Const ADS_NAME_INITTYPE_GC = 3
	Const ADS_NAME_TYPE_NT4 = 3
	Const ADS_NAME_TYPE_1779 = 1

	' Determine DNS name of domain from RootDSE.
	Set objRootDSE = GetObject("LDAP://RootDSE")
	strDNSDomain = objRootDSE.Get("defaultNamingContext")

	' Use the NameTranslate object to find the NetBIOS domain name from the
	' DNS domain name.
	Set objTrans = CreateObject("NameTranslate")
	objTrans.Init ADS_NAME_INITTYPE_GC, ""
	objTrans.Set ADS_NAME_TYPE_1779, strDNSDomain
	strNetBIOSDomain = objTrans.Get(ADS_NAME_TYPE_NT4)
	' Remove trailing backslash.
	strNetBIOSDomain = Left(strNetBIOSDomain, Len(strNetBIOSDomain) - 1)

	strNTName = Trim(LoginID)

	' Use the Set method to specify the NT format of the object name.
	' Trap error if user does not exist.
	On Error Resume Next

	objTrans.Set ADS_NAME_TYPE_NT4, strNTName

	If (Err.Number = 0) Then
		On Error GoTo 0
		' Use the Get method to retrieve the RPC 1779 Distinguished Name.
		strUserDN = objTrans.Get(ADS_NAME_TYPE_1779)

		' Bind to the user object (if desired).
		Set objUser = GetObject("LDAP://" & strUserDN)
		' Do whatever you want...
		wscript.echo "Name: " & objUser.GivenName & " " & objUser.sn
		wscript.echo "Phone: " & objUser.physicalDeliveryOfficeName
		wscript.echo "Office: " & objUser.telephonenumber
		wscript.echo "Mobile: " & objUser.mobile
	Else
		On Error GoTo 0
		' Alert user about bad user name.
		Wscript.Echo "User " & strNTName & " does not exist"
	End If
End Function


Function IsHostAlive(strComputer)
        IsHostAlive = False                                ' normally we will return false, unless ping is successful

        Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
        Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_PingStatus WHERE Address = '" + strComputer + "'")

        For Each oRow In colItems
          	Select Case oRow.StatusCode
          		Case 0
          			IsHostAlive = True
          			wscript.echo strComputer & " is alive..."
				      Case 11001 wscript.echo "Buffer Too Small"
      				Case 11002 wscript.echo "Destination Net Unreachable"
      				Case 11003 wscript.echo "Destination Host Unreachable"
      				Case 11004 wscript.echo "Destination Protocol Unreachable"
      				Case 11005 wscript.echo "Destination Port Unreachable"
      				Case 11006 wscript.echo "No Resources"
							Case 11007 wscript.echo "Bad Option"
      				Case 11008 wscript.echo "Hardware Error"
      				Case 11009 wscript.echo "Packet Too Big"
      				Case 11010 wscript.echo "Request Timed Out"
      				Case 11011 wscript.echo "Bad Request"
      				Case 11012 wscript.echo "Bad Route"
      				Case 11013 wscript.echo "TimeToLive Expired Transit"
      				Case 11014 wscript.echo "TimeToLive Expired Reassembly"
      				Case 11015 wscript.echo "Parameter Problem"
      				Case 11016 wscript.echo "Source Quench"
      				Case 11017 wscript.echo "Option Too Big"
      				Case 11018 wscript.echo "Bad Destination"
      				Case 11032 wscript.echo "Negotiating IPSEC"
      				Case 11050 wscript.echo "General Failure"
      				Case Else wscript.echo "Status code " & objPing.StatusCode & " - Unable to determine cause of failure."
    		End Select
        Next
End Function

FreeDiskSpace Function

Wed, 18 Apr 2012 20:18:40 GMT

Description: http://www.alanphipps.com/VBScript-DiskFile.html#FreeSpace Adapted from URL above. This function can easily be adapted to output the integer value of available drive space in kilo, mega or gigabytes.

Link: http://www.codekeep.net/snippets/e7a1e24e-6142-4cb5-a9b2-c6c1b6c43576.aspx

Function FreeDiskSpace(DriveLetter)
   ' Returns the number of free Megabytes on a given drive
   ' http://www.alanphipps.com/VBScript-DiskFile.html
   ' Instantiate the VBScript FileSystemObject
   Set FsoObject = WScript.CreateObject("Scripting.FileSystemObject")

   ' Use the FilesystemObject Object's GetDrive Method
   Set DiskDrive = FsoObject.GetDrive(FsoObject.GetDriveName(DriveLetter & ":"))

   ' Main Processing Section

   ' Use the FileSystemObjects FreeSpace Property to Determine the Amount of FreeSpace in MB
   ' on the C: Drive

   AvailSpacebytes = DiskDrive.FreeSpace
   AvailSpaceKB = DiskDrive.FreeSpace / 1024
   AvailSpaceMB = (DiskDrive.FreeSpace / 1024) / 1024
   AvailSpaceGB = ((DiskDrive.FreeSpace / 1024) / 1024) / 1024

   ' Use VBScripts FormatNumber Function to format the results as a Whole Number
   AvailSpacebytes = FormatNumber(AvailSpacebytes, 0)
   AvailSpaceKB = FormatNumber(AvailSpaceKB, 0)
   AvailSpaceMB = FormatNumber(AvailSpaceMB, 0)
   AvailSpaceGB = FormatNumber(AvailSpaceGB, 0)

   ' Display the Amount of Free Space on the C: Drive
   WScript.Echo "There is Currently: " & AvailSpacebytes & " bytes available on the C: Drive" & vbCrLf & _
   "There is Currently: " & AvailSpaceKB & "KB available on the C: Drive" & vbCrLf & _
   "There is Currently: " & AvailSpaceMB & "MB available on the C: Drive" & vbCrLf & _
   "There is Currently: " & AvailSpaceGB & "GB available on the C: Drive" & vbCrLf

   FreeDiskSpace = AvailSpaceMB
End Function

VBA: Export Charts in Excel 2007

Fri, 10 Feb 2012 15:55:36 GMT

Description: to export all the charts in active sheet in Excel

Link: http://www.codekeep.net/snippets/316b54c0-11cd-49fb-9193-6c191d33aea2.aspx

Sub ExportCharts()
   
    Dim objCht As ChartObject
    Dim strPath As String
   
    strPath = "C:\@Projects\_R9Insite\pages\fas\images\chart\"
   
    For Each objCht In Sheets("Sheet1").ChartObjects
        objCht.Chart.Export strPath & objCht.Name & ".gif", filtername:="gif"
    Next

End Sub

QTP DOM

Fri, 21 Oct 2011 01:13:11 GMT

Description: Access sibling/parent in QTP

Link: http://www.codekeep.net/snippets/60ad6f69-4c4e-409e-a992-7660857b039c.aspx

rc = Browser("name:=.*WebSeries.*").Page("title:=.*").WebButton("type:=button","index:=7").Object.PreviousSibling.innertext
MsgBox(rc)

Set oPwBox1 = Browser("micclass:=Browser").Page("micclass:=Page").WebEdit("html tag:=INPUT", "name:=char1")
oPwBox1.Object.parentNode.previousSibling.innertext

Setting the style of the DataGridView control

Tue, 27 Sep 2011 06:27:36 GMT

Description: Setting the style of the DataGridView control

Link: http://www.codekeep.net/snippets/4840d10e-4791-4434-85f2-7896147d902d.aspx

' Setting the style of the DataGridView control
        DataGridView1.ColumnHeadersDefaultCellStyle.Font = New Font("Tahoma", 8, FontStyle.Bold, GraphicsUnit.Point)
        DataGridView1.ColumnHeadersDefaultCellStyle.BackColor = SystemColors.ControlDark
        DataGridView1.ColumnHeadersBorderStyle = DataGridViewHeaderBorderStyle.[Single]
        DataGridView1.ColumnHeadersDefaultCellStyle.Alignment = DataGridViewContentAlignment.MiddleCenter
        DataGridView1.DefaultCellStyle.Font = New Font("Tahoma", 8, FontStyle.Regular, GraphicsUnit.Point)
        DataGridView1.DefaultCellStyle.BackColor = Color.Empty
        DataGridView1.AlternatingRowsDefaultCellStyle.BackColor = SystemColors.ControlLight
        DataGridView1.CellBorderStyle = DataGridViewCellBorderStyle.[Single]
        DataGridView1.GridColor = SystemColors.ControlDarkDark

Macro for toggle comment block in VS

Wed, 23 Feb 2011 05:12:24 GMT

Description: This will comment/uncomment out single lines or blocks. Single lines are commented with the same indention level. Blocks are commented at the beginning of the line. Assign this to a key (e.g. ctrl-/) and it will toggle the current line/bloc

Link: http://www.codekeep.net/snippets/694ef029-4d64-4b7d-b42d-866cfd7a0c4c.aspx

Imports System
Imports EnvDTE
Imports EnvDTE80
Imports EnvDTE90
'Imports EnvDTE90a
'Imports EnvDTE100
Imports System.Diagnostics

Public Module ToggleComment
    'Constant              Value
    '---------------------------
    'dsMove                  0
    'dsExtend                1
    'dsFirstColumn           0
    'dsFirstText             1
    'dsLowercase             1
    'dsUppercase             2
    'dsCapitalize            3
    'dsHorizontal            0
    'dsVertical              1
    'dsLastLine              -1
    'dsDevStudio             0
    'dsVC2                   1
    'dsBrief                 2
    'dsEpsilon               3
    'dsCustom                4
    'dsMatchWord             2
    'dsMatchCase             4
    'dsMatchNoRegExp         0
    'dsMatchRegExp           8
    'dsMatchRegExpB          16
    'dsMatchRegExpE          32
    'dsMatchRegExpCur        64
    'dsMatchForward          0
    'dsMatchBackward         128
    'dsMatchFromStart        256
    'dsWindowStateMaximized  1
    'dsWindowStateMinimized  2
    'dsWindowStateNormal     3
    'dsMinimize              1
    'dsTileHorizontal        2
    'dsTileVertical          3
    'dsCascade               4
    'dsGlyph                 1
    'dsText                  2
    'dsSaveChangesYes        1
    'dsSaveChangesNo         2
    'dsSaveChangesPrompt     3
    'dsSaveSucceeded         1
    'dsSaveCanceled          2
    'dsTextDocument          "Text"
    'dsVBSMacro              "VBS Macro"
    'dsJava                  "Java"
    'dsCPP                   "C/C++"
    'dsIDL                   "ODL/IDL"
    'dsHTML_IE3              "HTML - IE 3.0"
    'dsHTML_RFC1866          "HTML 2.0 (RFC 1866)"
    'dsFortran_Fixed         "Fortran Fixed"
    'dsFortran_Free          "Fortran Free"

    '----------------------------------------------------------------------------------
    ' This routine has many uses if you are trying to determine the type of source file.
    ' This has been modified from the one included with DevStudio
    ' Return value:  0 Unknown file type
    '               1 C-related file, this includes .c, .cpp, .cxx, .h, .hpp, .hxx
    '               2 Java-related file, this includes .jav, .java
    '               3 ODL-style file, .odl, .idl
    '               4 VBS-style file, .dsm
    '               5 VBS-style file, .asp
    '               6 HTML-style file, this includes .html, and .htm
    '               7 Resource file, .rc, .rc2
    '               8 Def-style file, .def
    ' USE: Pass this function the document that you wish to get information for.
    '----------------------------------------------------------------------------------
    Function FileType(ByVal doc)
        Dim ext = doc.Name
        FileType = 0
        Dim pos = InStr(ext, ".")
        If pos > 0 Then
            Do While pos <> 1
                ext = Mid(ext, pos, Len(ext) - pos + 1)
                pos = InStr(ext, ".")
            Loop
            ext = LCase(ext)
        End If

        If ext = ".rc" Or ext = ".rc2" Then
            FileType = 7
        ElseIf doc.Language = EnvDTE.Constants.dsCPP Then
            FileType = 1
        ElseIf doc.Language = EnvDTE.Constants.dsJava Then
            FileType = 2
        ElseIf doc.Language = EnvDTE.Constants.dsIDL Then
            FileType = 3
        ElseIf ext = ".js" Then
            FileType = 4
        ElseIf doc.Language = EnvDTE.Constants.dsVBSMacro Then
            FileType = 5
        ElseIf ext = ".asp" Then
            FileType = 6
        ElseIf doc.Language = EnvDTE.Constants.dsHTML_IE3 Or doc.Language = EnvDTE.Constants.dsHTML_RFC1866 Then
            FileType = 7
        ElseIf ext = ".def" Then
            FileType = 8
        Else
            FileType = 0
        End If

        'MsgBox "Ext:" + vbTab + ext + vbLf + "Lang:" + vbTab + doc.Language + vbLf + "Type:" + vbTab + CStr(FileType)
    End Function

    '------------------------------------------------------------------------------
    'FILE DESCRIPTION: These are useful macros by Adam Solesby [adam@solesby.com]
    '------------------------------------------------------------------------------


    '----------------------------------------------------------------------------------
    ' This will comment/uncomment out single lines or blocks. Single lines are commented 
    ' with the same indention level. Blocks are commented at the beginning of the line.
    ' Assign this to a key (e.g. ctrl-/) and it will toggle the current line/block of code.
    ' This will handle both "//" and "'" style comments
    '
    ' Author: Adam Solesby -- http://solesby.com, Sowrov -- http://sowrov.com
    '----------------------------------------------------------------------------------

    Sub Switch()
        Dim dsFirstColumn = 0
        Dim dsFirstText = 1
        'DESCRIPTION: Comments out a selected block of text. (ctrl-/)
        If DTE.ActiveDocument.Type <> "Text" Then
            MsgBox("This macro can only be run when a text editor window is active.")
        Else
            Dim TypeOfFile = FileType(DTE.ActiveDocument)
            Dim CommentType, CommentWidth, StartLine, EndLine, Temp, s, n
            '	MsgBox "Type: " + CStr(TypeOfFile)
            If TypeOfFile > 0 And TypeOfFile < 7 Then
                If TypeOfFile > 4 Then
                    CommentType = "'"   ' VBShit
                    CommentWidth = 1
                Else
                    CommentType = "//"  ' C++ and java style comments

                    CommentWidth = 2
                End If
                StartLine = ActiveDocument.Selection.TopLine
                EndLine = ActiveDocument.Selection.BottomLine
                If EndLine < StartLine Then
                    Temp = StartLine
                    StartLine = EndLine
                    EndLine = Temp
                End If
                ' single line with words selected
                If EndLine = StartLine And Len(ActiveDocument.Selection.Text) > 0 Then
                    s = ActiveDocument.Selection.Text
                    n = Len(ActiveDocument.Selection.Text)
                    ' convert "/*sample text*/" => "sample text" ("/*sample text*/" selected)
                    If Left(s, 2) = "/*" And Right(s, 2) = "*/" Then
                        ActiveDocument.Selection.Text = Mid(s, 3, n - 4)
                    Else
                        ActiveDocument.Selection.CharLeft()
                        ActiveDocument.Selection.CharLeft(EnvDTE.DsMovementOptions.dsMove, 2)
                        ActiveDocument.Selection.CharRight(EnvDTE.DsMovementOptions.dsExtend, n + 4)
                        Dim s2 = ActiveDocument.Selection.Text
                        ' convert "/*sample text*/" => "sample text" ("sample text" selected)
                        If Left(s2, 2) = "/*" And Right(s2, 2) = "*/" Then
                            ActiveDocument.Selection.Text = s

                            ' convert "sample text" => "/*sample text*/" ("sample text" selected)
                        Else
                            ActiveDocument.Selection.CharLeft()
                            ActiveDocument.Selection.CharRight(EnvDTE.DsMovementOptions.dsMove, 2)
                            ActiveDocument.Selection.CharRight(EnvDTE.DsMovementOptions.dsExtend, n)
                            ActiveDocument.Selection.Text = "/*" & s & "*/"
                        End If

                    End If

                    ' Single line -- comment at start of text
                    '   have to check for comments at start of line and start of text
                ElseIf EndLine = StartLine Then
                    ActiveDocument.Selection.StartOfLine(dsFirstText)
                    ActiveDocument.Selection.CharRight(EnvDTE.DsMovementOptions.dsExtend, CommentWidth)
                    If ActiveDocument.Selection.Text = CommentType Then
                        ActiveDocument.Selection.Delete()
                    Else
                        'ActiveDocument.Selection.StartOfLine(dsFirstText)
                        'ActiveDocument.Selection.CharRight(EnvDTE.DsMovementOptions.dsExtend, CommentWidth)
                        'If ActiveDocument.Selection.Text = CommentType Then

                        '    ActiveDocument.Selection.CharLeft()
                        '    ActiveDocument.Selection.EndOfLine(EnvDTE.DsMovementOptions.dsExtend)
                        '    s = ActiveDocument.Selection.Text
                        '    s = LTrim(Mid(s, 3))

                        '    Do While Left(s, 1) = vbTab
                        '        s = LTrim(Mid(s, 2))
                        '    Loop

                        '    ActiveDocument.Selection.Text = s

                        'Else
                        ActiveDocument.Selection.StartOfLine(dsFirstText)
                        ActiveDocument.Selection.Text = CommentType + ActiveDocument.Selection.Text
                        'End If
                    End If
                    ActiveDocument.Selection.StartOfLine(dsFirstText)

                    ' Multi-line -- comment at start of line
                Else
                    Dim CommentLoc = 1 'dsFirstText
                    Dim bAddComment
                    '' check whether commenting on or off based on the _last_ line of selection
                    'ActiveDocument.Selection.GoToLine(EndLine)
                    'ActiveDocument.Selection.StartOfLine(CommentLoc)
                    'ActiveDocument.Selection.CharRight(EnvDTE.DsMovementOptions.dsExtend, CommentWidth)
                    'If ActiveDocument.Selection.Text = CommentType Then
                    '    bAddComment = False
                    'Else
                    '    bAddComment = True
                    'End If

                    ' now do it to each line
                    For i = StartLine To EndLine
                        ActiveDocument.Selection.GoToLine(i)
                        ActiveDocument.Selection.StartOfLine(CommentLoc)
                        ActiveDocument.Selection.CharRight(EnvDTE.DsMovementOptions.dsExtend, CommentWidth)
                        If ActiveDocument.Selection.Text = CommentType Then
                            'ActiveDocument.Selection.CharRight(EnvDTE.DsMovementOptions.dsExtend, CommentWidth)
                            ActiveDocument.Selection.Delete()
                        Else
                            ActiveDocument.Selection.Text = CommentType + ActiveDocument.Selection.Text
                        End If
                    Next

                    ' work with strings so that we can do a single undo in editor
                    'ActiveDocument.Selection.MoveTo(StartLine, 1)
                    'DTE.ActiveDocument.Selection.LineDown(True, EndLine - StartLine + 1)
                    's = ActiveDocument.Selection.Text

                    'If bAddComment Then
                    '    s = CommentType & Replace(s, vbNewLine, vbNewLine & CommentType)
                    'Else
                    '    s = Replace(s, vbNewLine & CommentType, vbNewLine)
                    '    s = Mid(s, Len(CommentType) + 1)
                    'End If
                    ''MsgBox(s)
                    'ActiveDocument.Selection.Text = s

                End If
            Else
                MsgBox("Unable to comment out the highlighted text" + vbLf + _
                 "because the file type was unrecognized." + vbLf + _
                 "If the file has not yet been saved, " + vbLf + _
                 "please save it and try again.")
            End If
        End If
    End Sub

End Module

GUID Macro

Fri, 20 Aug 2010 08:39:02 GMT

Description: GUID Macro

Link: http://www.codekeep.net/snippets/20ca2dca-beca-43c2-b358-3df53705a249.aspx

Sub InsertGuid()
  Dim objTextSelection As TextSelection
  objTextSelection = CType(DTE.ActiveDocument.Selection(), EnvDTE.TextSelection)
  objTextSelection.Text = System.Guid.NewGuid.ToString("D").ToUpperInvariant
End Su

VerifyCScript

Tue, 22 Sep 2009 15:04:13 GMT

Description: This subroutine will make sure the script is being run with the Cscript and not Wscript engine.

Link: http://www.codekeep.net/snippets/b2c7be41-b040-4ac5-87a5-2e3ac214e23f.aspx

Sub VerifyCscript 
    'When called, confirms script is being run with Cscript engine.
    'If not, it calls the original script with the Cscript egine 
    'including all passed parameters and end current wscript instance.

    Dim objShell, Return, strCmd, strArg
    if lcase(right(wscript.fullname,11))="wscript.exe" then
        set objShell = CreateObject("wscript.shell")
        strCmd = "cscript.exe " & chr(34) & WScript.ScriptFullName & chr(34)
        if objArgs.Count > 0 then
            for each strArg in objArgs
                strCmd = strCmd & " " & strArg
            next
        end if
        Return = objShell.Run (strCmd,1,false)
        set objShell = nothing
        wscript.quit
    end if
end sub 'End of VerifyCScript

VBscript - List All files in a folder

Mon, 11 May 2009 00:59:40 GMT

Description: Vbscript - List all files in a folder.

Link: http://www.codekeep.net/snippets/bc9ec2b5-f0ea-4075-8419-81b19e9157b5.aspx

On Error Resume Next  
Dim fso, folder, files, NewsFile,sFolder, objTextFile
Const ForReading = 1

Set fso = CreateObject("Scripting.FileSystemObject")
Set objOutputFile = fso.CreateTextFile("AllFileNames.txt")
currentPath  = Replace(Wscript.ScriptFullName, "\" & Wscript.ScriptName, "")

sFolder = Wscript.Arguments.Item(0)  
	If sFolder = "" Then      
		sFolder =  currentPath 
	End If

Set files = fso.GetFolder(sFolder).Files
Echo "Chirag"
For each file In files    
	if lcase(objFSO.getExtensionName(file.name))="mp3" Then
		objOutputFile.WriteLine file.name
	End if
Next  
objOutputFile.Close

List and combine all text files in a folder

Thu, 07 May 2009 19:17:12 GMT

Description: VBScript code to combine all text ( sql ) files in one file

Link: http://www.codekeep.net/snippets/9adfec8a-3167-4065-8762-2dd4c031ade4.aspx

On Error Resume Next  
Dim fso, folder, files, NewsFile,sFolder, objTextFile
Const ForReading = 1

Set fso = CreateObject("Scripting.FileSystemObject")
Set objOutputFile = fso.CreateTextFile("EMDAllStoredProcedures.sql")
currentPath  = Replace(Wscript.ScriptFullName, "\" & Wscript.ScriptName, "")

sFolder = Wscript.Arguments.Item(0)  
	If sFolder = "" Then      
		sFolder =  currentPath & "\Stored Procedures"
		'Wscript.Echo sFolder
		'Wscript.Quit  
	End If

Set files = fso.GetFolder(sFolder).Files
Echo file.Count
For each folderIdx In files    
	if lcase(objFSO.getExtensionName(file.path))="txt" then
		Set objTextFile = fso.OpenTextFile(folderIdx.path, ForReading) 
		strText = objTextFile.ReadAll
		objTextFile.Close
		objOutputFile.WriteLine strText
	End if
Next  
objOutputFile.Close

Escapes invalid text for XML

Fri, 20 Feb 2009 17:20:32 GMT

Description: Removes invalid xml characters

Link: http://www.codekeep.net/snippets/bf9456f1-676f-442a-907a-b985cbceba80.aspx

Function Format4XML(str)
  str = replace(str, "&", "&amp;")
  str = replace(str, "\", "&quot;")
  str = replace(str, "'", "&apos;")
  str = replace(str, "<", "&lt;")
  str = replace(str, ">", "&gt;")
  Format4XML = str
end function

Eventhandler f�r Controls im MS Datagrid verdrahten

Wed, 04 Feb 2009 13:19:13 GMT

Description: Um auf den Controls in einem MS Datagrid Events zu verdrahten muss man sich durch den Visualtree arbeiten

Link: http://www.codekeep.net/snippets/d3b46a82-0fb9-4674-a3bb-e0e730bc70ee.aspx

     Private Function AddCheckBoxHandlers() As Boolean

         Try
            Dim oRowsPresenter As DataGridRowsPresenter = Helpers.GetRowsPresenter(dgData)
            If Not oRowsPresenter Is Nothing Then
               For Each oRow In oRowsPresenter.Children
                  Dim oDataGridRow = TryCast(oRow, DataGridRow)
                  If oDataGridRow Is Nothing Then Continue For

                  Dim oRowBorder = TryCast(VisualTreeHelper.GetChild(oDataGridRow, 0), Border)
                  If oRowBorder Is Nothing Then Continue For

                  Dim oScrollingGrid = TryCast(oRowBorder.Child, SelectiveScrollingGrid)
                  If oScrollingGrid Is Nothing Then Continue For

                  Dim oCellsPresenter = TryCast(oScrollingGrid.Children(0), DataGridCellsPresenter)
                  If oCellsPresenter Is Nothing Then Continue For

                  Dim oCellsItemsPresenter = TryCast(VisualTreeHelper.GetChild(oCellsPresenter, 0), ItemsPresenter)
                  If oCellsItemsPresenter Is Nothing Then Continue For

                  Dim oCellsPanel = TryCast(VisualTreeHelper.GetChild(oCellsItemsPresenter, 0), DataGridCellsPanel)
                  If oCellsPanel Is Nothing Then Continue For

                  For Each oChild In oCellsPanel.Children
                     Dim oCell = TryCast(oChild, DataGridCell)
                     If oCell Is Nothing Then Continue For

                     Dim oCheckBoxColumn = TryCast(oCell.Column, DataGridCheckBoxColumn)
                     If Not oCheckBoxColumn Is Nothing Then
                        Dim oCheckBox = TryCast(oCell.Content, CheckBox)
                        If oCheckBox Is Nothing Then Continue For
                        AddHandler oCheckBox.Checked, AddressOf dgDataCheck_Checked
                        AddHandler oCheckBox.Unchecked, AddressOf dgDataCheck_Unchecked
                     End If
                  Next
               Next
            End If
            Return True
         Catch ex As Exception
            Call SF.TraceUtil.DoTrace(Infor.Blending.Admin.SharedFunctions.TraceCategoryEnum.Client, TraceEventType.Error, ex)
            Return False
         End Try

      End Function

Get Site ID of IIS Site

Tue, 23 Dec 2008 13:22:05 GMT

Description: Get Site ID of Website in IIS 6.0, Site ID is usually created automatically. save to .vbs file and doble click on it.

Link: http://www.codekeep.net/snippets/f0ae6b76-e895-4e5a-8efc-c54c0f9ccc54.aspx

Function ProcessWebSite(ServiceType, SiteNumber)
Set IISWebSite = getObject("IIS://localhost/" & ServiceType & "/" & SiteNumber)
Set IISWebSiteRoot = getObject("IIS://localhost/" & ServiceType & "/" & SiteNumber & "/root")
ProcessWebSite = IISWebSite.ServerComment
Set IISWebSiteRoot = nothing
Set IISWebSite = Nothing
end function

Function ShowSites(ServiceType, ClassName, Title)
Wscript.echo "Web Sites Description"
Wscript.echo "==============================================================="
Set IISOBJ = getObject("IIS://localhost/" & ServiceType)
for each Web in IISOBJ
if (Web.Class = ClassName) then
wscript.echo Ucase(ServiceType) & "/" & Web.Name & _
Space(17-(len(Ucase(ServiceType))+1+len(Web.Name))) & " " & _
ProcessWebSite(ServiceType, Web.name)
end if
next
Set IISOBj=Nothing
WScript.Echo ""
End function

Call ShowSites("w3svc", "IIsWebServer", "Web")

Grabbing Browsers via ChildObjects in QTP

Mon, 18 Aug 2008 19:07:11 GMT

Description: Quick and easy way to grab and iterate browsers in Windows without relying on CreationTime, which is unreliable.

Link: http://www.codekeep.net/snippets/5c0f1210-26c9-4e68-98ec-36f26f6cf301.aspx


Dim objDesc 'As Description
Dim objBrowsers 'As Collection

Set objDesc = Description.Create
objDesc("micclass").Value = "Browser"
Set objBrowsers = Desktop.ChildObjects(objDesc)

'Zero-based collection
For lBrowserIndex = 0 to objBrowsers.Count - 1
	strTemp = (lBrowserIndex).GetROProperty("hwnd")  Then
	Set objBrowser = Nothing
Next

Set objBrowsers = Nothing
Set objDesc = Nothing

Call and pass parameter to Web Service from VBScript

Wed, 28 May 2008 02:49:26 GMT

Description: The code snippet calls and passes parameters to Web Service from VBScript

Link: http://www.codekeep.net/snippets/068096f5-1928-4180-9a30-d0ae5b57e2d8.aspx

Dim oXMLDoc, oXMLHTTP
Sub btnCallWebService_Click()
		
	Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP.4.0")
	Set oXMLDoc = CreateObject("MSXML2.DOMDocument")

	oXMLHTTP.onreadystatechange = getRef("HandleStateChange") 
	Dim strEnvelope 
	Set objPage = Item.GetInspector.ModifiedFormPages("P.2")
	Set objtxt1 = objPage.Controls("TextBox1")
	Set objtxt2 = objPage.Controls("TextBox2")
	strEnvelope = "a=" & objtxt1.value & "&b=" & objtxt2.value	

	call oXMLHTTP.open("POST","http://localhost:3257/Service1.asmx/AddNumbers",true)
	call oXMLHTTP.setRequestHeader("Content-Type","application/x-www-form-urlencoded")
	call oXMLHTTP.send(strEnvelope)
End Sub

Sub HandleStateChange
	if(oXMLHTTP.readyState = 4) then
		dim szResponse: szResponse = oXMLHTTP.responseText
		call oXMLDoc.loadXML(szResponse)
		if(oXMLDoc.parseError.errorCode <> 0) then
			call msgbox("ERROR")
			call msgbox(oXMLHTTP.responseText)
			call msgbox(oXMLDoc.parseError.reason)
		else
			call msgbox( oXMLDoc.getElementsByTagName("string")(0).childNodes(0).text)
		end if
	end if
End Sub


------------- OR --------------------

Sub btnCallWebService_Click()
	Dim oXml 
	Dim xmlDoc 		
	Dim strEnvelope 
	Set objPage = Item.GetInspector.ModifiedFormPages("P.2")
	Set objtxt1 = objPage.Controls("TextBox1")
	Set objtxt2 = objPage.Controls("TextBox2")
	Const strUrl = "http://localhost:3257/Service1.asmx/AddNumbers"

	strEnvelope = "a=" & objtxt1.value & "&b=" & objtxt2.value	
	
	Set oXml = CreateObject("MSXML2.XMLHTTP") 
	Set xmlDoc = CreateObject("MSXML2.DOMDocument") 
	
	oXml.open "POST", strUrl, True
	call oXml.setRequestHeader("Content-Type","application/x-www-form-urlencoded")
	oXml.send(strEnvelope)
	
	MsgBox "Calling Web Service to add Nos"
	
	If oXml.Status = "200" Then 
		If xmlDoc.loadXML(oXml.responseText) Then 
			Msgbox xmlDoc.text
		End If 
	End If 
end sub

Custom Action Service Depends

Fri, 04 Apr 2008 08:24:59 GMT

Description: Sets a dependency for a Service

Link: http://www.codekeep.net/snippets/91047cb7-230c-4071-8c42-6a7409756728.aspx

'''
''' Set CustomActionData to [ProductName]<>boolBits
''' i.e. [ProductName]<>false
'''
Dim objWSH
Dim ProductName
Dim boolBits

'msgbox "CustomActionData: " & Session.Property("CustomActionData")

Args = Split(Session.Property("CustomActionData"),"<>")
ProductName = Args(0)
boolBits = Args(1)

'msgbox "ProductName: " & ProductName
'msgbox "boolBits: " & boolBits

Set objWSH = CreateObject("WScript.Shell")

If boolBits Then

objWSH.Run "%SystemRoot%\system32\reg.exe ADD HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\" & ProductName & " /v DependOnService /d MSMQ\0BITS\0 /t REG_MULTI_SZ /F", 7, False

Else

objWSH.Run "%SystemRoot%\system32\reg.exe ADD HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\" & ProductName & " /v DependOnService /d MSMQ\0 /t REG_MULTI_SZ /F", 7, False

End If

Set objWSH = Nothing

Custom Action Service Set User/Pass

Fri, 04 Apr 2008 08:23:14 GMT

Description: Set the username and password for a service

Link: http://www.codekeep.net/snippets/d5c3873c-c437-4ff7-9b80-c8c4e3df6876.aspx

'''
''' Set CustomActionData to [ProductName]<>UserName<>Password
''' i.e. [ProductName]<>GatewayScheduler<>password
'''
Dim objWSH
Dim ProductName
Dim UserName
Dim Password

'msgbox "CustomActionData: " & Session.Property("CustomActionData")

Args = Split(Session.Property("CustomActionData"),"<>")

ProductName = Args(0)
UserName = Args(1)
Password = Args(2)

'msgbox "ProductName: " & ProductName
'msgbox "UserName: " & UserName
'msgbox "Password: " & Password

Set objWSH = CreateObject("WScript.Shell")

objWSH.Run "%SystemRoot%\system32\sc.exe config " & ProductName & " obj= .\" & UserName & " password= " & Password, 7, False

Set objWSH = Nothing

Customer Action Service Start

Fri, 04 Apr 2008 08:21:54 GMT

Description: start a service

Link: http://www.codekeep.net/snippets/f9e99a0a-160b-4ea2-92ae-252a2c424dfa.aspx

'''
''' Set CustomActionData to [ProductName]
'''
Dim objWSH
Dim ProductName

'msgbox "CustomActionData: " & Session.Property("CustomActionData")

ProductName = Session.Property("CustomActionData")

'msgbox "ProductName: " & ProductName

Set objWSH = CreateObject("WScript.Shell")

objWSH.Run "%SystemRoot%\system32\sc.exe start " & ProductName, 7, False

Set objWSH = Nothing

To fetch the values from DB and save it to a xls sheet.

Wed, 05 Dec 2007 11:28:48 GMT

Description: This will allow the User to grab the value from the DB and export the same to the Excel sheet.

Link: http://www.codekeep.net/snippets/988fe59e-a7d9-4988-a021-788074316657.aspx

Set con = createobject("Adodb.Connection")
 Set rs = CreateObject("Adodb.Recordset")
 
 con.open "Provider=SQLOLEDB;server=CQDB\TESTING;database=CQDS_5.5.2_VERITAS;user id=sa	;password=unknown;Connect Timeout=30"
 if(err.number <>0) then
 msgbox "Error"
 else 
 msgbox "Works fine"
 msgbox "Connected"
 End if
 
 
 rs.open "select  *  from cqt_user",con
 
 rs.MoveFirst
 
 
 For i = 0 to rs.Fields.count-1
 DataTable.GlobalSheet.AddParameter rs.Fields(i).Name,""
 
 Next
 
 c=1

 ''Add records to the datatable.
 
 Do until rs.Eof
 DataTable.SetCurrentRow(c)
 For j = 1 to rs.Fields.Count
 
 DataTable.Value(j,dtglobalsheet) = rs(j-1)
 
 Next
 rs.MoveNext
 c=c+1
 Loop
'''''''Then If you are using QTP you can call this function

Open the excel sheet and insert some column values along with formatting.

Wed, 05 Dec 2007 11:25:32 GMT

Description: TO open the excel sheet and insert some column values along with formatting.This function can be used. it helps all who work on QTP as this is what they should do for logging.

Link: http://www.codekeep.net/snippets/2d415c9e-585c-40e2-a4f7-638c08063e75.aspx

Dim objXL
Set objXL = CreateObject("Excel.Application")
 
objXL.Visible = TRUE
 
objXL.WorkBooks.Add
 
 
objXL.Columns(1).ColumnWidth = 20
objXL.Columns(2).ColumnWidth = 30
objXL.Columns(3).ColumnWidth = 40
 
objXL.Cells(1, 1).Value = "Property Name"
objXL.Cells(1, 2).Value = "Value"
objXL.Cells(1, 3).Value = "Description"
 
objXL.Range("A1:C1").Select
objXL.Selection.Font.Bold = True
objXL.Selection.Interior.ColorIndex = 1
objXL.Selection.Interior.Pattern = 1 'xlSolid
objXL.Selection.Font.ColorIndex = 2

Get all the links

Wed, 05 Dec 2007 11:23:33 GMT

Description: This function will get all the links or by modifying you can get any type of objects from a web page.

Link: http://www.codekeep.net/snippets/4c8e9b9a-8cc1-4ad8-b9ca-9272f68550bb.aspx

Dim l_objPage 'Holds Page object 
Dim l_objTag 'Holds "A" Tag Object 
Dim l_intTotalLink 'Holds Total Link 
Dim l_intCtr 'Holds FOR counter 
Dim l_strLink 'Holds Link Name 
Dim l_strHref 'Holds Href 
Set l_objPage = Browser("Title:=BrowserTitle.*").Page("Title:=BrowserTitle.*").Object 
Set l_objTag = l_objPage.GetElementsByTagName("A") 
l_intTotalLink = l_objTag.Length - 1 
For l_intCtr = 0 to l_intTotalLink 
     l_strLink = l_objTag(l_intCtr).InnerText 
     l_strHref = l_objTag(l_intCtr).Href 
     If l_strLink = "Contact Us" Then 
        l_strLink(l_intCtr).Click 
Next

network drive

Thu, 22 Nov 2007 17:04:09 GMT

Description: script to map network drive

Link: http://www.codekeep.net/snippets/06a6a955-5fec-4e5a-a1b5-6c907624686c.aspx

dim wshnetwork
set wshnetwork=Wscript.CreateObject("Wscript.network")
set wshnetwork=Wscript.CreateObject("Wscript.shell")
Wscript.sleep 3000
wshnetwork.MapNetworkDrive "w:","\\192.168.1.1\"&wshnetwork.usern

Get Script Directory

Mon, 17 Sep 2007 11:03:43 GMT

Description: Gets the directory path (with a trailing slash) for the VB Script File.

Link: http://www.codekeep.net/snippets/46e72221-bf1b-41a2-ad7e-ae3680debe33.aspx

scriptFullName = WScript.ScriptFullName

scriptPath = Left ( scriptFullName, _
	InStrRev ( scriptFullName, WScript.ScriptName) - 1 )

WScript.Echo scriptPath

Export VBA Modules

Mon, 03 Sep 2007 00:31:13 GMT

Description: VBScript code to export class and standard VBA modules from an MS Office document.

Link: http://www.codekeep.net/snippets/c27c511d-5c8b-4b4f-8411-ba36ca58a7d0.aspx

'directory for exported files
targetDir = "C:\Exported VBA Files"

targetDir = Trim  ( targetDir )

Set fso = WScript.CreateObject ( "Scripting.FileSystemObject" )
If Not fso.FolderExists ( targetDir ) Then
	fso.CreateFolder targetDir
End If


If Right(targetDir, 1) <> "\" Then
	targetDir = targetDir & "\"
End If

'the progid of a running office application
progId = "Visio.Application"

Set app = GetObject ( , progId )

Set doc = app.ActiveDocument
Set comps = doc.VBProject.VBComponents

For Each comp In comps
	
	'class modules
	If comp.Type = 2 Then
		
		comp.Export targetDir & comp.Name & ".cls"

	'standard modules
	ElseIf Comp.Type = 1 Then

		comp.Export targetDir & comp.Name & ".bas"

	'document code-behind
	ElseIf Comp.Type = 100 Then	

		comp.Export targetDir & comp.Name & ".cls"
	
	End If


Next

WScript.Echo "Done"

ConvertRecordSetToString

Tue, 10 Jul 2007 03:24:26 GMT

Description: Converting RecordSet To String

Link: http://www.codekeep.net/snippets/3b908fa3-ca23-4c31-9539-d4c79805ae94.aspx

Function ConvertRecordSetToString(objRS)
	Dim strContent
	Dim objField, intFields
	If IsObject(objRS) AND objRS.RecordCount > 0 Then
		objRS.MoveFirst
		For intFields = 0 To objRS.Fields.Count - 1
			strContent = strContent & objRS.Fields.Item(intFields).Name & ","
		Next
		strContent = strContent & VbCrLf
		Do While NOT objRS.EOF
			For intFields = 0 To objRS.Fields.Count - 1
				Set objField = objRS.Fields.Item(intFields)
				If IsNull(objField.Value) = False Then
					If IsNumeric(objField.Value) Then
						strContent = strContent & Replace(Trim(objField.Value), ",", "") & ","
					Else
						strContent = strContent & Replace(Trim(objField.Value), ",", " ") & ","
					End If
				Else
					strContent = strContent & objField.Value & ","				
				End If
			Next
			strContent = strContent & VbCrLf
			objRS.MoveNext
		Loop
	End If
	ConvertRecordSetToString = strContent
End Function