I am trying to return a string from a subroutine in VBScript, but I am getting a type mismatch.
Here is the code:
main
Sub Main
Dim NumofBatches, Batch1
CStr(Batch1)
Batch1 = checkXML("Bar.xml")
End Sub
'Checks For Batch in ZoneX
Sub checkXML(sFile)
Set objFileToRead = CreateObject("Scripting.FileSystemObject").OpenTextFile("D:\Projects\Scripts\SQL\" + sFile, 1)
Dim strLine, x, y
Do While Not objFileToRead.AtEndOfStream
CStr(StrLine)
strLine = objFileToRead.ReadLine()
'String Foo
If (x > 3) Then
If (InStr(strLine, """") = 1) Then
CheckXMl = ""
Else
CheckXMl = StrLine
End If
End If
Loop
objFileToRead.Close
Set objFileToRead = Nothing
End Sub
And I am not sure of the issue, I know the system right now only gets one result from If (x > 3) Then portion, but even if it weren't I should only overwrite my result, correct?
As #omegastripes pointed out, subs don't have a return value, only functions do.
Change
Sub checkXML(sFile)
...
End Sub
to
Function checkXML(sFile)
...
End Function
See also.
Related
I'm trying to compile the following code, and I keep getting an error. I got this erro before multiple times so I was forced to use workaround functions. This time I'm really tired of this issue and I need to know what's wrong here.
sub SQL_AddTestResults (byval sData as string, byval testID as integer)
dim i as integer
dim dataChain as string
dim aData (Split(sData, ";").length) as string
aData = Split(sData, ";")
for i = 0 to aData.Length
if(i = 4) then
goto skip
elseif (i = 68) then
goto skip
elseif (i = 72) then
goto skip
end if
if(i = aData.length) then
dataChain = dataChain & aData(i)
else
dataChain = dataChain & aData(i) & ", "
end if
skip:
next
MsgBox (dataChain)
SQL_statement = "INSERT INTO ""TestData"" VALUES (" & dataChain & ");"
Stmt = connection.createStatement()
Stmt.executeUpdate(SQL_statement)
end sub
Compiling this code gives me the following error on "for i = 0 to aData.Length" line:
Basic syntax error.
Symbol aData already defined differently.
Have no idea why. Apologies if that's a trivial problem, but I'm completely new to VB. C++ didn't prepare me for this.
Arrays in classic VB don't have a "length" property. I'm not sure where you got that from.
The way to get the bounds of an array in classic VB is with the LBound and UBound functions.
for i = LBound(aData) to UBound(aData)
This way you can even handle arrays that don't have 0 as the starting index, as yes, one of VB's wonderful quirks is that it lets you use any range of numbers for your indexes.
VB6 isn't a language I'd recommend for new development. If you're trying to learn something new, there are plenty of other options. As you've no doubt noticed, it's harder and harder to find documentation on how classic VB does things, and how it differs from VBScript and VB.NET. If you need to be maintaining an older VB6 code base, I'd recommend finding a used book somewhere that goes over VB6 syntax and usage.
Try this code corrected code:
sub SQL_AddTestResults (byval sData as string, byval testID as integer)
dim i as integer
dim dataChain as string
dim aData as variant
aData = Split(sData, ";")
for i = 0 to ubound(aData)
if(i = 4) then
goto skip
elseif (i = 68) then
goto skip
elseif (i = 72) then
goto skip
end if
if(i = ubound(aData)) then
dataChain = dataChain & aData(i)
else
dataChain = dataChain & aData(i) & ", "
end if
skip:
next
MsgBox (dataChain)
SQL_statement = "INSERT INTO ""TestData"" VALUES (" & dataChain & ");"
Stmt = connection.createStatement()
Stmt.executeUpdate(SQL_statement)
end sub
What I could gather, you are defining aData twice but in different ways -
dim aData (Split(sData, ";").length) as string
aData = Split(sData, ";")
aData length will return an integer of the actual length whilst you are asking it to return a string, and you are using it in your integer loop for i as counter.
Immediately after that you are telling it to return just some data causing the crash. Rather use another nominator to hold the two different kinds of returned information you need -
dim aData (Split(sData, ";").length) as Long ''Rather use long as the length might exceed the integer type. Use the same for i, change integer to long
Dim bData = Split(sData, ";") as String
for i = 0 to aData.Length
if(i = 4) then
goto skip
elseif (i = 68) then
goto skip
elseif (i = 72) then
goto skip
end if
if(i = aData.length) then
dataChain = dataChain & bData(i)
else
dataChain = dataChain & bData(i) & ", "
end if
skip:
next
why now return ....Syntax error
Can i put the Sub rutine in the function? Or better way for this?!
Function SumerizePlanArrays(f_String, f_Type)
Set dic = CreateObject("Scripting.Dictionary")
Sub Add(s)
weight = Split(s,"$")(0)
values = Split(s,"$")(1)
pipes = Split(values, "|")
For Each line In pipes
val = Split(line, ",")
if f_Type = 1 then
dic(val(1)) = (dic(val(1))*weight/100) + CInt(val(2))
elseif f_Type = 2 then
dic(val(1)) = dic(val(1)) + CInt(val(2))
end if
Next
End Sub
arrString = Split(f_String,"#")
For i = 0 to UBound(arrString)
'wei = Split(arrString(i),"$")(0)
Add arrString(i)
Next
Set a = CreateObject("System.Collections.ArrayList")
For Each key In dic.Keys
a.Add "0," & key & "," & dic(key)
Next
a.Sort
result = Join(a.ToArray, "|")
SumerizePlanArrays = result
End Function
Microsoft VBScript compilation error '800a03ea'
Syntax error
/inc_func_projects.asp, line 2592
Sub Add(s)
^
No - you can't put a sub within a function, except in JavaScript or in the server side version called JScript. VBScript and JScript are two completely different languages, however.
You should be doing this...
Function SumerizePlanArrays(f_String, f_Type)
Set dic = CreateObject("Scripting.Dictionary")
arrString = Split(f_String,"#")
For i = 0 to UBound(arrString)
'NOTE: Updated the call to reflect comment by sadrasjd...
Add arrString(i, f_Type, dic)
Next
Set a = CreateObject("System.Collections.ArrayList")
For Each key In dic.Keys
a.Add "0," & key & "," & dic(key)
Next
a.Sort
result = Join(a.ToArray, "|")
SumerizePlanArrays = result
End Function
Sub Add(s, type, dic)
'NOTE: ^Updated the parameters to reflect comment by sadrasjd^
weight = Split(s,"$")(0)
values = Split(s,"$")(1)
pipes = Split(values, "|")
For Each line In pipes
val = Split(line, ",")
if type = 1 then
dic(val(1)) = (dic(val(1))*weight/100) + CInt(val(2))
elseif type = 2 then
dic(val(1)) = dic(val(1)) + CInt(val(2))
end if
Next
End Sub
NOTE: Updated the call to reflect the suggestion made by sadrasjd.
Sub test()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Dim x As Workbook
Dim y As Workbook
Set x = ActiveWorkbook
Set y = Workbooks.Open("S:\HR\Attendance Charts\2014\May 14\abc.xlsx")
y.Sheets("Report").Activate
ActiveSheet.Range("A34:DM64").Copy
x.Sheets("Modified").Activate
ActiveSheet.Range("A70").PasteSpecial xlPasteValues
y.Close
End Sub
I am using this code to copy some data from x workbook to y workbook. Size of x workbook is 13 MB and the Y is 23.5 MB. Copying the data from x and pasting it to y takes a lot of time. Is there anyway I can make this process run faster? I am using the code above. Thanks
According to http://www.ozgrid.com/VBA/SpeedingUpVBACode.htm , the following may make your code faster (it bypasses the clipboard and copies the values directly):
Sub test()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Dim x As Workbook
Dim y As Workbook
Dim r1 As Range ' source
Dim r2 As Range ' destination
Set x = ActiveWorkbook
Set y = Workbooks.Open("S:\HR\Attendance Charts\2014\May 14\abc.xlsx")
Set r1 = y.Sheets("Report").Range("A34:DM64")
Set r2 = x.Sheets("Modified").Range("A70:DM100")
r2.Value = r1.Value '<<<<<<<<< this is the line that does the magic
y.Close
End Sub
Do check that I set the ranges r1 and r2 correctly...
i changed Floris's code a bit, to try with a VBA Array
Sub test()
with Application
.ScreenUpdating = False
.DisplayAlerts = False
.AskToUpdateLinks = False
.enableevents=false
.calculation = Xlmanual
end with
Dim x As Workbook
Dim y As Workbook
Dim r1 As Range ' source
Dim r2 As Range ' destination
Dim Y_Array() as Variant
dim Y_Sheet as Worksheet
Dim X_Sheet as Worksheet
Set x = ActiveWorkbook
Set X_Sheet= x.Sheets("Modified") '=activesheet ' i've preferably named it with complete name here
'testing if y already opened, if it's the case win a lot of time
err.clear
on error resume next
Set y = Workbooks ("abc.xlsx")
if err<>0 then
err.clear
Set y = Workbooks.Open("S:\HR\Attendance Charts\2014\May 14\abc.xlsx")
end if
on error goto 0
with y
application.windows(.name).windowstate=xlminimized
set Y_Sheet= .Sheets("Report")
with Y_Sheet
Set r1 = .Range(.cells(34,1) , .cells(64,117) ) ' same as "A34:DM64")
with r1
redim Y_Array (1 to 30, 1 to 117) 'to make it a dynamic array : (1 to .rows.count, 1 to .columns.count)
Y_Array = .value2 'edit : modified to .value2
end with
end with
end with
Set r2 = x.Sheets("Modified").Range("A70:DM100")
r2.Value2 = Y_Array 'r1.Value '<<<<<<<<< this is the line that does the magic 'edit: modified to value2
y.Close
'Free memory
erase Y_Array
set r1=nothing
set Y_Sheet=nothing
set Y=nothing
set r2=nothing
set X_Sheet=nothing
set X=nothing
with Application
.ScreenUpdating = true 'uh, without reseting it to normal you gonna have troubles....
.DisplayAlerts = true
'.AskToUpdateLinks = true
.enableevents = true
.calculation = XlAutomatic
end with
End Sub
Code untested, not sure it really helps, give it a try...
I have an Excel file which includes pictures in column B and I want like to export them into several files as .jpg (or any other picture file format). The name of the file should be generated from text in column A. I tried following VBA macro:
Private Sub CommandButton1_Click()
Dim oTxt As Object
For Each cell In Ark1.Range("A1:A" & Ark1.UsedRange.Rows.Count)
' you can change the sheet1 to your own choice
saveText = cell.Text
Open "H:\Webshop_Zpider\Strukturbildene\" & saveText & ".jpg" For Output As #1
Print #1, cell.Offset(0, 1).text
Close #1
Next cell
End Sub
The result is that it generates files (jpg), without any content. I assume the line Print #1, cell.Offset(0, 1).text. is wrong.
I don't know what I need to change it into, cell.Offset(0, 1).pix?
Can anybody help me? Thanks!
If i remember correctly, you need to use the "Shapes" property of your sheet.
Each Shape object has a TopLeftCell and BottomRightCell attributes that tell you the position of the image.
Here's a piece of code i used a while ago, roughly adapted to your needs. I don't remember the specifics about all those ChartObjects and whatnot, but here it is:
For Each oShape In ActiveSheet.Shapes
strImageName = ActiveSheet.Cells(oShape.TopLeftCell.Row, 1).Value
oShape.Select
'Picture format initialization
Selection.ShapeRange.PictureFormat.Contrast = 0.5: Selection.ShapeRange.PictureFormat.Brightness = 0.5: Selection.ShapeRange.PictureFormat.ColorType = msoPictureAutomatic: Selection.ShapeRange.PictureFormat.TransparentBackground = msoFalse: Selection.ShapeRange.Fill.Visible = msoFalse: Selection.ShapeRange.Line.Visible = msoFalse: Selection.ShapeRange.Rotation = 0#: Selection.ShapeRange.PictureFormat.CropLeft = 0#: Selection.ShapeRange.PictureFormat.CropRight = 0#: Selection.ShapeRange.PictureFormat.CropTop = 0#: Selection.ShapeRange.PictureFormat.CropBottom = 0#: Selection.ShapeRange.ScaleHeight 1#, msoTrue, msoScaleFromTopLeft: Selection.ShapeRange.ScaleWidth 1#, msoTrue, msoScaleFromTopLeft
'/Picture format initialization
Application.Selection.CopyPicture
Set oDia = ActiveSheet.ChartObjects.Add(0, 0, oShape.Width, oShape.Height)
Set oChartArea = oDia.Chart
oDia.Activate
With oChartArea
.ChartArea.Select
.Paste
.Export ("H:\Webshop_Zpider\Strukturbildene\" & strImageName & ".jpg")
End With
oDia.Delete 'oChartArea.Delete
Next
This code:
Option Explicit
Sub ExportMyPicture()
Dim MyChart As String, MyPicture As String
Dim PicWidth As Long, PicHeight As Long
Application.ScreenUpdating = False
On Error GoTo Finish
MyPicture = Selection.Name
With Selection
PicHeight = .ShapeRange.Height
PicWidth = .ShapeRange.Width
End With
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:="Sheet1"
Selection.Border.LineStyle = 0
MyChart = Selection.Name & " " & Split(ActiveChart.Name, " ")(2)
With ActiveSheet
With .Shapes(MyChart)
.Width = PicWidth
.Height = PicHeight
End With
.Shapes(MyPicture).Copy
With ActiveChart
.ChartArea.Select
.Paste
End With
.ChartObjects(1).Chart.Export Filename:="MyPic.jpg", FilterName:="jpg"
.Shapes(MyChart).Cut
End With
Application.ScreenUpdating = True
Exit Sub
Finish:
MsgBox "You must select a picture"
End Sub
was copied directly from here, and works beautifully for the cases I tested.
''' Set Range you want to export to the folder
Workbooks("your workbook name").Sheets("yoursheet name").Select
Dim rgExp As Range: Set rgExp = Range("A1:H31")
''' Copy range as picture onto Clipboard
rgExp.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
''' Create an empty chart with exact size of range copied
With ActiveSheet.ChartObjects.Add(Left:=rgExp.Left, Top:=rgExp.Top, _
Width:=rgExp.Width, Height:=rgExp.Height)
.Name = "ChartVolumeMetricsDevEXPORT"
.Activate
End With
''' Paste into chart area, export to file, delete chart.
ActiveChart.Paste
ActiveSheet.ChartObjects("ChartVolumeMetricsDevEXPORT").Chart.Export "C:\ExportmyChart.jpg"
ActiveSheet.ChartObjects("ChartVolumeMetricsDevEXPORT").Delete
Dim filepath as string
Sheets("Sheet 1").ChartObjects("Chart 1").Chart.Export filepath & "Name.jpg"
Slimmed down the code to the absolute minimum if needed.
New versions of excel have made old answers obsolete. It took a long time to make this, but it does a pretty good job. Note that the maximum image size is limited and the aspect ratio is ever so slightly off, as I was not able to perfectly optimize the reshaping math. Note that I've named one of my worksheets wsTMP, you can replace it with Sheet1 or the like. Takes about 1 second to print the screenshot to target path.
Option Explicit
Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Sub weGucciFam()
Dim tmp As Variant, str As String, h As Double, w As Double
Application.PrintCommunication = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
If Application.StatusBar = False Then Application.StatusBar = "EVENTS DISABLED"
keybd_event vbKeyMenu, 0, 0, 0 'these do just active window
keybd_event vbKeySnapshot, 0, 0, 0
keybd_event vbKeySnapshot, 0, 2, 0
keybd_event vbKeyMenu, 0, 2, 0 'sendkeys alt+printscreen doesn't work
wsTMP.Paste
DoEvents
Const dw As Double = 1186.56
Const dh As Double = 755.28
str = "C:\Users\YOURUSERNAMEHERE\Desktop\Screenshot.jpeg"
w = wsTMP.Shapes(1).Width
h = wsTMP.Shapes(1).Height
Application.DisplayAlerts = False
Set tmp = Charts.Add
On Error Resume Next
With tmp
.PageSetup.PaperSize = xlPaper11x17
.PageSetup.TopMargin = IIf(w > dw, dh - dw * h / w, dh - h) + 28
.PageSetup.BottomMargin = 0
.PageSetup.RightMargin = IIf(h > dh, dw - dh * w / h, dw - w) + 36
.PageSetup.LeftMargin = 0
.PageSetup.HeaderMargin = 0
.PageSetup.FooterMargin = 0
.SeriesCollection(1).Delete
DoEvents
.Paste
DoEvents
.Export Filename:=str, Filtername:="jpeg"
.Delete
End With
On Error GoTo 0
Do Until wsTMP.Shapes.Count < 1
wsTMP.Shapes(1).Delete
Loop
Application.PrintCommunication = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub
Thanks for the ideas! I used the above ideas to make a macro to do a bulk file conversion--convert every file of one format in a folder to another format.
This code requires a sheet with cells named "FilePath" (which must end in a "\"), "StartExt" (original file extension), and "EndExt" (desired file extension). Warning: it doesn't ask for confirmation before replacing existing files with the same name and extension.
Private Sub CommandButton1_Click()
Dim path As String
Dim pathExt As String
Dim file As String
Dim oldExt As String
Dim newExt As String
Dim newFile As String
Dim shp As Picture
Dim chrt As ChartObject
Dim chrtArea As Chart
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Get settings entered by user
path = Range("FilePath")
oldExt = Range("StartExt")
pathExt = path & "*." & oldExt
newExt = Range("EndExt")
file = Dir(pathExt)
Do While Not file = "" 'cycle through all images in folder of selected format
Set shp = ActiveSheet.Pictures.Insert(path & file) 'Import image
newFile = Replace(file, "." & oldExt, "." & newExt) 'Determine new file name
Set chrt = ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height) 'Create blank chart for embedding image
Set chrtArea = chrt.Chart
shp.CopyPicture 'Copy image to clipboard
With chrtArea 'Paste image to chart, then export
.ChartArea.Select
.Paste
.Export (path & newFile)
End With
chrt.Delete 'Delete chart
shp.Delete 'Delete imported image
file = Dir 'Advance to next file
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Here is another cool way to do it- using en external viewer that accepts command line switches (IrfanView in this case) :
* I based the loop on what Michal Krzych has written above.
Sub ExportPicturesToFiles()
Const saveSceenshotTo As String = "C:\temp\"
Const pictureFormat As String = ".jpg"
Dim pic As Shape
Dim sFileName As String
Dim i As Long
i = 1
For Each pic In ActiveSheet.Shapes
pic.Copy
sFileName = saveSceenshotTo & Range("A" & i).Text & pictureFormat
Call ExportPicWithIfran(sFileName)
i = i + 1
Next
End Sub
Public Sub ExportPicWithIfran(sSaveAsPath As String)
Const sIfranPath As String = "C:\Program Files\IrfanView\i_view32.exe"
Dim sRunIfran As String
sRunIfran = sIfranPath & " /clippaste /convert=" & _
sSaveAsPath & " /killmesoftly"
' Shell is no good here. If you have more than 1 pic, it will
' mess things up (pics will over run other pics, becuase Shell does
' not make vba wait for the script to finish).
' Shell sRunIfran, vbHide
' Correct way (it will now wait for the batch to finish):
call MyShell(sRunIfran )
End Sub
Edit:
Private Sub MyShell(strShell As String)
' based on:
' http://stackoverflow.com/questions/15951837/excel-vba-wait-for-shell-command-to-complete
' by Nate Hekman
Dim wsh As Object
Dim waitOnReturn As Boolean:
Dim windowStyle As VbAppWinStyle
Set wsh = VBA.CreateObject("WScript.Shell")
waitOnReturn = True
windowStyle = vbHide
wsh.Run strShell, windowStyle, waitOnReturn
End Sub
I am creating a excel sheet that would autocomplete a text based on the text present in a particular column. After trying to make one myself unsuccessfully, I was looking online for sample codes that I could modify and incorporate in my program. (and not plagiarize)
I downloaded Workbook1.xls from http://www.ozgrid.com/forum/showthread.php?t=144438
The code is
Option Explicit
Dim ufEventsDisabled As Boolean
Dim autoCompleteEnabled As Boolean
Dim oRange As Range
Private Sub TextBox1_Change()
If ufEventsDisabled Then Exit Sub
If autoCompleteEnabled Then Call myAutoComplete(TextBox1)
End Sub
Sub myAutoComplete(aTextBox As MSForms.TextBox)
Dim RestOfCompletion As String
On Error GoTo Halt
With aTextBox
If .SelStart + .SelLength = Len(.Text) Then
RestOfCompletion = Mid(oRange.Cells(1, 1).AutoComplete(.Text), Len(.Text) + 1)
ufEventsDisabled = True
.Text = .Text & RestOfCompletion
.SelStart = Len(.Text) - Len(RestOfCompletion)
.SelLength = Len(RestOfCompletion)
End If
End With
Halt:
ufEventsDisabled = False
On Error GoTo 0
End Sub
Private Sub TextBox1_AfterUpdate()
Dim strCompleted As String
With TextBox1
strCompleted = oRange.AutoComplete(.Text)
If LCase(strCompleted) = LCase(.Text) Then
ufEventsDisabled = True
.Text = strCompleted
ufEventsDisabled = False
End If
End With
End Sub
Private Sub TextBox1_Enter()
Set oRange = ThisWorkbook.Sheets("Sheet1").Range("f4")
End Sub
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
autoCompleteEnabled = KeyCode <> vbKeyBack
autoCompleteEnabled = ((vbKey0 <= KeyCode) And (KeyCode <= vbKeyZ))
End Sub
Private Sub CommandButton1_Click()
Unload Me
End Sub
Private Sub UserForm_Click()
End Sub
If you'd notice the line RestOfCompletion = Mid(oRange.Cells(1, 1).AutoComplete(.Text), Len(.Text) + 1), I was wondering what AutoComplete is doing here. Its not a in built function and is not defined anywhere. Still the code runs fine. I am very curious.
Thanks
The .AutoComplete is a function of the Range object - it is based on passing the text to a range that exists elsewhere on the sheet.
You can see the documentation on this function here:
http://msdn.microsoft.com/en-us/library/bb209667(v=office.12).aspx
The myAutoComplete function handles the finding of the autocomplete data against the range if it exists, and the other pieces in the code are for highlighting the correct piece of text.