Just Code : Highlight Excel Cells

Ever wanted to highlight some cells dependent on their value in Excel. This JustCode script does it for you .

Dim oExcel,oSheet1, oSheet2, oSheet3
Dim iRow,iCol,iStartRow
Dim iLastRow,iLastCol

Set oExcel = createobject("Excel.Application")

oExcel.Visible = True	

oExcel.Application.Workbooks.Open("C:\Data\SD\JustCode\temp.xlsx")



For each oSheet1 in oExcel.Sheets
	
	oSheet1.Activate()
	
	
	For iRow = 1 to 99 
		if ( find(oSheet1.cells[iRow][2].text,"Base") > -1 ) Then
			iStartRow = iRow
			Exit for
		end If
	NExt
	
	For iCol = 1 to 500
		if ( oSheet1.cells[iStartRow][iCol].text = "" ) Then
			iLastCol = iCol
			Exit for
		end If
	Next
	
	For iRow = iStartRow to 99 step 3
		if ( oSheet1.cells[iRow][2].text = "" ) Then
			iLastRow = iRow
			Exit for
		end If
	NExt
	
	
	For iRow = iStartRow to iLastRow
	
		For iCol = 3 to iLastCol
	
			If ( find(oSheet1.cells[iRow][iCol].text,"A") > -1 ) Then
				' VBA to color a cell
				oSheet1.cells[iRow][iCol].Interior.Color = RGB(0, 0, 250)
				oSheet1.cells[iRow][iCol].Font.Color  = RGB(255, 255, 255)
			End If
	
		Next
	
	Next
	
Next

oExcel.ActiveWorkbook.Save()

oExcel.Quit()

Set oExcel = null

JustCode : Read all file in one go

