Refresh Excel query tables

VBScript

Sub RefreshSpreadsheet(filename)
'
'  This procedure will refresh all the query
'  tables from the active Excel sheet.
'
    Dim oExcel
    Dim oQueryTable
    
    Set oExcel = CreateObject("excel.application")
    
    oExcel.Workbooks.Open(filename)
    
    For Each oQueryTable In oExcel.ActiveSheet.QueryTables
        oQueryTable.Refresh False
    Next    
    
    oExcel.ActiveWorkbook.Save
    oExcel.Workbooks.Close
    oExcel.Quit
    Set oExcel = Nothing
End Sub
Advertisements

Execute Excel macro

VB Script

Sub RunMacro(filename, macroname)
'
'  This procedure will execute a Excel macro.
'
    Dim oExcel
    
    Set oExcel = CreateObject("excel.application")
    
    oExcel.Workbooks.Open(filename)
    
    oExcel.Run macroname
    
    oExcel.ActiveWorkbook.Save
    oExcel.Workbooks.Close
    oExcel.Quit
    Set oExcel = Nothing
End Sub

DTS: VBScript tests file creation month at the ftp site

Option Explicit

'  This VBScript tests the file creation month at the ftp site.
'
' reference: http://www.microsoft.com/technet/scriptcenter/resources/tales/sg1002.mspx
' reference: http://www.sqlservercentral.com/articles/Administering/usingvbscripttoautomatetasks/1171/
'
Function Main()
    Dim fso
    Dim temp_folder
    Dim ftp_control_file
    Dim ftp_control_filename
    Dim shell
    Dim return
    
    
    Set fso         = CreateObject("Scripting.FileSystemObject")
    Set temp_folder = fso.GetSpecialFolder(2) ' Temporary Folder = 2
        
    ' ftp control file name
    ftp_control_filename = temp_folder.Path + "\" + fso.GetTempName()
    
    ' create ftp control file
    Set ftp_control_file = fso.CreateTextFile(ftp_control_filename, True)
    ftp_control_file.WriteLine ("open ftp.xyz.com")
    ftp_control_file.WriteLine ("my_user_name")
    ftp_control_file.WriteLine ("my_password")
    ftp_control_file.WriteLine ("ascii")
    ftp_control_file.WriteLine ("dir my_file_name.txt")
    ftp_control_file.WriteLine ("bye")
    ftp_control_file.Close
    Set ftp_control_file = Nothing
    
    ' reference: http://www.printdistributor.com/forum/post/124
    ' The WScript object isn't part of DTS VBScript.
    Set shell = CreateObject( "WScript.Shell" )
    ' reference: http://www.chebucto.ns.ca/~ak621/DOS/ExitCode.html
    ' the return variable will be the return value from the last FIND command
    return = shell.Run("%comspec% /c ftp -s:"""  & ftp_control_filename & """ | find ""my_file_name.txt"" | find "" " & MonthName(Month(Now), True) & " """, 0, True)
    Set shell = Nothing
    
    ' clean up control file
    fso.DeleteFile ftp_control_filename
    
    Set temp_folder = Nothing
    Set fso         = Nothing
    
    ' return the flag to the DTS package
    If return = 0 Then
        Main = DTSTaskExecResult_Success
    Else
        Main = DTSTaskExecResult_Failure
    End If
End Function

Using ADO to upload data

Dim cnn
Dim rst

Set cnn = CreateObject("ADODB.Connection")
cnn.ConnectionString = "Driver={SQL Native Client};Server=myserver;Database=test;Trusted_Connection=yes;"
cnn.Open
cnn.Execute "CREATE TABLE ##tmp (id INTEGER NOT NULL PRIMARY KEY)"

 

Set rst = CreateObject("ADODB.Recordset")
Set rst.ActiveConnection = cnn
rst.CursorLocation = 3
rst.CursorType = 3
rst.LockType = 3
rst.Open "##tmp", , , ,2
rst.AddNew
rst("id") = 1
rst.Update
rst.AddNew
rst("id") = 2
rst.Update

Using global temporary table is required because ADO updating process will open the second connection to the server. The CursorLocation, CursorType, and LockType must be set. ADO will generate RPC with the INSERT statement for each record.

msval.vbs

Option Explicit

' Initialize global objects and variables.
Dim fso, f, file, folder, filepath, dir, coll
Dim fspec, strFileName, shortName, strResult
Dim LineOfEquals, strFile, strFiles, strFileExt
Dim Files, StartingFolder, WshShell, strDesktop
Dim S, SubFolders, SubFolder, procFilesCount
Dim xmlDoc, state
Dim sLogPath

