I am adding a new function to a legacy application. Basically users are requesting permission to be allowed to carry out a function and this change will prompt them to upload a screenshot to prove this and then send an email to the relevant parties which will include this screenshot.
I was able to find some code online that performs the upload function I need (included below - credit to David Crowell) however I can't find a way that will pass the file name back to the parent page. I've tried several variations of parent.returnvalue / window.returnvalue without luck. I've never worked with vb before or file uploads so I've been hunting around Google but I've not been able to work out why this won't work, I did read something about being unable to pass server side variables back to the client side - is this the reason its not working?
Parent page (POHierarchy.asp)
' Any value greater than zero must have an uploaded file to show authorisation
if strApprovalValue <> "0" then
strTarget = "popup.asp?page=Uploader.asp"
'below should pass back uploaded filename but does not
strReturnValue = window.ShowModalDialog(strTarget, , "dialogwidth:650px; dialogheight:300px; status:no; help:no")
'************************
' test value for attachment
'*************************
'strReturnValue = "test.png"
'*************************
'test value end
'*************************
FormSubmit.hstrFileName.value = strReturnValue 'uploaded filename
Call sDisplayFormData
end if
child page (Uploader.asp)
<!-- #include file="ShadowUpload.asp" -->
<HTML>
<HEAD>
<!--<META name="VI60_DefaultClientScript" content="VBScript">-->
<META http-equiv="Pragma" content="no-cache">
<META name="GENERATOR" content="Microsoft Visual Studio 6.0">
<LINK rel="stylesheet" type="text/css" href="_Themes/Standard/popup.css">
</HEAD>
<BODY style="cursor:wait">
<%
Dim objUpload
Dim Folder
Dim intWebAccess, intPDFAccess, blnViewOnly, blnAccessAllowed
Dim strList, intBusinessIdx, strBusiness, strModuleAuthoriserName, intAuthoriserIdx, intThisUserIdx
Dim strModuleAuthoriserEmail, strDisplay, strBusinessFull, intCurrentOrg
Dim LocalSystem, strAuthoriserList, strFullHeading, strInstructions, strInstructions1, intCount
Dim rs, cmd
Dim strfileName
Folder = "C:\inetpub\wwwroot\FSSRequests\Attachments"
strFullHeading = "Please Upload the DOFA Screenshot"
If Request("action")="1" Then
Set objUpload=New ShadowUpload
If objUpload.GetError<>"" Then
Response.Write("sorry, could not upload: "&objUpload.GetError)
Else
Response.Write("found "&objUpload.FileCount&" files...<br />")
For x=0 To objUpload.FileCount-1
Response.Write("file name: "&objUpload.File(x).FileName&"<br />")
Response.Write("file type: "&objUpload.File(x).ContentType&"<br />")
Response.Write("file size: "&objUpload.File(x).Size&"<br />")
Response.Write("image width: "&objUpload.File(x).ImageWidth&"<br />")
Response.Write("image height: "&objUpload.File(x).ImageHeight&"<br />")
strfileName = objUpload.File(x).FileName 'set filename to be passed back to parent window - working
If (objUpload.File(x).ImageWidth>200) Or (objUpload.File(x).ImageHeight>200) Then
Response.Write("Image too big, not saving!")
Else
Call objUpload.File(x).SaveToDisk(Folder, "")
Response.Write("file saved successfully!")
End If
Response.Write("<hr />")
Next
Response.Write("thank you, "&objUpload("name")) 'gives details of uploaded file for testing
Response.Write("File name is "&strfileName) 'shows that strfileName is being set correctly
End If
Response.Write ("<script>window.returnvalue = strfileName;</script>") 'will upload but name is not passed
Response.Write("<script>self.close();</script>")
Response.End
End If
%>
<table border=0 width="100%">
<TR width="300px" nowrap><H1><%=strFullHeading%></H1></TR>
<tr>Please screen shot your Results from DOFA with a name relevent to your request <br /> The Link is available by clicking here </tr>
<tr>Upload New Attachment</tr>
<tr><form action="<%=Request.ServerVariables( "Script_Name" )%>?action=1" enctype="multipart/form-data" method="POST">
File1: <input type="file" name="file1" /><br />
<button type="submit">Upload</button>
</form></tr>
</table>
<script language="vbscript">
Option Explicit
'********************************************************
' sPageInitialise
'********************************************************
Sub sPageInitialise
strPageTitle = "Uploader.asp"
blnAccessAllowed = IsWebAccessAllowed("VIEW", intWebAccess, intPDFAccess)
strWindow = "popup" ' ‘main’ or ‘popup’ or ‘toolbar’
End Sub
</script>
child page references ShadowUpload.asp
<%
'constants:
Const MAX_UPLOAD_SIZE=6000000 'bytes
Const MSG_NO_DATA="nothing to upload!"
Const MSG_EXCEEDED_MAX_SIZE="you exceeded the maximum upload size!"
Const SU_DEBUG_MODE=False
Class ShadowUpload
Private m_Request
Private m_Files
Private m_Error
Public Property Get GetError
GetError = m_Error
End Property
Public Property Get FileCount
FileCount = m_Files.Count
End Property
Public Function File(index)
Dim keys
keys = m_Files.Keys
Set File = m_Files(keys(index))
End Function
Public Default Property Get Item(strName)
If m_Request.Exists(strName) Then
Item = m_Request(strName)
Else
Item = ""
End If
End Property
Private Sub Class_Initialize
Dim iBytesCount, strBinData
'first of all, get amount of uploaded bytes:
iBytesCount = Request.TotalBytes
WriteDebug("initializing upload, bytes: " & iBytesCount & "<br />")
'abort if nothing there:
If iBytesCount=0 Then
m_Error = MSG_NO_DATA
Exit Sub
End If
'abort if exceeded maximum upload size:
If iBytesCount>MAX_UPLOAD_SIZE Then
m_Error = MSG_EXCEEDED_MAX_SIZE
Exit Sub
End If
'read the binary data:
strBinData = Request.BinaryRead(iBytesCount)
'create private collections:
Set m_Request = Server.CreateObject("Scripting.Dictionary")
Set m_Files = Server.CreateObject("Scripting.Dictionary")
'populate the collection:
Call BuildUpload(strBinData)
End Sub
Private Sub Class_Terminate
Dim fileName
If IsObject(m_Request) Then
m_Request.RemoveAll
Set m_Request = Nothing
End If
If IsObject(m_Files) Then
For Each fileName In m_Files.Keys
Set m_Files(fileName)=Nothing
Next
m_Files.RemoveAll
Set m_Files = Nothing
End If
End Sub
Private Sub BuildUpload(ByVal strBinData)
Dim strBinQuote, strBinCRLF, iValuePos
Dim iPosBegin, iPosEnd, strBoundaryData
Dim strBoundaryEnd, iCurPosition, iBoundaryEndPos
Dim strElementName, strFileName, objFileData
Dim strFileType, strFileData, strElementValue
strBinQuote = AsciiToBinary(chr(34))
strBinCRLF = AsciiToBinary(chr(13))
'find the boundaries
iPosBegin = 1
iPosEnd = InstrB(iPosBegin, strBinData, strBinCRLF)
strBoundaryData = MidB(strBinData, iPosBegin, iPosEnd-iPosBegin)
iCurPosition = InstrB(1, strBinData, strBoundaryData)
strBoundaryEnd = strBoundaryData & AsciiToBinary("--")
iBoundaryEndPos = InstrB(strBinData, strBoundaryEnd)
'read binary data into private collection:
Do until (iCurPosition>=iBoundaryEndPos) Or (iCurPosition=0)
'skip non relevant data...
iPosBegin = InstrB(iCurPosition, strBinData, AsciiToBinary("Content-Disposition"))
iPosBegin = InstrB(iPosBegin, strBinData, AsciiToBinary("name="))
iValuePos = iPosBegin
'read the name of the form element, e.g. "file1", "text1"
iPosBegin = iPosBegin+6
iPosEnd = InstrB(iPosBegin, strBinData, strBinQuote)
strElementName = BinaryToAscii(MidB(strBinData, iPosBegin, iPosEnd-iPosBegin))
'maybe file?
iPosBegin = InstrB(iCurPosition, strBinData, AsciiToBinary("filename="))
iPosEnd = InstrB(iPosEnd, strBinData, strBoundaryData)
If (iPosBegin>0) And (iPosBegin<iPosEnd) Then
'skip non relevant data..
iPosBegin = iPosBegin+10
'read file name:
iPosEnd = InstrB(iPosBegin, strBinData, strBinQuote)
strFileName = BinaryToAscii(MidB(strBinData, iPosBegin, iPosEnd-iPosBegin))
'verify that we got name:
If Len(strFileName)>0 Then
'create file data:
Set objFileData = New FileData
objFileData.FileName = strFileName
'read file type:
iPosBegin = InstrB(iPosEnd, strBinData, AsciiToBinary("Content-Type:"))
iPosBegin = iPosBegin+14
iPosEnd = InstrB(iPosBegin, strBinData, strBinCRLF)
strFileType = BinaryToAscii(MidB(strBinData, iPosBegin, iPosEnd-iPosBegin))
objFileData.ContentType = strFileType
'read file contents:
iPosBegin = iPosEnd+4
iPosEnd = InstrB(iPosBegin, strBinData, strBoundaryData)-2
strFileData = MidB(strBinData, iPosBegin, iPosEnd-iPosBegin)
'check that not empty:
If LenB(strFileData)>0 Then
objFileData.Contents = strFileData
'append to files collection if not empty:
Set m_Files(strFileName) = objFileData
Else
Set objFileData = Nothing
End If
End If
strElementValue = strFileName
Else
'ordinary form value, just read:
iPosBegin = InstrB(iValuePos, strBinData, strBinCRLF)
iPosBegin = iPosBegin+4
iPosEnd = InstrB(iPosBegin, strBinData, strBoundaryData)-2
strElementValue = BinaryToAscii(MidB(strBinData, iPosBegin, iPosEnd-iPosBegin))
End If
'append to request collection
m_Request(strElementName) = strElementValue
'skip to next element:
iCurPosition = InstrB(iCurPosition+LenB(strBoundaryData), strBinData, strBoundaryData)
Loop
End Sub
Private Function WriteDebug(msg)
If SU_DEBUG_MODE Then
Response.Write(msg)
Response.Flush
End If
End Function
Private Function AsciiToBinary(strAscii)
Dim i, char, result
result = ""
For i=1 to Len(strAscii)
char = Mid(strAscii, i, 1)
result = result & chrB(AscB(char))
Next
AsciiToBinary = result
End Function
Private Function BinaryToAscii(strBinary)
Dim i, result
result = ""
For i=1 to LenB(strBinary)
result = result & chr(AscB(MidB(strBinary, i, 1)))
Next
BinaryToAscii = result
End Function
End Class
Class FileData
Private m_fileName
Private m_contentType
Private m_BinaryContents
Private m_AsciiContents
Private m_imageWidth
Private m_imageHeight
Private m_checkImage
Public Property Get FileName
FileName = m_fileName
End Property
Public Property Get ContentType
ContentType = m_contentType
End Property
Public Property Get ImageWidth
If m_checkImage=False Then Call CheckImageDimensions
ImageWidth = m_imageWidth
End Property
Public Property Get ImageHeight
If m_checkImage=False Then Call CheckImageDimensions
ImageHeight = m_imageHeight
End Property
Public Property Let FileName(strName)
Dim arrTemp
arrTemp = Split(strName, "\")
m_fileName = arrTemp(UBound(arrTemp))
End Property
Public Property Let CheckImage(blnCheck)
m_checkImage = blnCheck
End Property
Public Property Let ContentType(strType)
m_contentType = strType
End Property
Public Property Let Contents(strData)
m_BinaryContents = strData
m_AsciiContents = RSBinaryToString(m_BinaryContents)
End Property
Public Property Get Size
Size = LenB(m_BinaryContents)
End Property
Private Sub CheckImageDimensions
Dim width, height, colors
Dim strType
'''If gfxSpex(BinaryToAscii(m_BinaryContents), width, height, colors, strType) = true then
If gfxSpex(m_AsciiContents, width, height, colors, strType) = true then
m_imageWidth = width
m_imageHeight = height
End If
m_checkImage = True
End Sub
Private Sub Class_Initialize
m_imageWidth = -1
m_imageHeight = -1
m_checkImage = False
End Sub
Public Sub SaveToDisk(strFolderPath, ByRef strNewFileName)
Dim strPath, objFSO, objFile
Dim i, time1, time2
Dim objStream, strExtension
strPath = strFolderPath&"\"
If Len(strNewFileName)=0 Then
strPath = strPath & m_fileName
Else
strExtension = GetExtension(strNewFileName)
If Len(strExtension)=0 Then
strNewFileName = strNewFileName & "." & GetExtension(m_fileName)
End If
strPath = strPath & strNewFileName
End If
WriteDebug("save file started...<br />")
time1 = CDbl(Timer)
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.CreateTextFile(strPath)
objFile.Write(m_AsciiContents)
'''For i=1 to LenB(m_BinaryContents)
''' objFile.Write chr(AscB(MidB(m_BinaryContents, i, 1)))
'''Next
time2 = CDbl(Timer)
WriteDebug("saving file took " & (time2-time1) & " seconds.<br />")
objFile.Close
Set objFile=Nothing
Set objFSO=Nothing
End Sub
Private Function GetExtension(strPath)
Dim arrTemp
arrTemp = Split(strPath, ".")
GetExtension = ""
If UBound(arrTemp)>0 Then
GetExtension = arrTemp(UBound(arrTemp))
End If
End Function
Private Function RSBinaryToString(xBinary)
'Antonin Foller, http://www.motobit.com
'RSBinaryToString converts binary data (VT_UI1 | VT_ARRAY Or MultiByte string)
'to a string (BSTR) using ADO recordset
Dim Binary
'MultiByte data must be converted To VT_UI1 | VT_ARRAY first.
If vartype(xBinary)=8 Then Binary = MultiByteToBinary(xBinary) Else Binary = xBinary
Dim RS, LBinary
Const adLongVarChar = 201
Set RS = CreateObject("ADODB.Recordset")
LBinary = LenB(Binary)
If LBinary>0 Then
RS.Fields.Append "mBinary", adLongVarChar, LBinary
RS.Open
RS.AddNew
RS("mBinary").AppendChunk Binary
RS.Update
RSBinaryToString = RS("mBinary")
Else
RSBinaryToString = ""
End If
End Function
Function MultiByteToBinary(MultiByte)
'© 2000 Antonin Foller, http://www.motobit.com
' MultiByteToBinary converts multibyte string To real binary data (VT_UI1 | VT_ARRAY)
' Using recordset
Dim RS, LMultiByte, Binary
Const adLongVarBinary = 205
Set RS = CreateObject("ADODB.Recordset")
LMultiByte = LenB(MultiByte)
If LMultiByte>0 Then
RS.Fields.Append "mBinary", adLongVarBinary, LMultiByte
RS.Open
RS.AddNew
RS("mBinary").AppendChunk MultiByte & ChrB(0)
RS.Update
Binary = RS("mBinary").GetChunk(LMultiByte)
End If
MultiByteToBinary = Binary
End Function
Private Function WriteDebug(msg)
If SU_DEBUG_MODE Then
Response.Write(msg)
Response.Flush
End If
End Function
Private Function BinaryToAscii(strBinary)
Dim i, result
result = ""
For i=1 to LenB(strBinary)
result = result & chr(AscB(MidB(strBinary, i, 1)))
Next
BinaryToAscii = result
End Function
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'::: :::
'::: This routine will attempt to identify any filespec passed :::
'::: as a graphic file (regardless of the extension). This will :::
'::: work with BMP, GIF, JPG and PNG files. :::
'::: :::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'::: Based on ideas presented by David Crowell :::
'::: (credit where due) :::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'::: blah blah blah blah blah blah blah blah blah blah blah blah :::
'::: blah blah blah blah blah blah blah blah blah blah blah blah :::
'::: blah blah Copyright *c* MM, Mike Shaffer blah blah :::
'::: bh blah ALL RIGHTS RESERVED WORLDWIDE blah blah :::
'::: blah blah Permission is granted to use this code blah blah :::
'::: blah blah in your projects, as long as this blah blah :::
'::: blah blah copyright notice is included blah blah :::
'::: blah blah blah blah blah blah blah blah blah blah blah blah :::
'::: blah blah blah blah blah blah blah blah blah blah blah blah :::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'::: :::
'::: This function gets a specified number of bytes from any :::
'::: file, starting at the offset (base 1) :::
'::: :::
'::: Passed: :::
'::: flnm => Filespec of file to read :::
'::: offset => Offset at which to start reading :::
'::: bytes => How many bytes to read :::
'::: :::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
Private Function GetBytes(flnm, offset, bytes)
Dim startPos
If offset=0 Then
startPos = 1
Else
startPos = offset
End If
if bytes = -1 then ' Get All!
GetBytes = flnm
else
GetBytes = Mid(flnm, startPos, bytes)
end if
' Dim objFSO
' Dim objFTemp
' Dim objTextStream
' Dim lngSize
'
' Set objFSO = CreateObject("Scripting.FileSystemObject")
'
' ' First, we get the filesize
' Set objFTemp = objFSO.GetFile(flnm)
' lngSize = objFTemp.Size
' set objFTemp = nothing
'
' fsoForReading = 1
' Set objTextStream = objFSO.OpenTextFile(flnm, fsoForReading)
'
' if offset > 0 then
' strBuff = objTextStream.Read(offset - 1)
' end if
'
' if bytes = -1 then ' Get All!
' GetBytes = objTextStream.Read(lngSize) 'ReadAll
' else
' GetBytes = objTextStream.Read(bytes)
' end if
'
' objTextStream.Close
' set objTextStream = nothing
' set objFSO = nothing
End Function
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'::: :::
'::: Functions to convert two bytes to a numeric value (long) :::
'::: (both little-endian and big-endian) :::
'::: :::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
Private Function lngConvert(strTemp)
lngConvert = clng(asc(left(strTemp, 1)) + ((asc(right(strTemp, 1)) * 256)))
end function
Private Function lngConvert2(strTemp)
lngConvert2 = clng(asc(right(strTemp, 1)) + ((asc(left(strTemp, 1)) * 256)))
end function
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'::: :::
'::: This function does most of the real work. It will attempt :::
'::: to read any file, regardless of the extension, and will :::
'::: identify if it is a graphical image. :::
'::: :::
'::: Passed: :::
'::: flnm => Filespec of file to read :::
'::: width => width of image :::
'::: height => height of image :::
'::: depth => color depth (in number of colors) :::
'::: strImageType=> type of image (e.g. GIF, BMP, etc.) :::
'::: :::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
function gfxSpex(flnm, width, height, depth, strImageType)
dim strPNG
dim strGIF
dim strBMP
dim strType
dim strBuff
dim lngSize
dim flgFound
dim strTarget
dim lngPos
dim ExitLoop
dim lngMarkerSize
strType = ""
strImageType = "(unknown)"
gfxSpex = False
strPNG = chr(137) & chr(80) & chr(78)
strGIF = "GIF"
strBMP = chr(66) & chr(77)
strType = GetBytes(flnm, 0, 3)
if strType = strGIF then ' is GIF
strImageType = "GIF"
Width = lngConvert(GetBytes(flnm, 7, 2))
Height = lngConvert(GetBytes(flnm, 9, 2))
Depth = 2 ^ ((asc(GetBytes(flnm, 11, 1)) and 7) + 1)
gfxSpex = True
elseif left(strType, 2) = strBMP then ' is BMP
strImageType = "BMP"
Width = lngConvert(GetBytes(flnm, 19, 2))
Height = lngConvert(GetBytes(flnm, 23, 2))
Depth = 2 ^ (asc(GetBytes(flnm, 29, 1)))
gfxSpex = True
elseif strType = strPNG then ' Is PNG
strImageType = "PNG"
Width = lngConvert2(GetBytes(flnm, 19, 2))
Height = lngConvert2(GetBytes(flnm, 23, 2))
Depth = getBytes(flnm, 25, 2)
select case asc(right(Depth,1))
case 0
Depth = 2 ^ (asc(left(Depth, 1)))
gfxSpex = True
case 2
Depth = 2 ^ (asc(left(Depth, 1)) * 3)
gfxSpex = True
case 3
Depth = 2 ^ (asc(left(Depth, 1))) '8
gfxSpex = True
case 4
Depth = 2 ^ (asc(left(Depth, 1)) * 2)
gfxSpex = True
case 6
Depth = 2 ^ (asc(left(Depth, 1)) * 4)
gfxSpex = True
case else
Depth = -1
end select
else
strBuff = GetBytes(flnm, 0, -1) ' Get all bytes from file
lngSize = len(strBuff)
flgFound = 0
strTarget = chr(255) & chr(216) & chr(255)
flgFound = instr(strBuff, strTarget)
if flgFound = 0 then
exit function
end if
strImageType = "JPG"
lngPos = flgFound + 2
ExitLoop = false
do while ExitLoop = False and lngPos < lngSize
do while asc(mid(strBuff, lngPos, 1)) = 255 and lngPos < lngSize
lngPos = lngPos + 1
loop
if asc(mid(strBuff, lngPos, 1)) < 192 or asc(mid(strBuff, lngPos, 1)) > 195 then
lngMarkerSize = lngConvert2(mid(strBuff, lngPos + 1, 2))
lngPos = lngPos + lngMarkerSize + 1
else
ExitLoop = True
end if
loop
if ExitLoop = False then
Width = -1
Height = -1
Depth = -1
else
Height = lngConvert2(mid(strBuff, lngPos + 4, 2))
Width = lngConvert2(mid(strBuff, lngPos + 6, 2))
Depth = 2 ^ (asc(mid(strBuff, lngPos + 8, 1)) * 8)
gfxSpex = True
end if
end if
End Function
End Class
%>
I would expect that this will pass the strfileName variable from Uploader.asp to strReturnValue in POHierarchy.asp and then should be stored in the form using FormSubmit.hstrFileName.value = strReturnValue
I need to store it as it must be passed through at least 3 more pages before the email is finally sent.
The test value I have included in POHierarchy.asp shows me that there is no issue storing the value in the form (I have a function on the next page that displays the form data) so I believe its not being passed through.
Any advice appreciated, I've been tweaking this for days now and I'm not making any progress.
Resolved this by storing the file name in a session variable
Session("filename")=strfileName
And then appended it on to my file path in a later asp page to be passed into the stored procedure that sends the email.
strFileName = Session("filename")
strFilePath = "C:\inetpub\wwwroot\FSSRequests\Attachments\"
strAttachPath = strFilePath & strFileName
You're making it very difficult for yourself here...
If I was you, I'd look into an Ajax file upload (Jquery makes it pretty easy) that doesn't use a popup window and returns the names (by the way, in case of multiple files, your method, even if successful, would only return the name of the last file processed) of the uploaded files, that you could then easily store in a hidden field of your form.
My VB6 code reads XML file
loads into MSFLEXIGRID
loops through each record, if I see a break point,
does not add data in sql table except one record why it is happening does not know. does not throw any error.
I'm appending my code below:
Private Sub cmdPrint_Click()
Dim rsMtrData As New ADODB.Recordset
Dim irow As Integer
rsClose rsMtrData
rsMtrData.Open "select * from Master_Meter_Reading ", cn, adOpenKeyset, adLockPessimistic
With MSFlexGrid1
rsMtrData.AddNew
For irow = 0 To .Rows - 1
.Row = irow
.Col = 0
rsMtrData!Snapshot = .text & ""
.Col = 1
rsMtrData!LoadSurveyDTime = Format(.text, "dd-MM-yyyy hh:mm:SS")
.Col = 2
rsMtrData!LoadSurveyDateDay = g_ConvertNumber(.text)
.Col = 3
rsMtrData!LoadSurveyDate = Format(.text, g_DateFormat)
.Col = 4
rsMtrData!LoadSurveyDateParmVal = g_ConvertNumber(.text)
.Col = 5
rsMtrData!LoadSurveyType = .text & ""
.Col = 6
rsMtrData!LoadSurveyUnit = g_ConvertNumber(.text)
.Col = 7
rsMtrData!LoadSurveySlipValParmVal = .text & ""
.Col = 8
rsMtrData!LoadSurveySlipValParmValTime = g_ConvertNumber(.text)
rsMtrData.Update
Next irow
End With
MsgBox "Data Successfully Saved", vbInformation
End Sub
You are only adding one record then updating it. At the moment the AddNew is on the outside of the loop. If you change the code and move the AddNew inside the For..Next loop it should add more rows.
Your code would look something like this:
Private Sub cmdPrint_Click()
Dim rsMtrData As New ADODB.Recordset
Dim irow As Integer
rsClose rsMtrData
rsMtrData.Open "select * from Master_Meter_Reading ", cn, adOpenKeyset, adLockPessimistic
With MSFlexGrid1
For irow = 0 To .Rows - 1
rsMtrData.AddNew 'This is the line that has moved from outside to inside the loop.
.Row = irow
.Col = 0
rsMtrData!Snapshot = .text & ""
.Col = 1
rsMtrData!LoadSurveyDTime = Format(.text, "dd-MM-yyyy hh:mm:SS")
.Col = 2
rsMtrData!LoadSurveyDateDay = g_ConvertNumber(.text)
.Col = 3
rsMtrData!LoadSurveyDate = Format(.text, g_DateFormat)
.Col = 4
rsMtrData!LoadSurveyDateParmVal = g_ConvertNumber(.text)
.Col = 5
rsMtrData!LoadSurveyType = .text & ""
.Col = 6
rsMtrData!LoadSurveyUnit = g_ConvertNumber(.text)
.Col = 7
rsMtrData!LoadSurveySlipValParmVal = .text & ""
.Col = 8
rsMtrData!LoadSurveySlipValParmValTime = g_ConvertNumber(.text)
rsMtrData.Update
Next irow
End With
MsgBox "Data Successfully Saved", vbInformation
End Sub
I'm a bit stuck on this one, since I couldn't find much on the web. Basically, I'd like the user to be able to click a button which formats some cells, and then opens a box which makes the user navigate through windows explorer in order to insert one or two pictures in the newly formatted cells.
This is what I have so far:
Private Sub AddPic_Click()
Dim lastCell As Range
Dim newCell1 As Range
Dim newCell2 As Range
Dim newCellMergePic1 As Range
Dim newCellMergePic2 As Range
Dim myRange As Range
Set myRange = Worksheets("Product Packaging").Range("A1:A1000")
For Each r In myRange
If r.MergeCells Then
Set lastCell = r
End If
Next r
Set newCell1 = lastCell.Offset(1, 0)
Set newCell2 = newCell1.Offset(0, 5)
Set newCellMergePic1 = Range(newCell1, newCell1.Offset(9, 4))
Set newCellMergePic2 = Range(newCell2, newCell2.Offset(9, 4))
newCellMergePic1.Merge
newCellMergePic2.Merge
With newCellMergePic1
.Font.Name = "Calibri"
.Font.Color = vbBlack
.VerticalAlignment = xlVAlignCenter
.HorizontalAlignment = xlHAlignCenter
.Font.Bold = True
.Value = "Picture Here"
End With
With newCellMergePic2
.Font.Name = "Calibri"
.Font.Color = vbBlack
.VerticalAlignment = xlVAlignCenter
.HorizontalAlignment = xlHAlignCenter
.Font.Bold = True
.Value = "Picture Here"
End With
End Sub
It works, but I don't know how to integrate the feature which allows the user to navigate through their folders in order to select the picture(s) they want to add. Thank you for the taking the time to read my post.
You will need to use a dialog box:
Option Explicit
Public Sub addImage1()
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.ButtonName = "Ok"
.Title = "Select an image"
.Filters.Clear
.Filters.Add "JPG", "*.JPG"
.Filters.Add "JPEG File Interchange Format", "*.JPEG"
.Filters.Add "Graphics Interchange Format", "*.GIF"
.Filters.Add "Portable Network Graphics", "*.PNG"
.Filters.Add "All Pictures", "*.*"
If .Show = -1 Then
Dim img As Object
Set img = ActiveSheet.Pictures.Insert(.SelectedItems(1))
Else
MsgBox ("Cancelled.")
End If
End With
End Sub
or
Public Sub addImage2()
Dim result, imgTypes As String
imgTypes = imgTypes & "JPG files (*.jp*),*.jp*"
imgTypes = imgTypes & ", GIF files (*.gif),*.gif"
imgTypes = imgTypes & ", PNG files (*.png),*.png"
imgTypes = imgTypes & ", All files (*.*),*.*"
result = Application.GetOpenFilename(imgTypes, 1, "Select Image", , False)
If result <> False Then
ActiveSheet.Pictures.Insert (result)
End If
End Sub
Problem solved, here is the final result
Private Sub AddPic_Click()
Dim lastCell As Range
Dim newCell1 As Range
Dim newCell2 As Range
Dim newCellMergePic1 As Range
Dim newCellMergePic2 As Range
Dim myRange As Range
Dim fd As Office.FileDialog
Dim Pic1 As Picture
Dim Pic2 As Picture
Dim Pic1Path As String
Dim Pic2Path As String
Set fd = Application.FileDialog(msoFileDialogFilePicker)
Set myRange = Worksheets("Product Packaging").Range("A1:A1000")
For Each r In myRange
If r.MergeCells Then
Set lastCell = r
End If
Next r
Set newCell1 = lastCell.Offset(1, 0)
Set newCell2 = newCell1.Offset(0, 5)
Set newCellMergePic1 = Range(newCell1, newCell1.Offset(9, 4))
Set newCellMergePic2 = Range(newCell2, newCell2.Offset(9, 4))
newCellMergePic1.Merge
newCellMergePic2.Merge
With newCellMergePic1
.Font.Name = "Calibri"
.Font.Color = vbBlack
.VerticalAlignment = xlVAlignCenter
.HorizontalAlignment = xlHAlignCenter
.Font.Bold = True
.Value = "Picture Here"
End With
With newCellMergePic2
.Font.Name = "Calibri"
.Font.Color = vbBlack
.VerticalAlignment = xlVAlignCenter
.HorizontalAlignment = xlHAlignCenter
.Font.Bold = True
.Value = "Picture Here"
End With
With fd
.AllowMultiSelect = True
.Title = "Please select picture(s). Maximum of two pictures per insert."
.Filters.Add "Images", "*.gif; *.jpg; *.jpeg", 1
If .Show = True Then
If .SelectedItems.Count > 2 Then
MsgBox "Please select no more than 2 pictures at once.", vbExclamation, Conflict
Dim delRange1 As Excel.Range
Dim delRange2 As Excel.Range
Set myRange = Worksheets("Product Packaging").Range("A1:A1000")
For Each r In myRange
If r.MergeCells Then
Set lastCell = r
End If
Next r
If lastCell.Address <> Range("A2").Address Then
Set lastCell2 = lastCell.Offset(0, 5)
Set delRange1 = lastCell.MergeArea
Set delRange2 = lastCell2.MergeArea
delRange1.ClearContents
delRange2.ClearContents
lastCell.UnMerge
lastCell2.UnMerge
Exit Sub
End If
End If
Pic1Path = .SelectedItems(1)
Set Pic1 = Pictures.Insert(Pic1Path)
With Pic1.ShapeRange
.LockAspectRatio = msoTrue
.Height = newCellMergePic1.Height - 2
.Top = newCellMergePic1.Top + 1
.Left = newCellMergePic1.Left
End With
If .SelectedItems.Count = 2 Then
Pic2Path = .SelectedItems(2)
Set Pic2 = Pictures.Insert(Pic2Path)
With Pic2.ShapeRange
.LockAspectRatio = msoTrue
.Height = newCellMergePic2.Height - 2
.Top = newCellMergePic2.Top + 1
.Left = newCellMergePic2.Left
End With
End If
End If
End With
End Sub
Screenshot
In the above form, I have an SSTab. The Add Characteristics button is an added control to create rows of characteristics. On click of this button, I can keep adding Dynamic controls (Checkbox, Label, Text, Combobox and other controls.) Now I want to capture the Action. for Example, change of Text in Combobox or Change in CheckBox Status. I am not able to trap the Event to identify which control and what code will help me capture the action of a Dynamic Control (on the first Tab)
Can some one help me with a good solution? I have been desperately searching for over a month and have not got a solution so far.
Let me know how I can send the VB code as a ZIP file for reference over email.
Expectation:
1. I should be able to capture delete Row change in the check box
2. I should be able to capture changes in Combo box
Static Controls:
1. Form: frmcharacteristics
2. Button: cmdAddCharacteristics
3. SSTab: tabDisplay
Code in Module1:
Public SR_NO As Long
Public Top_Position As Long
code in frmCharacterisitcs:
Option Explicit
Dim WithEvents Ch_Delete_Row As CheckBox
Dim WithEvents Ch_SR_NO As Label
Dim WithEvents Ch_Name As TextBox
Dim WithEvents Ch_Type As ComboBox
Dim WithEvents Extended_Control As VBControlExtender
Private Sub cmdAddCharacteristics_Click()
Module1.SR_NO = Module1.SR_NO + 1
Set Ch_Delete_Row = frmCharacteristics.Controls.Add("VB.CheckBox", "Ch_Delete_Row" & (Module1.SR_NO), tabDisplay)
Ch_Delete_Row.Visible = True
Ch_Delete_Row.Top = Module1.Top_Position + 100
Ch_Delete_Row.Width = 1000
Ch_Delete_Row.Left = 500
Ch_Delete_Row.Caption = ""
Ch_Delete_Row.Height = 315
'MsgBox Ch_Delete_Row.Name
Set Ch_SR_NO = frmCharacteristics.Controls.Add("VB.Label", "Ch_SR_NO" & (Module1.SR_NO), tabDisplay)
Ch_SR_NO.Visible = True
Ch_SR_NO.Top = Module1.Top_Position + 200
Ch_SR_NO.Width = 750
Ch_SR_NO.Left = Ch_Delete_Row.Left + Ch_Delete_Row.Width + 400
Ch_SR_NO.Caption = Module1.SR_NO
Ch_SR_NO.Height = 315
Set Ch_Name = frmCharacteristics.Controls.Add("VB.TextBox", "Ch_Name" & (Module1.SR_NO), tabDisplay)
Ch_Name.Visible = True
Ch_Name.Top = Module1.Top_Position + 100
Ch_Name.Width = 2000
Ch_Name.Left = Ch_SR_NO.Left + Ch_SR_NO.Width + 200
Ch_Name.Text = ""
Ch_Name.Height = 315
Set Ch_Type = frmCharacteristics.Controls.Add("VB.ComboBox", "Ch_Type" & (Module1.SR_NO), tabDisplay)
Ch_Type.Visible = True
Ch_Type.Top = Module1.Top_Position + 100
Ch_Type.Width = 1500
Ch_Type.Left = Ch_Name.Left + Ch_Name.Width + 50
Ch_Type.Text = ""
'Ch_Type.Height = 315
Ch_Type.AddItem "Service"
Ch_Type.AddItem "Special"
Ch_Type.AddItem "Option"
Module1.Top_Position = Module1.Top_Position + 400
End Sub
Private Sub Form_Load()
Module1.SR_NO = 0
Dim Test_Line As Control
Set Test_Line = frmCharacteristics.Controls.Add("VB.Line", "LINE", frmCharacteristics)
Test_Line.Visible = True
Test_Line.X1 = 100
Test_Line.Y1 = 600
Test_Line.X2 = frmCharacteristics.Width
Test_Line.Y2 = 600
Top_Position = Test_Line.Y1
frmCharacteristics.Show
tabDisplay.Width = frmCharacteristics.Width - 1000
tabDisplay.Height = frmCharacteristics.Height - 1500
tabDisplay.Left = frmCharacteristics.Left + 200
Call set_labels
End Sub
Sub set_labels()
Dim Label_SR_NO As Control
Dim Label_Name As Control
Dim Label_Delete_Row As Control
Dim Label_Type As Control
Set Label_Delete_Row = frmCharacteristics.Controls.Add("VB.Label", "Label_Delete_Row" & (Module1.SR_NO), tabDisplay)
Label_Delete_Row.Visible = True
Label_Delete_Row.Top = Module1.Top_Position + 100
Label_Delete_Row.Width = 1000
Label_Delete_Row.Left = 300
Label_Delete_Row.Caption = "Delete(Y/N)"
Label_Delete_Row.Height = 315
Set Label_SR_NO = frmCharacteristics.Controls.Add("VB.Label", "Label_SR_NO" & (Module1.SR_NO), tabDisplay)
Label_SR_NO.Visible = True
Label_SR_NO.Top = Module1.Top_Position + 100
Label_SR_NO.Width = 750
Label_SR_NO.Left = Label_Delete_Row.Left + Label_Delete_Row.Width + 400
Label_SR_NO.Caption = "SR_NO"
Label_SR_NO.Height = 315
Set Label_Name = frmCharacteristics.Controls.Add("VB.Label", "Label_Name" & (Module1.SR_NO), tabDisplay)
Label_Name.Visible = True
Label_Name.Top = Module1.Top_Position + 100
Label_Name.Width = 2000
Label_Name.Left = Label_SR_NO.Left + Label_SR_NO.Width + 400
Label_Name.Caption = "Characteristics Name"
Label_Name.Height = 315
Set Label_Type = frmCharacteristics.Controls.Add("VB.Label", "Label_Type" & (Module1.SR_NO), tabDisplay)
Label_Type.Visible = True
Label_Type.Top = Module1.Top_Position + 100
Label_Type.Width = 1500
Label_Type.Left = Label_Name.Left + Label_Name.Width + 50
Label_Type.Caption = "Charac. Type"
Label_Type.Height = 315
Module1.Top_Position = Module1.Top_Position + 400
End Sub
So I was tasked with migrating a website to a shared environment that will not allow 3rd party software installs which were used by the 3 previous developers. What I need to do is create an image from a subset of GIFs and return it from an asp page. Here is my current code:
The original page calls it as:
<p align="center"><img src="/code.asp"></p>
The code.asp page is as follows:
<%
Path = Server.MapPath("/images")
CodePath = Server.MapPath("/images/codes")
Dim test As System.Drawing.Image
Dim strWord As String
Dim nWidth = 0
Dim nHeight = 0
Dim strLetter as String
Dim imgpath As String
Dim imgpathnext As String
Dim nX As Integer
Dim binary As String
strWord = "OhYeah"
if len(strWord) = 0 then
strWord = "fjkuypd"
end if
nX = 1
strLetter = lcase(mid(strWord,nX,1))
imgpath = Path & "\letter_" & strLetter & ".gif"
for nX = 2 to len(strWord)
If(nX = 2)
strLetter = lcase(mid(strWord,nX,1))
imgpathnext = Path & "\letter_" & strLetter & ".gif"
test = MergeImages(System.Drawing.Image.FromFile(imgpath),System.Drawing.Image.FromFile(imgpathnext))
Continue For
End If
strLetter = lcase(mid(strWord,nX,1))
imgpathnext = Path & "\letter_" & strLetter & ".gif"
test = MergeImages(test,System.Drawing.Image.FromFile(imgpathnext))
next
binary = ImageConversion(test)
Response.Clear
Response.ContentType = "image/jpeg"
Response.BinaryWrite(binary)
Public Function ImageConversion(ByVal image As System.Drawing.Image) As String
If image Is Nothing Then Return ""
Dim memoryStream As System.IO.MemoryStream = New System.IO.MemoryStream
image.Save(memoryStream, System.Drawing.Imaging.ImageFormat.Gif)
Dim value As String = ""
For intCnt As Integer = 0 To memoryStream.ToArray.Length - 1
value = value & memoryStream.ToArray(intCnt) & ","
Next
Return value
End Function
Public Function MergeImages(ByVal Pic1 As System.Drawing.Image, ByVal pic2 As System.Drawing.Image) As System.Drawing.Image
Dim MergedImage As System.Drawing.Image ‘ This will be the finished merged image
Dim Wide, High As Integer
Wide = Pic1.Width + pic2.Width
If Pic1.Height >= pic2.Height Then
High = Pic1.Height
Else
High = pic2.Height
End If
Dim bm As New Bitmap(Wide, High)
Dim gr As Graphics = Graphics.FromImage(bm)
gr.DrawRectangle(Pens.Black, 0, 0, Wide - 1, High - 1)
gr.DrawImage(Pic1, 0, 0)
gr.DrawImage(pic2, Pic1.Width, 0)
MergedImage = bm
gr.Dispose()
Return MergedImage
End Function
%>
All i get back is a red X. Any help on this would be greatly appreciated.