This JustCode shows us how to open a file in read-only mode and read all the file in one go. I find this very useful when i need to read in template files and do some sort of search and replace.

 
`’ ****************************************
 ‘ Designed by : Smarter Dimensions
 ‘ Last Updated : 24th July 2009
 ‘ Read all file in one go.
 ‘ ****************************************
 
Dim oFSO, oFile
 
Set oFSO = CreateObject(“Scripting.FileSystemObject”)
 
Set oFile = oFSO.OpenTextFile(“C:\temp\test.txt”,1,false,0)
 
debug.Log(oFile.ReadAll())
 
oFile.Close()

JustCode : Print to Word Version 1

Many moons ago , i needed to make a script that showed the users answer in a word doc. This JustCode script shows you how you can do it. Its creates a template for you and populates it.

Routing(Web)

' Set the survey Answers

Single = {A}
Multi = {A,B}
ToDaysDate="04/06/2010"

GridQuestion[{Sub1}].SingleCategoricalQuestionName = {A}
GridQuestion[{Sub2}].SingleCategoricalQuestionName = {B}
GridQuestion[{Sub3}].SingleCategoricalQuestionName = {C}
GridQuestion[{Sub4}].SingleCategoricalQuestionName = {D}
GridQuestion[{Sub5}].SingleCategoricalQuestionName = {E}

DoubleQuestioName = 12.12
LongQuestionName = 122
TextQuestionName = "This is a text question"
SingleWithOther._Other = "hello"
SingleWithOther = {_other}

Dim oWord,sFileName
Set oWord = CreateObject("Word.Application")
oWord.visible = true


' These two lines will make a template for us.
'oWord.Documents.Add()
'RunTemplate(oWord,IOM,False)


' These lines will use a template and show results
oWord.Documents.Open("D:DATASDLibraryPrintToWordSimpleTemplate.docx")
RunTemplate(oWord,IOM,True)


oWord.DisplayAlerts = false
'sFileName = "c:temp" + replace(replace(CText(DateNow()),"/","_"),":","_") + ".docx"
'oWord.ActiveDocument.SaveAs(sFileName)
oWord.Quit()

Sub MakeSpace(oWord)
' Jump out of table
oWord.Selection.MoveDown(5,1)

' Insert New line
oWord.Selection.TypeParagraph()

End Sub

Sub MakeTable(oWord,sLabel)
oWord.ActiveDocument.Tables.Add(oWord.Selection.range,2,1,1,0)

With oWord.Selection.Tables[1]
If .Style <> "Table Grid" Then
.Style = "Table Grid"
End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.ApplyStyleRowBands = True
.ApplyStyleColumnBands = False
End With

oWord.Selection.Text = sLabel

End Sub

Sub Add2RowToTable(oWord,sLabel,sAnswerLabel,sAnswer)

oWord.Selection.MoveRight(12)
oWord.Selection.Text = sAnswerLabel
oWord.Selection.MoveRight(12)
oWord.Selection.Text = sAnswer

End Sub

Sub Add1RowToTable(oWord,sLabel,sAnswerLabel,sAnswer)

oWord.Selection.MoveRight(12)
oWord.Selection.Text = sAnswer

End Sub

Sub AddSplitRowToTable(oWord,sLabel,sAnswerLabel,sAnswer,iRows,iCols)

oWord.Selection.MoveRight(12)
oWord.Selection.Cells.Split(iRows,iCols,True)
oWord.Selection.Text = sAnswerLabel
oWord.Selection.MoveRight(12)
oWord.Selection.Text = sAnswer

End Sub

Sub AddGridSplitRowToTable(oWord,sLabel,sAnswerLabel,sAnswer,iRows,iCols)

oWord.Selection.MoveRight(12)
oWord.Selection.Cells.Split(iRows,iCols,True)
oWord.Selection.Text = sAnswerLabel
oWord.Selection.MoveRight(12)
oWord.Selection.Font.Size = 2
oWord.Selection.Text = sAnswer

End Sub

Sub AddGridRowToTable(oWord,sAnswer)

oWord.Selection.MoveRight(12)
oWord.Selection.Font.Size = 2
oWord.Selection.Text = sAnswer

End Sub

Sub AddNextGridRowToTable(oWord,sLabel,sAnswer)

oWord.Selection.MoveRight(12)
oWord.Selection.Text = sLabel

oWord.Selection.MoveRight(12)
oWord.Selection.Font.Size = 2
oWord.Selection.Text = sAnswer

End Sub


Sub RunTemplate(oWord,IOM,bWithAnswers)
Dim oQuestion

For Each oQuestion in IOM.Questions
Select Case oQuestion.QuestionType
Case QuestionTypes.qtSimple
If ( bWithAnswers ) Then
GetAnswers(oQuestion,"S","",oWord)
Else
MakeSpace(oWord)
MakeTable(oWord,oQuestion.Label)
CreateQuestions(oQuestion,"S","",oWord,0,IOM)
End If
Case QuestionTypes.qtLoopCategorical, QuestionTypes.qtLoopNumeric
If ( bWithAnswers ) Then
GetAnswers(oQuestion,"G","",oWord)
Else
MakeSpace(oWord)
MakeTable(oWord,oQuestion.Label)
CreateQuestions(oQuestion,"G","",oWord,0,IOM)
End If
Case QuestionTypes.qtBlock, QuestionTypes.qtCompound, QuestionTypes.qtPage
If ( bWithAnswers ) Then
GetAnswers(oQuestion,"G","",oWord)
Else
MakeSpace(oWord)
MakeTable(oWord,oQuestion.Label)
CreateQuestions(oQuestion,"G","",oWord,0,IOM)
End If
End Select
Next
End Sub

Sub FindAnswer(oWord,sLookingFor,sValue)

With oWord.Selection.Find
.Text = sLookingFor
.Replacement.Text = sValue
.Forward = True
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
oWord.Selection.Find.Execute(,,,,,,,,,,1,,,,)
oWord.Selection.Font.Size = 10
oWord.Selection.HomeKey(6)

End Sub

Sub GetAnswers(oQuestion,sType,sLabel,oWord)
Dim oCat,oItem,oOther
Select Case sType
Case = "S"
Select Case oQuestion.QuestionDataType
Case = DataTypeConstants.mtDate
FindAnswer(oWord,"X" + oQuestion.QuestionFullName + "X",oQuestion.Response.Value)

Case = DataTypeConstants.mtBoolean,DataTypeConstants.mtDouble, _
DataTypeConstants.mtLong,DataTypeConstants.mtText

FindAnswer(oWord,"X" + oQuestion.QuestionFullName + "X",oQuestion.Response.Value)


Case Else
For each oCat in oQuestion.Categories
If ( oCat.Value.Format("a") = oQuestion.Response.Value.Format("a") ) Then

FindAnswer(oWord,"X" + oQuestion.QuestionFullName + ":" + _
oCat.Name + "X","Yes")

Else
FindAnswer(oWord,"X" + oQuestion.QuestionFullName + ":" + _
oCat.Name + "X","No")

End If
Next

' Do we have Other Responses
For Each oOther in oQuestion.OtherCategories
FindAnswer(oWord,"X" + oQuestion.QuestionFullName + ":" + _
oCat.Name + ":OtherTextX",oOTher.OtherQuestion.response.value)
Next
End Select
Case = "G"
For each oItem in oQuestion
If ( Find(oItem.ParentQuestion.QuestionFullname,"{") > -1 ) Then
GetAnswers(oItem,"S",oQuestion.ParentQuestion.Label,oWord)
Else
GetAnswers(oItem,"G",oQuestion.Label,oWord)
End If
Next
End Select
End Sub

Sub CreateQuestions(oQuestion,sType,sLabel,oWord,iQCount,oIOM)
Dim oCat,oItem,oOther,iCat
Select Case sType
Case = "S"
Select Case oQuestion.QuestionDataType
Case = DataTypeConstants.mtDate
If ( sLabel = "" ) Then
Add1RowToTable(oWord,oQuestion.Label,"","X" + oQuestion.QuestionFullName + "X")
Else
Add1RowToTable(oWord,oQuestion.Label,"","X" + sLabel + "X")
End If
Case = DataTypeConstants.mtBoolean,DataTypeConstants.mtDouble, _
DataTypeConstants.mtLong,DataTypeConstants.mtText
If ( sLabel = "" ) Then
Add1RowToTable(oWord,oQuestion.Label,"","X" + oQuestion.QuestionFullName + "X")
Else
Add1RowToTable(oWord,oQuestion.Label,"","X" + sLabel + "X")
End If

Case Else
iCat = 0
For each oCat in oQuestion.Categories

If iCat = 0 Then
If ( sLabel = "" ) Then
AddSplitRowToTable(oWord,oQuestion.Label,oCat.Label,"X" + oQuestion.QuestionFullName + ":" + _
oCat.Name + "X",1,2)
Else
AddSplitRowToTable(oWord,sLabel,oCat.Label,"X" + oQuestion.QuestionFullName + ":" + _
oCat.Name + "X",1,2)
End If
Else
If ( sLabel = "" ) Then
Add2RowToTable(oWord,oQuestion.Label,oCat.Label,"X" + oQuestion.QuestionFullName + ":" + _
oCat.Name + "X")
Else
Add2RowToTable(oWord,sLabel,oCat.Label,"X" + oQuestion.QuestionFullName + ":" + _
oCat.Name + "X")
End If

End If
iCat = iCat + 1
Next

' Do we have Other Responses
For Each oOther in oQuestion.OtherCategories
If ( sLabel = "" ) Then
Add2RowToTable(oWord,oQuestion.Label,oOther.Label,"X" + oQuestion.QuestionFullName + ":" + _
oOther.Name + ":OtherTextX")
Else
Add2RowToTable(oWord,sLabel,oOther.Label,"X" + oQuestion.QuestionFullName + ":" + _
oOther.Name + ":OtherTextX")
End If
Next
End Select
Case = "GS"
'MakeTable(oWord,oQuestion.Label)
Select Case oQuestion.QuestionDataType
Case = DataTypeConstants.mtDate
Case = DataTypeConstants.mtBoolean,DataTypeConstants.mtDouble, _
DataTypeConstants.mtLong,DataTypeConstants.mtText
Case Else
iCat = 0

For each oCat in oQuestion.Categories
If iCat = 0 Then
If ( iQCount = 2 ) Then
If ( sLabel = "" ) Then

AddGridSplitRowToTable(oWord,oQuestion.Label,oCat.Label,"X" + oQuestion.QuestionFullName + ":" + _
oCat.Name + "X",1,oQuestion.Categories.count+1)
Else
AddGridSplitRowToTable(oWord,sLabel,oIOM.Questions[oQuestion.ParentQuestion.ParentQuestion.QuestionName].categories[oQuestion.ParentQuestion.QuestionName].label,"X" + oQuestion.QuestionFullName + ":" + _
oCat.Name + "X",1,oQuestion.Categories.count+1)
End If
Else
'At This stage i need to know
'oIOM.Questions["GridQuestion"].categories["Sub1"].label

If ( sLabel = "" ) Then
AddNextGridRowToTable(oWord,oIOM.Questions[oQuestion.ParentQuestion.ParentQuestion.QuestionName].categories[oQuestion.ParentQuestion.QuestionName].label,"X" + oQuestion.QuestionFullName + ":" + _
oCat.Name + "X")
Else
AddNextGridRowToTable(oWord,oIOM.Questions[oQuestion.ParentQuestion.ParentQuestion.QuestionName].categories[oQuestion.ParentQuestion.QuestionName].label,"X" + oQuestion.QuestionFullName + ":" + _
oCat.Name + "X")
End If
End If
Else
If ( sLabel = "" ) Then
AddGridRowToTable(oWord,"X" + oQuestion.QuestionFullName + ":" + _
oCat.Name + "X")
Else
AddGridRowToTable(oWord,"X" + oQuestion.QuestionFullName + ":" + _
oCat.Name + "X")
End If

End If
iCat = iCat + 1
Next

' Do we have Other Responses
For Each oOther in oQuestion.OtherCategories
If ( sLabel = "" ) Then
AddSimpleTable(oWord,oQuestion.Label,oOther.Label,"X" + oQuestion.QuestionFullName + ":" + _
oOther.Name + ":OtherTextX")
Else
AddSimpleTable(oWord,sLabel,oOther.Label,"X" + oQuestion.QuestionFullName + ":" + _
oOther.Name + ":OtherTextX")
End If
Next
End Select
Case = "G"

For each oItem in oQuestion
iQCount = iQCount + 1
If ( Find(oItem.ParentQuestion.QuestionFullname,"{") > -1 ) Then
CreateQuestions(oItem,"GS",oQuestion.ParentQuestion.Label,oWord,iQCount,oIOM)
Else
CreateQuestions(oItem,"G",oQuestion.Label,oWord,iQCount,oIOM)
End If
Next
End Select
End Sub

End Routing

JustCode : Loop all files and folders

I have started using this allot in the last few months. This JustCode example will show you all the files and folders in a specific folder.

LoopFolders(“c:\temp”)
 
Sub LoopFolders(sFullPath)
 Dim oFolder,oSubFolder,oFSO,oFile
 
Set oFSO = CreateObject(“Scripting.FileSystemObject”)
 
If oFSO.FolderExists(sFullPath) Then
 Set oFolder = oFSO.GetFolder(sFullPath)
 
For Each oFile In oFolder.Files
 debug.Log(oFolder.Path + “” + oFile.Name)
 Next
 
For each oSubFolder in oFolder.SubFolders
 debug.Log(“Folder:”+ oSubFolder.Name)
 LoopFolders(oSubFolder.Path)
 Next
 
End If
 
Set oFSO = null
 Set oFolder = null
 Set oFile = null
 End Sub

JustCode : Work Out Value of Question On or Off Path

From time to time i find this very useful. This JustCode script will return the value of a question based on if it has an OffPath value or not.

Function WorkOutValue(oIOM,oQuestion,sReturn)
On Error Goto LogIt

if ( oQuestion.Response.value <> oQuestion.Info.OffPathResponse ) Then 

	if ( oQuestion.Info.OffPathResponse <> "" ) then
			
		select case sReturn
			Case = "V"
				WorkOutValue = ctext(oQuestion.Info.OffPathResponse)
			Case = "C"
				WorkOutValue = "{" + ctext(format(oQuestion.Info.OffPathResponse,"a")) + "}"
		End Select
	else
				
		select case sReturn
			Case = "V"
				WorkOutValue = ctext(oQuestion.Response.value)
			Case = "C"
				WorkOutValue = "{" + ctext(format(oQuestion.Response.value,"a")) + "}"
		End Select
		
	end if
Else
	
	select case sReturn
		Case = "V"
			WorkOutValue = ctext(oQuestion.Response.value)
		Case = "C"
			WorkOutValue = "{" + ctext(format(oQuestion.Response.value,"a")) + "}"
	End Select
End If

Goto SkipError

LogIt:
		
	oIOM.Terminate(Signals.sigError)
	
SkipError:

	On Error Goto 0	

		WorkOutValue = WorkOutValue
End Function

JustCode : Send Email via Lotus Notes

Want to send an email to someone using Lotus Notes. This script will help you do that.

' Tested on Notes Version 8.0

Dim Maildb
Dim MailDoc
Dim Body
Dim Session

'Start a session to notes
Set Session = CreateObject("Lotus.NotesSession")

Session.Initialize("PASSWORD_HERE")

Set Maildb = Session.GETDATABASE("", "NSFFILE_LOCATION_HERE")

If Not Maildb.IsOpen = True Then
Maildb.Open()
End If

'Create the mail document
Set MailDoc = Maildb.CREATEDOCUMENT()

MailDoc.ReplaceItemValue("Form", "Memo")
'Set the recipient
MailDoc.ReplaceItemValue("SendTo", "MyEmail@Myserver.com")
'Set subject
MailDoc.ReplaceItemValue("Subject", "Subject Text")

'Create and set the Body content
Set Body = MailDoc.CREATERICHTEXTITEM("Body")
Body.APPENDTEXT("Body text here")

'Example to create an attachment (optional)
Body.ADDNEWLINE(2)
Body.EMBEDOBJECT(1454, "", "MYFILELOCATION_HERE", "Attachment")

'Example to save the message (optional)
MailDoc.SAVEMESSAGEONSEND = True
'Send the document
'Gets the mail to appear in the Sent items folder
MailDoc.ReplaceItemValue("PostedDate", Now())
MailDoc.SEND(False)

'Clean Up
Set Maildb = null
Set MailDoc = null
Set Body = null
Set Session = null

IBM SPSS Data Collection Server Pre-Installation

▶ IBM SPSS Data Collection Server Pre-Installation – YouTube

This video goes through the basic setup of a Data Collection server environment, starting with pre-requisite software, creating users and assigning permissions, IIS roles configuration, and finally client and server ports used by our software. Complete installation guides may be downloaded from IBM at http://www-01.ibm.com/support/knowled…
(Guides available for all Data Collection products in English, française, Deutsch, 日本語ガイド, 简体中国指南, español.)

LinkedIn Auto Publish Powered By : XYZScripts.com