'Set global constants and variables.
Const OpenFileForAppending = 8 
LineOfEquals = "=============================================" & vbCrLf

set WshShell = WScript.CreateObject("WScript.Shell")
strDesktop = WshShell.SpecialFolders("Desktop")
Set fso = CreateObject("Scripting.FileSystemObject")
sLogPath = strDesktop & "\msval.txt"

Sub ShowHelp
    Wscript.Echo vbCrLf & _
    "About:" & Chr(9) & "Msval.vbs is an XML file validator." & vbCrLf & _
    vbCrLf & _
    "Syntax:" & Chr(9) & "msval [input_file_or_folder]" & vbCrLf & _
    vbCrLf & _
    "Examples:" & vbCrLf & vbCrLf & _
    Chr(9) & "msval my.xml" & vbCrLf & _
    Chr(9) & "msval C:\MyFolderContainingXML" & vbCrLf & _
    Chr(9) & "msval ..\..\MyFolderContainingXML" & vbCrLf & vbCrLf & _
    "Notes:" & Chr(9) & "If XML file is specified, results are " & _
    "returned in a console message." & vbCrLf & vbCrLf & _
    Chr(9) & "If a folder is specified, a report file, Msval.txt," & _
    " is generated" & vbCrLf & _
    Chr(9) & "on your desktop and validation results are recursive" & _
    " for XML" & vbCrLf & _
    Chr(9) & "files found in the specified folder and all of its" & _
    " subfolders." & vbCrLf
    Exit Sub
End Sub

Sub ErrorOut
    Wscript.Echo (vbCrLf & "Status: MSVAL failed." + vbCr)
    Wscript.Quit
End Sub

Sub ValidateAsXmlFile
    Set xmlDoc = CreateObject("Msxml2.DOMDocument.6.0")
    xmlDoc.setProperty "ProhibitDTD", False
    xmlDoc.setProperty "ResolveExternals", True 

    xmlDoc.validateOnParse = True
    xmlDoc.async = False
    xmlDoc.load(strFileName)
    Select Case xmlDoc.parseError.errorCode
       Case 0 
            strResult = "Valid: " & strFileName & vbCr
       Case Else
           strResult = vbCrLf & "ERROR! Failed to validate " & _
           strFileName & vbCrLf & xmlDoc.parseError.reason & vbCr & _
          "Error code: " & xmlDoc.parseError.errorCode & ", Line: " & _
                           xmlDoc.parseError.line & ", Character: " & _
                           xmlDoc.parseError.linepos & ", Source: " & _
                           Chr(34) & xmlDoc.parseError.srcText & _
                           Chr(34) & " - " & Now & vbCrLf 
    End Select

' Create log file for storing results when validatin multiple files.
    Set f = fso.OpenTextFile(sLogPath, OpenFileForAppending)
    f.WriteLine strResult
    f.Close

    ' Increment processed files count.
    procFilesCount = procFilesCount + 1
    'Release DOM document object
    Set xmlDoc = Nothing
End Sub

Function WalkSubfolders(Folder)
    Dim strFolder, currentFolder, strCurPath
    Set currentFolder = fso.GetFolder(Folder)
    strCurPath = currentFolder.Path
    strFolder = vbCrLf & LineOfEquals & _
                "Folder: " & strCurPath & _
                vbCrLf & LineOfEquals & vbCrLf

    ' Open the log file and append current subfolder.
    Set f = fso.OpenTextFile(sLogPath, OpenFileForAppending)
    f.Write strFolder
    f.Close
    strFolder = ""
    Set Files = currentFolder.Files
    If Files.Count  0 Then
      ' Walk the collection. If the file is XML, 
      ' load and validate it.
      For Each File In Files
         strFileName = fso.GetAbsolutePathName(File)
         strFileExt = Right(strFileName,4)
         Select Case strFileExt
           ' Process all known XML file types.
           Case ".xml" ValidateAsXmlFile
           Case ".xsl" ValidateAsXmlFile
           Case ".xsd" ValidateAsXmlFile
           Case Else
         End Select
      Next
    End If

    ' Open the log file and append file list from current subfolder.
    Set f = fso.OpenTextFile(sLogPath, OpenFileForAppending)
    f.Write strFiles
    f.Close
    strFiles  = ""

    Set SubFolders = currentFolder.SubFolders

    If SubFolders.Count  0 Then
       For Each SubFolder In SubFolders
          strFolder = strFolder & WalkSubfolders(SubFolder)
       Next
       strFolder = strFolder & vbCr
    End If
End Function

