I am traying to transfer data from my locale computer to a distant one with FTP using this VB code
Dim fwr As FtpWebRequest = FtpWebRequest.Create(FTPURL)
fwr.Credentials = New NetworkCredential (FTPUserName , FTPPassword)
fwr.KeepAlive = False
fwr.UseBinary = True
fwr.Timeout = 20000
fwr.Method = WebRequestMethods.Ftp.UploadFile
Dim FileInfo As System.IO.FileInfo(LocalFilePath + LocalFileName)
Dim FileLength as Integer = FileInfo.Length
fwr.ContentLength = FileLength
Dim buffLength as Integer
if FileInfo.Length < 131072 Then
buffLength = FileLength
else
BuffLength = 131072
end if
Dim buff(buffLength - 1 ) As Byte
Dim fstream As System.IO.FileStream = FileInfo.OpenRead()
Try
Dim FTPStream As System.IO.Stream = fwr.GetRequestStream()
Dim contentLen As Integer = fstream.Read( buff , 0 , buffLength )
Do Wile contentLen <> 0
FTPStream.Write(buff, 0 , contentLen)
contentLen = fstream.Read(buff , 0 , buffLength)
Loop
FTPStream.Close()
FTPStream.Dispose()
fstream.Close()
fstream.Dispose()
Catch ex As Exception
ErrorMessage = ex.Message
End Try
fwr = Nothing
When i try to transfer file with a lambda user it's show me the error The remote server returned an error: (553) File name not allowed. but when i use root user it's working OK
Related
Good afternoon. I clarify that I don't know much about WebSockets, but I'm learning about it. I am trying to make a connection between vb.net (server) and browser (client) using WebSocket. Searching on the internet I could make this work (Websocket Server VB.NET - Data Frame) Currently I can send a message from vb.net to the browser, but I have not known how to read the messages that the client sends to the server .. I found a code about it, but I do not understand well how it could be implemented to my code (WebSocket Server, client -> server frame mask)
CLIENT
function connect(host) {
var ws = new WebSocket(host);
ws.onopen = function () {
console('connected');
//ws.send("test");
};
ws.onmessage = function (evt) {
console('reveived data:'+evt.data);
};
ws.onclose = function () {
console('socket closed');
};
SERVER
Imports System.Net.Sockets
Imports System.Threading
Imports System.Net
Public Class Form1
Dim serverTcp As TcpListener
Dim serverThread As Thread
Dim host_ As String = ""
Dim curSocket As Socket
Sub Main()
'' Start server
serverThread = New Thread(AddressOf serverProc)
serverThread.Start()
End Sub
Private Sub serverProc()
Try
'' Listen to port 5665
serverTcp = New TcpListener(System.Net.IPAddress.Parse(host_), 5665)
serverTcp.Start()
Console.WriteLine("Listen to port 5665 ...")
'' Accept any connection
While (True)
curSocket = serverTcp.AcceptSocket()
Dim thread As New Thread(AddressOf clientProc)
thread.Start(curSocket)
End While
Catch ex As Exception
End Try
End Sub
Private Sub clientProc(ByVal sck As Socket)
Try
Dim netStream As New NetworkStream(sck)
Dim netReader As New IO.StreamReader(netStream)
Dim netWriter As New IO.StreamWriter(netStream)
Dim key As String = ""
Console.WriteLine("Accept new connection ...")
'' Reading handshake message
While (True)
Dim line As String = netReader.ReadLine()
If line.Length = 0 Then
Exit While
End If
If (line.StartsWith("Sec-WebSocket-Key: ")) Then
key = line.Split(":")(1).Trim()
End If
Console.WriteLine("Data: " & line)
End While
'' Calculate accept-key
key += "258EAFA5-E914-47DA-95CA-C5AB0DC85B11"
key = getSHA1Hash(key)
'' Response handshake message
Dim response As String
response = "HTTP/1.1 101 Switching Protocols" & vbCrLf
response &= "Upgrade: websocket" & vbCrLf
response &= "Connection: Upgrade" & vbCrLf
response &= "Sec-WebSocket-Accept: " & key & vbCrLf & vbCrLf
netWriter.Write(response)
netWriter.Flush()
'' Sending message
SendMessage(sck, "SEND.. VB.NET")
Catch ex As Exception
End Try
End Sub
Sub Msg(t As String)
Console.WriteLine(t)
End Sub
Function getSHA1Hash(ByVal strToHash As String) As String
Dim sha1Obj As New System.Security.Cryptography.SHA1CryptoServiceProvider
Dim bytesToHash() As Byte = System.Text.Encoding.ASCII.GetBytes(strToHash)
Dim result As String
bytesToHash = sha1Obj.ComputeHash(bytesToHash)
result = Convert.ToBase64String(bytesToHash)
Return result
End Function
Sub SendMessage(sck As Socket, message As String)
Dim rawData = System.Text.Encoding.UTF8.GetBytes(message)
Dim frameCount = 0
Dim frame(10) As Byte
frame(0) = CByte(129)
If rawData.Length <= 125 Then
frame(1) = CByte(rawData.Length)
frameCount = 2
ElseIf rawData.Length >= 126 AndAlso rawData.Length <= 65535 Then
frame(1) = CByte(126)
Dim len = CByte(rawData.Length)
frame(2) = CByte(((len >> 8) & CByte(255)))
frame(3) = CByte((len & CByte(255)))
frameCount = 4
Else
frame(1) = CByte(127)
Dim len = CByte(rawData.Length)
frame(2) = CByte(((len >> 56) & CByte(255)))
frame(3) = CByte(((len >> 48) & CByte(255)))
frame(4) = CByte(((len >> 40) & CByte(255)))
frame(5) = CByte(((len >> 32) & CByte(255)))
frame(6) = CByte(((len >> 24) & CByte(255)))
frame(7) = CByte(((len >> 16) & CByte(255)))
frame(8) = CByte(((len >> 8) & CByte(255)))
frame(9) = CByte((len & CByte(255)))
frameCount = 10
End If
Dim bLength = frameCount + rawData.Length
Console.WriteLine(frameCount)
Console.WriteLine(rawData.Length)
Dim reply(bLength + 1) As Byte
Dim bLim = 0
For i = 0 To frameCount - 1
Console.WriteLine(bLim)
reply(bLim) = frame(i)
bLim += 1
Next
For i = 0 To rawData.Length - 1
Console.WriteLine(bLim)
reply(bLim) = rawData(i)
bLim += 1
Next
sck.Send(reply)
End Sub
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
host_ = Dns.GetHostEntry(Dns.GetHostName()).AddressList _
.Where(Function(a As IPAddress) Not a.IsIPv6LinkLocal AndAlso Not a.IsIPv6Multicast AndAlso Not a.IsIPv6SiteLocal) _
.Last() _
.ToString()
End Sub
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
Main()
End Sub
Private Sub btnEnviarMensaje_Click(sender As Object, e As EventArgs) Handles btnEnviarMensaje.Click
SendMessage(curSocket, txtMensaje.Text)
End Sub
End Class
it is simple if you want implement this in your vb.net project
you have to put this code anywhere in your project to calling
you also can use it as a "clientProc" private sub or you also
can insert this code in button1 object if you will click on button
after handshake it will give you return web browser websocket client message
Dim netStream As New NetworkStream(curSocket)
Dim bytesArray(1024) As [Byte]
Dim byteslen As Int32
byteslen = netStream.Read(bytesArray, 0, bytesArray.Length)
If bytesArray.Length > 1 Then
Msg("---------------------------------------------------")
Msg("data type: " & bytesArray(0))
Dim secondByte As Byte = bytesArray(1)
Dim theLength As UInteger = secondByte And 127
Dim indexFirstMask As Integer = 2
If theLength = 126 Then
indexFirstMask = 4
ElseIf theLength = 127 Then
indexFirstMask = 10
End If
Msg("indexFirstMask: " & indexFirstMask)
Dim masks As New List(Of Byte)
Dim x As Integer = indexFirstMask
While (x < indexFirstMask + 4)
masks.Add(bytesArray(x))
x += 1
End While
Dim indexFirstDataByte = indexFirstMask + 4
Dim decoded(byteslen - indexFirstDataByte) As Byte
Dim i As Integer = 0, j As Integer = 0
For i = indexFirstDataByte To byteslen Step 1
Dim mask As Byte = masks(j Mod 4)
Dim encodedByte As Byte = bytesArray(i)
decoded(j) = (encodedByte Xor mask)
j += 1
Next
Console.WriteLine("FROM CLIENT: '" & System.Text.Encoding.UTF8.GetString(decoded) & "'")
'Console.WriteLine("temp " + decoded.ToString)
SendMessage(curSocket, "CONNECTION_OK")
End If
I get an hresult 0x800a01b6 on the seccond passing of my code.
When it runs the first time it works but fails seccond time around. IE opens then program stops.
Dim pID As String
Dim mesg As String
Dim pw As String
Dim Id As String
Dim ie As Object
Dim l As String
'For Each Id In ListBox2.Items'
For i As Integer = 0 To Me.ListBox2.Items.Count - 1
Id = Me.ListBox2.Items(i).ToString
If Id = "me " Then
Id = "466901"
ElseIf "you" Then
Id = "466942"
End If
ie = CreateObject("InternetExplorer.Application")
ie.Navigate("http://www.webpage.com.au/")
ie.Visible = True
mesg = TextBox1.Text.ToString()
pw = "....."
ie.Document.All("password").Value = pw
ie.Document.All("idpagers").Value = Id
ie.Document.All("message").Value = mesg
ie.Document.All("Send").Click()
pID = ie.Document.All().ToString
'MessageBox.Show(pID)
MessageBox.Show(l & mesg & pw, "Test")'
Next
End Sub
i m using asp classic. i want to rename image file while i upload image on web folder created by me. please help me out of this issue.
If there is a file in targeted folder with same name (like lokesh.jpg) what i am uploading, than new file should b automatically renamed(like lokesh(1).jpg) instead of overwriting
my code is as below:
upload.asp
<%
Class FileUploader
Public Files
Private mcolFormElem
Private Sub Class_Initialize()
Set Files = Server.CreateObject("Scripting.Dictionary")
Set mcolFormElem = Server.CreateObject("Scripting.Dictionary")
End Sub
Private Sub Class_Terminate()
If IsObject(Files) Then
Files.RemoveAll()
Set Files = Nothing
End If
If IsObject(mcolFormElem) Then
mcolFormElem.RemoveAll()
Set mcolFormElem = Nothing
End If
End Sub
Public Property Get Form(sIndex)
Form = ""
If mcolFormElem.Exists(LCase(sIndex)) Then Form = mcolFormElem.Item(LCase(sIndex))
End Property
Public Default Sub Upload()
Dim biData, sInputName
Dim nPosBegin, nPosEnd, nPos, vDataBounds, nDataBoundPos
Dim nPosFile, nPosBound
biData = Request.BinaryRead(Request.TotalBytes)
nPosBegin = 1
nPosEnd = InstrB(nPosBegin, biData, CByteString(Chr(13)))
If (nPosEnd-nPosBegin) <= 0 Then Exit Sub
vDataBounds = MidB(biData, nPosBegin, nPosEnd-nPosBegin)
nDataBoundPos = InstrB(1, biData, vDataBounds)
Do Until nDataBoundPos = InstrB(biData, vDataBounds & CByteString("--"))
nPos = InstrB(nDataBoundPos, biData, CByteString("Content-Disposition"))
nPos = InstrB(nPos, biData, CByteString("name="))
nPosBegin = nPos + 6
nPosEnd = InstrB(nPosBegin, biData, CByteString(Chr(34)))
sInputName = CWideString(MidB(biData, nPosBegin, nPosEnd-nPosBegin))
nPosFile = InstrB(nDataBoundPos, biData, CByteString("filename="))
nPosBound = InstrB(nPosEnd, biData, vDataBounds)
If nPosFile <> 0 And nPosFile < nPosBound Then
Dim oUploadFile, sFileName
Set oUploadFile = New UploadedFile
nPosBegin = nPosFile + 10
nPosEnd = InstrB(nPosBegin, biData, CByteString(Chr(34)))
sFileName = CWideString(MidB(biData, nPosBegin, nPosEnd-nPosBegin))
oUploadFile.FileName = Right(sFileName, Len(sFileName)-InStrRev(sFileName, "\"))
Dim oFileExtension
If sFileName <> "" then
oFileExtension = (Right(sFileName, Len(sFileName)-InStrRev(sFileName, ".")))
If oFileExtension <> "jpg" AND oFileExtension <> "jpeg" AND oFileExtension <> "gif" AND oFileExtension <> "pdf" then
response.write("<h1>Post New File</h1><p><font color=#ff0000>An error has occurred while processing your request.<br><br>We are sorry, Extensions other than JPG, JPEG, Gif, PDF are not allowed to upload<p><b>Click <a href='javascript:history.go(-1);'>here</a> to go back and address the error.</b></font>")
response.end
Exit Sub
End if
end If
nPos = InstrB(nPosEnd, biData, CByteString("Content-Type:"))
nPosBegin = nPos + 14
nPosEnd = InstrB(nPosBegin, biData, CByteString(Chr(13)))
oUploadFile.ContentType = CWideString(MidB(biData, nPosBegin, nPosEnd-nPosBegin))
nPosBegin = nPosEnd+4
nPosEnd = InstrB(nPosBegin, biData, vDataBounds) - 2
oUploadFile.FileData = MidB(biData, nPosBegin, nPosEnd-nPosBegin)
If sfileName <> "" then
If oUploadFile.FileSize > 10000000 Then
response.write("<h1>Post New Image</h1><p><font color=#ff0000>An error has occurred while processing your request.<br><br>We are sorry, Upload file containing 10000000(10mb) bytes only.<p><b>Click <a href='javascript:window:history.go(-1);'>here</a> to go back and address the error.</b></font>")
response.end
Exit Sub
End if
End if
If oUploadFile.FileSize > 0 Then Files.Add LCase(sInputName), oUploadFile
Else
nPos = InstrB(nPos, biData, CByteString(Chr(13)))
nPosBegin = nPos + 4
nPosEnd = InstrB(nPosBegin, biData, vDataBounds) - 2
If Not mcolFormElem.Exists(LCase(sInputName)) Then mcolFormElem.Add LCase(sInputName), CWideString(MidB(biData, nPosBegin, nPosEnd-nPosBegin))
End If
nDataBoundPos = InstrB(nDataBoundPos + LenB(vDataBounds), biData, vDataBounds)
Loop
End Sub
'String to byte string conversion
Private Function CByteString(sString)
Dim nIndex
For nIndex = 1 to Len(sString)
CByteString = CByteString & ChrB(AscB(Mid(sString,nIndex,1)))
Next
End Function
'Byte string to string conversion
Private Function CWideString(bsString)
Dim nIndex
CWideString =""
For nIndex = 1 to LenB(bsString)
CWideString = CWideString & Chr(AscB(MidB(bsString,nIndex,1)))
Next
End Function
End Class
Class UploadedFile
Public ContentType
Public FileName
Public FileData
Public Property Get FileSize()
FileSize = LenB(FileData)
End Property
Public Sub SaveToDisk(sPath)
Dim oFS, oFile
Dim nIndex
If sPath = "" Or FileName = "" Then Exit Sub
If Mid(sPath, Len(sPath)) <> "\" Then sPath = sPath & "\"
Set oFS = Server.CreateObject("Scripting.FileSystemObject")
If Not oFS.FolderExists(sPath) Then Exit Sub
Set oFile = oFS.CreateTextFile(sPath & FileName, True)
For nIndex = 1 to LenB(FileData)
oFile.Write Chr(AscB(MidB(FileData,nIndex,1)))
Next
oFile.Close
End Sub
Public Sub SaveToDatabase(ByRef oField)
If LenB(FileData) = 0 Then Exit Sub
If IsObject(oField) Then
oField.AppendChunk FileData
End If
End Sub
End Class
%>
submit.asp
<!-- #include file="upload.asp" -->
<%
response.buffer = true
Dim Uploader, File, i, j
Set Uploader = New FileUploader
Uploader.Upload()
Dim brandnm, filename
brandnm = Uploader.form("brandname")
Dim objRSa, objCmda, stra
Set objCmda = server.CreateObject("adodb.connection")
Set Objrsa = Server.CreateObject("ADODB.Recordset")
objCmda.open MM_connDUdirectory_STRING
stra = "SELECT * FROM brand"
Objrsa.Open stra,objCmda,1,2
if Uploader.Files.count <> 0 then
File = Uploader.Files.Items()
File(0).SavetoDisk Server.MapPath("upload/brands") 'Folder path where image will save
filename = File(0).Filename
else
filename = ""
End if
Objrsa.addnew
Objrsa.fields("brand_name") = brandnm
Objrsa.fields("brand_createddt") = now()
if filename <>"" then Objrsa.fields("brand_picpath") = filename
For Each File In Uploader.Files.Items
Objrsa("brand_ctype") = File.ContentType
next
Objrsa.Update
Objrsa.Close
Set Objrsa = Nothing
set objCmda = Nothing
%>
Please help me out of this issue.
If you want to rename it to follow a known pattern as in your example ("filename(number).ext"), you must to use a pseudo-code like this:
let counter = 1
let original = file(0).Filename
let current = file(0).Filename
while(current file exists)
current = original-without-extension + (counter) + original-extension
counter = counter + 1
end
However, I think that would be better to store the user provided filename into your database and choose a random-like filename to store the actual file into the filesystem.
let current = userLogin + (currentTime as yyyyMMddHHmmss) + ".uploaded"
By using a bogus file extension you make your application way more secure, as your file will not be interpretable/executable -- imagine a malicious user uploading an .ASP file and executing it.
If this break the image MIME type, you should consider creating another .ASP page read the database to discover the appropriate MIME type based on the user provided file extension, write that content-type and the binary file content.
TL;DR: don't use the user provided file name, create a new one. This will avoid server hacking.
I currently have code written to take the fields of one workbook and copy into another workbook. I currently take a range and 'snapshot' it then save that as a separate .bmp file.
I also would like to take this snapshot and attach it into a cell of the workbook I'm copying everything over into. Anybody have any advice, or see here i can add code for this?
Sub Macro4()
'
' Record and File report
Dim Model As String
Dim IssueDate As String
Dim ConcernNo As String
Dim IssuedBy As String
Dim FollowedSEC As String
Dim FollowedBy As String
Dim RespSEC As String
Dim RespBy As String
Dim Timing As String
Dim Title As String
Dim PartNo As String
Dim Block As String
Dim Supplier As String
Dim Other As String
Dim Detail As String
Dim CounterTemp As String
Dim CounterPerm As String
Dim VehicleNo As String
Dim OperationNo As String
Dim Line As String
Dim Remarks As String
Dim ConcernMemosMaster As Workbook
Dim LogData As String
Dim newFile As String
Dim fName As String
Dim Filepath As String
Dim DTAddress As String
Dim pic_rng As Range
Dim ShTemp As Worksheet
Dim ChTemp As Chart
Dim PicTemp As Picture
'Determines if any required cells are empty and stops process if there are. displays error message.
If IsEmpty(Range("c2")) Or IsEmpty(Range("AT3")) Or IsEmpty(Range("BI2")) Or IsEmpty(Range("M7")) Or IsEmpty(Range("C10")) Or IsEmpty(Range("AP14")) Or IsEmpty(Range("C14")) Or IsEmpty(Range("C23")) Or IsEmpty(Range("C37")) Or IsEmpty(Range("J51")) Or IsEmpty(Range("AA51")) Or IsEmpty(Range("C55")) Or IsEmpty(Range("AR51")) Then
MsgBox "Please fill out all required fields and retry.", vbOKOnly
Exit Sub
End If
If Dir("N:\") = "" Then '"N" drive not found, abort sub
MsgBox "Error: Drive, path or file not found. Please email copy of file to: "
Exit Sub
End If
'assigns fields
Worksheets("ConcernMemo").Select
Model = Range("c2")
IssueDate = Range("AT3")
ConcernNo = Range("BC3")
IssuedBy = Range("BI2")
FollowedSEC = Range("BA9")
FollowedBy = Range("BD9")
RespSEC = Range("BG9")
RespBy = Range("BJ9")
Timing = Range("M7")
Title = Range("C10")
PartNo = Range("AP14")
Block = Range("AP16")
Supplier = Range("AP18")
Other = Range("AZ14")
Detail = Range("C14")
CounterTemp = Range("C23")
CounterPerm = Range("C37")
VehicleNo = Range("J51")
OperationNo = Range("AA51")
Remarks = Range("C55")
Line = Range("AR51")
LogData = Format(Now(), "mm_dd_yyyy_hh_mmAMPM")
fName = Range("BC3").Value
newFile = fName & "_" & Format(Now(), "mmddyyyy_hhmmAMPM")
Filepath = "N:\Newell K\Concern_Memo\Concern_Memo_File_Drop\Concern_Memo_Records\" & fName & "_" & Format(Now(), "mmddyyyy_hhmmAMPM")
DTAddress = CreateObject("WScript.Shell").SpecialFolders("Desktop") & Application.PathSeparator
'asks user is they are ready to send to database
If MsgBox("Are you ready to send record to database?", vbYesNo) = vbNo Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set pic_rng = Worksheets("ConcernMemo").Range("AK22:BK49")
Set ShTemp = Worksheets.Add
'Takes snapshot of image/sketch and saves to sharedrive
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:=ShTemp.Name
Set ChTemp = ActiveChart
pic_rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
ChTemp.Paste
Set PicTemp = Selection
With ChTemp.Parent
.Width = PicTemp.Width + 8
.Height = PicTemp.Height + 8
End With
ChTemp.Export fileName:="N:\Newell K\Concern_Memo\Concern_Memo_File_Drop\Concern_Memo_Images\" & newFile & ".bmp", FilterName:="bmp"
ShTemp.Delete
'opens db file on sharedrive and copies fields over
Set ConcernMemosMaster = Workbooks.Open("N:\Newell K\Concern_Memo\concern_memos_DBMASTER.xlsx")
Worksheets("sheet1").Select
Worksheets("sheet1").Range("a1").Select
RowCount = Worksheets("sheet1").Range("a1").CurrentRegion.Rows.Count
With Worksheets("sheet1")
.Range("a1").Offset(RowCount, 0) = Model
.Range("b1").Offset(RowCount, 0) = IssueDate
.Range("c1").Offset(RowCount, 0) = ConcernNo
.Range("d1").Offset(RowCount, 0) = IssuedBy
.Range("e1").Offset(RowCount, 0) = FollowedSEC
.Range("f1").Offset(RowCount, 0) = FollowedBy
.Range("g1").Offset(RowCount, 0) = RespSEC
.Range("h1").Offset(RowCount, 0) = RespBy
.Range("i1").Offset(RowCount, 0) = Timing
.Range("j1").Offset(RowCount, 0) = Title
.Range("k1").Offset(RowCount, 0) = PartNo
.Range("l1").Offset(RowCount, 0) = Block
.Range("m1").Offset(RowCount, 0) = Supplier
.Range("n1").Offset(RowCount, 0) = Other
.Range("o1").Offset(RowCount, 0) = Detail
.Range("p1").Offset(RowCount, 0) = CounterTemp
.Range("q1").Offset(RowCount, 0) = CounterPerm
.Range("r1").Offset(RowCount, 0) = VehicleNo
.Range("s1").Offset(RowCount, 0) = OperationNo
.Range("t1").Offset(RowCount, 0) = Remarks
.Range("U1").Offset(RowCount, 0) = PicTemp
.Range("V1").Offset(RowCount, 0) = LogData
.Range("w1").Offset(RowCount, 0) = Filepath
.Range("x1").Offset(RowCount, 0) = Line
'saves a copy to of entire file to sharedrive
ThisWorkbook.SaveCopyAs fileName:="N:\Newell K\Concern_Memo\Concern_Memo_File_Drop\Concern_Memo_Records\" & newFile & ".xlsm"
'Saves copy to desktop
Application.DisplayAlerts = True
ThisWorkbook.SaveCopyAs DTAddress & newFile & ".xlsm"
MsgBox "A copy has been saved to your desktop"
ThisWorkbook.SendMail Recipients:="kaitlin.newell#nissan-usa.com", _
Subject:="New Concern Memo"
End With
ConcernMemosMaster.Save
ConcernMemosMaster.Close
Application.DisplayAlerts = True
MsgBox "Please close out file without saving"
End Sub
Try this out :
Range("A1:D4").CopyPicture Appearance:=xlScreen, Format:=xlBitmap
Range("A6").PasteSpecial
It will paste a copy of the "snapshot" of Range("A1:D4") at the cell A6.
EDIT : Since you have already set an object of that "target" workbook, you can use it to easily paste into it. Try this :
ConcernMemosMaster.Worksheets("sheet1").Range("A1:X1").CopyPicture Appearance:=xlScreen, Format:=xlBitmap
ConcernMemosMaster.Worksheets("sheet1").Range("B1").PasteSpecial
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.