Sub WriteEOFSummary
    Set f = fso.OpenTextFile(sLogPath, OpenFileForAppending)
    strResult = vbCrLf & LineofEquals & _
               "Processing completed at " & Now & vbCrLf & _
               procFilesCount & " files processed" & vbCrLf & _
               LineOfEquals
    f.Write strResult
    f.Close
    strResult = "Results written to " & sLogPath & vbCrLf & _
               "Files processed: " & procFilesCount & vbCrLf & _
               vbCrLf & "Do you want to view the results now?"
    MsgBox strResult, vbYesNo, "MSVAL: Processing completed"
    If vbYes Then
       WshShell.Run ("%windir%\notepad " & sLogPath)
    End If
End Sub

Function ProcessStandAloneFile(sFile)
    Dim basename, str, xdoc
    Set f = fso.GetFile(fspec)
    basename = f.Name
    ' Load XML input file & validate it
    Set xdoc = CreateObject("Msxml2.DOMDocument.6.0")
    xdoc.setProperty "ProhibitDTD", False
    xdoc.setProperty "ResolveExternals", True
    xdoc.validateOnParse = True
    xdoc.async = False
    xdoc.load(fspec)
    If xdoc.parseError.errorCode = 0 Then
       str = basename & " is valid"
    ElseIf xdoc.parseError.errorCode  0 Then
       str = basename & " is not valid" & vbCrLf & _
       xdoc.parseError.reason & " URL: " & Chr(9) & _
       xdoc.parseError.url & vbCrLf & "Code: " & Chr(9) & _
       xdoc.parseError.errorCode & vbCrLf & "Line: " & _
       Chr(9) & xdoc.parseError.line & vbCrLf & _
       "Char: "  & Chr(9) & xdoc.parseError.linepos & vbCrLf & _
       "Text: "  & Chr(9) & xdoc.parseError.srcText
    End If
    ProcessStandAloneFile = str
End Function

Sub Main
    'Initialize files count
    procFilesCount = 0

    ' Get the folder to scan for files.
    If Wscript.Arguments.Length > 0 Then
       fSpec = Wscript.Arguments.Item(0)
       fSpec = fSpec & "\"
    Else
       ShowHelp
       WScript.Quit
    End If

    fspec = fso.GetAbsolutePathName(fspec)
    If fso.FileExists(fspec) Then
       strResult = ProcessStandAloneFile(fspec)
       Wscript.Echo strResult
       Wscript.Quit
    ElseIf fso.FolderExists(fspec) Then
       ' Executes a 'DIR' command into a collection.
       Set dir = fso.GetFolder(fspec)
       Set coll = dir.Files
       ' Create the log file on the user's desktop.
       Set f = fso.CreateTextFile(sLogPath, 1)
       strResult = vbCrLf & LineofEquals & sLogPath & _
           " at " & Now & vbCrLf & LineOfEquals & vbCrLf
       f.Write strResult
       f.Close
       WalkSubfolders(fSpec)
    Else
       strResult = vbCrLf & "Input file or folder " & _
                   fspec & " does not exist."
       MsgBox strResult, vbOKOnly, _
             "MSVAL: File or folder doesn't exist"
        ErrorOut
    End If

    WriteEOFSummary

    ' Reset object variables.
    Set fso = Nothing
    Set xmlDoc = Nothing

End Sub

http://msdn.microsoft.com/en-us/library/ms756015(VS.85).aspx

vbs: extract binary data from sql server

Dim sql
Dim cnn
Dim rst

sql = "select attachment from msdb.dbo.sysmail_attachments where attachment_id = 149987" 

Set cnn = CreateObject("ADODB.Connection")
cnn.ConnectionString = "Provider=SQLNCLI10.1;Data Source=myserver;Integrated Security=SSPI;Initial Catalog=msdb"
cnn.ConnectionTimeout = 30
cnn.CommandTimeout = 0
cnn.Open()


Set rst = cnn.Execute(sql)

SaveBinaryData "c:\att.csv", rst("attachment")

Set rst = Nothing
cnn.Close()
Set cnn = Nothing

Function SaveBinaryData(FileName, ByteArray)
'
'  http://www.motobit.com/tips/detpg_read-write-binary-files/
'
  Const adTypeBinary = 1
  Const adSaveCreateOverWrite = 2
  
  'Create Stream object
  Dim BinaryStream
  Set BinaryStream = CreateObject("ADODB.Stream")
  
  'Specify stream type - we want To save binary data.
  BinaryStream.Type = adTypeBinary
  
  'Open the stream And write binary data To the object
  BinaryStream.Open
  BinaryStream.Write ByteArray
  
  'Save binary data To disk
  BinaryStream.SaveToFile FileName, adSaveCreateOverWrite
End Function