can anyone help me convert this to autoit, or at least tell me how i can do this in autoit?
Private Const DC_PAPERNAMES = 16
Private Declare Function DeviceCapabilities Lib "winspool.drv" _
Alias "DeviceCapabilitiesW" ( _
ByVal lpDeviceName As Long, _
ByVal lpPort As Long, _
ByVal iIndex As Long, _
ByVal lpOutput As Long, _
ByVal lpDevMode As Long) As Long
Private Sub Form_Load()
Dim P As Printer
For Each P In Printers
lstPrinters.AddItem P.DeviceName
Next
End Sub
Private Sub lstPrinters_Click()
Dim P As Printer
Dim lngPapers As Long
Dim strPaperNames As String
Dim lngPaper As Long
Dim strPaperName As String
Dim lngActualLength As Long
Set P = Printers(lstPrinters.ListIndex)
lngPapers = DeviceCapabilities(StrPtr(P.DeviceName), _
StrPtr(P.Port), _
DC_PAPERNAMES, _
0, _
0)
strPaperNames = String$(lngPapers * 64, 0)
lngPapers = DeviceCapabilities(StrPtr(P.DeviceName), _
StrPtr(P.Port), _
DC_PAPERNAMES, _
StrPtr(strPaperNames), _
0)
lstPapers.Clear
For lngPaper = 0 To lngPapers - 1
strPaperName = Mid$(strPaperNames, 64 * lngPaper + 1, 64)
lngActualLength = InStr(strPaperName, vbNullChar) - 1
If lngActualLength > 1 Then strPaperName = Left$(strPaperName, lngActualLength)
lstPapers.AddItem strPaperName
Next
End Sub
Here's a thread where someone is trying to do the exact same thing: http://www.autoitscript.com/forum/topic/25857-need-a-help-from-the-pros-on-making-api-call/
There is also a guide which will help you write windows API calls: http://www.autoitscript.com/forum/topic/7072-dllcall/ it deals mainly with finding the correct type conversion which is the only hard part.
Related
I have a base64 string which was generated from an image using another application. Now on my application I want to convert the base64 string to byte and display it on a PictureBox.
I already found a sample application which takes a byte input and sets a PictureBox image. Unfortunately the sample application gets the byte array from an image and just translates it back. Here's the function it uses.
Public Function PictureFromByteStream(b() As Byte) As IPicture
Dim LowerBound As Long
Dim ByteCount As Long
Dim hMem As Long
Dim lpMem As Long
Dim IID_IPicture(15)
Dim istm As stdole.IUnknown
On Error GoTo Err_Init
If UBound(b, 1) < 0 Then
Exit Function
End If
LowerBound = LBound(b)
ByteCount = (UBound(b) - LowerBound) + 1
hMem = GlobalAlloc(&H2, ByteCount)
If hMem <> 0 Then
lpMem = GlobalLock(hMem)
If lpMem <> 0 Then
MoveMemory ByVal lpMem, b(LowerBound), ByteCount
Call GlobalUnlock(hMem)
If CreateStreamOnHGlobal(hMem, 1, istm) = 0 Then
If CLSIDFromString(StrPtr("{7BF80980-BF32-101A-8BBB-00AA00300CAB}"), IID_IPicture(0)) = 0 Then
Call OleLoadPicture(ByVal ObjPtr(istm), ByteCount, 0, IID_IPicture(0), PictureFromByteStream)
End If
End If
End If
End If
Exit Function
Err_Init:
If Err.Number = 9 Then
'Uninitialized array
MsgBox "You must pass a non-empty byte array to this function!"
Else
MsgBox Err.Number & " - " & Err.Description
End If
End Function
Here's the function I found to convert a base64 string to a byte, it seems to be converting it but when I pass the byte data to the above function, no image appears.
Private Function DecodeBase64(ByVal strData As String) As Byte()
Dim objXML As MSXML2.DOMDocument
Dim objNode As MSXML2.IXMLDOMElement
' help from MSXML
Set objXML = New MSXML2.DOMDocument
Set objNode = objXML.createElement("b64")
objNode.dataType = "bin.base64"
objNode.Text = strData
DecodeBase64 = objNode.nodeTypedValue
' thanks, bye
Set objNode = Nothing
Set objXML = Nothing
End Function
And here's my code calling the functions.
Dim b() As Byte
b = DecodeBase64(Text1.Text)
Dim pic As StdPicture
Set pic = PictureFromByteStream(b)
Set Picture1.Picture = pic
Try this:
Option Explicit
Private Const CRYPT_STRING_BASE64 As Long = &H1&
Private Const STRING_IPICTURE_GUID As String = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}"
Private Declare Function CryptStringToBinaryW Lib "Crypt32.dll" ( _
ByVal pszString As Long, _
ByVal cchString As Long, _
ByVal dwFlags As Long, _
ByVal pbBinary As Long, _
ByRef pcbBinary As Long, _
ByVal pdwSkip As Long, _
ByVal pdwFlags As Long) As Long
Private Declare Function CreateStreamOnHGlobal Lib "ole32.dll" ( _
ByRef hGlobal As Any, _
ByVal fDeleteOnResume As Long, _
ByRef ppstr As Any) As Long
Private Declare Function OleLoadPicture Lib "olepro32.dll" ( _
ByVal lpStream As IUnknown, _
ByVal lSize As Long, _
ByVal fRunMode As Long, _
ByRef riid As GUID, _
ByRef lplpObj As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32.dll" ( _
ByVal lpsz As Long, _
ByRef pclsid As GUID) As Long
Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Public Function DecodeBase64(ByVal strData As String) As Byte()
Dim Buffer() As Byte
Dim dwBinaryBytes As Long
dwBinaryBytes = LenB(strData)
ReDim Buffer(dwBinaryBytes - 1) As Byte
If CryptStringToBinaryW(StrPtr(strData), LenB(strData), CRYPT_STRING_BASE64, _
VarPtr(Buffer(0)), dwBinaryBytes, 0, 0) Then
ReDim Preserve Buffer(dwBinaryBytes - 1) As Byte
DecodeBase64 = Buffer
End If
Erase Buffer
End Function
Public Function PictureFromByteStream(ByRef b() As Byte) As IPicture
On Error GoTo errorHandler
Dim istrm As IUnknown
Dim tGuid As GUID
If Not CreateStreamOnHGlobal(b(LBound(b)), False, istrm) Then
CLSIDFromString StrPtr(STRING_IPICTURE_GUID), tGuid
OleLoadPicture istrm, UBound(b) - LBound(b) + 1, False, tGuid, PictureFromByteStream
End If
Set istrm = Nothing
Exit Function
errorHandler:
Debug.Print "Error in converting to IPicture."
End Function
I have a xls/csv list of images:
Name image url
test.jpg http://test.com/232dd.jpg
test2.jpg http://test.com/2390j.jpg
I have about 200 of these...is there a way to download the list and name them as identified in the xls file?
Here is my Excel VBA:
Private Declare Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" (ByVal pCaller As Long, _
ByVal szURL As String, ByVal szFileName As String, _
ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Private Sub download_pics()
Dim rng As Range
Dim cell As Variant
Set rng = Range("A1:B10")
For Each cell In rng
' Download the file.
URLDownloadToFile 0, cell(rng, 2).Value, "C:\" & cell(rng, 1).Value, 0, 0
Next
End Sub
Running into type mismatch error with URLDownloadToFile
OK The type mismatch has to do with your iteration. You need to specify how you're iterating over rng with the For each cell in rng statement, like:
For each cell in rng.Rows
Otherwise, it treats that statement as For each cell in rng.Cells and that raises the mismatch error.
I made some modifications to the code (based on Sid's answer here), so it checks to ensure the file downloaded successfully, but mostly what you found was correct, you just need to implement it a little differently.
Private Declare Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" (ByVal pCaller As Long, _
ByVal szURL As String, ByVal szFileName As String, _
ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Private Sub download_pics()
Dim rng As Range
Dim myRow As Range
Dim imgName As String
Dim fileLocation As String
Dim Ret As Long 'return value from the URLDownloadToFile function
Set rng = Range("A1:B10")
For Each myRow In rng.Rows
With myRow
imgName = .Columns(2).Value
fileLocation = "C:\" & .Columns(1).Value
With .Columns(1).Offset(, 2)
If URLDownloadToFile(0, imgName, fileLocation, 0, 0) = 0 Then
.Value = "downloaded successfully"
Else:
.Value = "download failed!"
End If
End With
End With
Next
End Sub
I have a form that is supposed to call a script upon a button press. I am trying to invoke it via Command Line. I tested the script in the command line and it works correctly. I can't get the form to run the script in the command shell. Any ideas?
This is the command line string I need ran autonomously by the shell:
cscript.exe proc_image.vbs 170.191.XXX.XXX picName C:\PicStorage
This is what I have currently have in my On_Click() action in my button:
ShellEx "cscript.exe C:\Scripts\proc_image.vbs" & " 170.191.XXX.XXX" & " picName" & " PicStorage"
My goal is to call the script and pass it 3 parameters: an ip address, name of the picture, and final storage destination. My issue is getting the form to execute the above command line in the shell. Thanks
EDIT: Here is the ShellEx Code:
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hWnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare Function ShellExecuteForExplore Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, lpParameters As Any, _
lpDirectory As Any, ByVal nShowCmd As Long) As Long
Public Enum EShellShowConstants
essSW_HIDE = 0
essSW_MAXIMIZE = 3
essSW_MINIMIZE = 6
essSW_SHOWMAXIMIZED = 3
essSW_SHOWMINIMIZED = 2
essSW_SHOWNORMAL = 1
essSW_SHOWNOACTIVATE = 4
essSW_SHOWNA = 8
essSW_SHOWMINNOACTIVE = 7
essSW_SHOWDEFAULT = 10
essSW_RESTORE = 9
essSW_SHOW = 5
End Enum
Private Const ERROR_FILE_NOT_FOUND = 2&
Private Const ERROR_PATH_NOT_FOUND = 3&
Private Const ERROR_BAD_FORMAT = 11&
Private Const SE_ERR_ACCESSDENIED = 5 ' access denied
Private Const SE_ERR_ASSOCINCOMPLETE = 27
Private Const SE_ERR_DDEBUSY = 30
Private Const SE_ERR_DDEFAIL = 29
Private Const SE_ERR_DDETIMEOUT = 28
Private Const SE_ERR_DLLNOTFOUND = 32
Private Const SE_ERR_FNF = 2 ' file not found
Private Const SE_ERR_NOASSOC = 31
Private Const SE_ERR_PNF = 3 ' path not found
Private Const SE_ERR_OOM = 8 ' out of memory
Private Const SE_ERR_SHARE = 26
Public Function ShellEx( _
ByVal sFIle As String, _
Optional ByVal eShowCmd As EShellShowConstants = essSW_SHOWDEFAULT, _
Optional ByVal sParameters As String = "", _
Optional ByVal sDefaultDir As String = "", _
Optional sOperation As String = "open", _
Optional Owner As Long = 0 _
) As Boolean
Dim lR As Long
Dim lErr As Long, sErr As Long
If (InStr(UCase$(sFIle), ".EXE") <> 0) Then
eShowCmd = 0
End If
On Error Resume Next
If (sParameters = "") And (sDefaultDir = "") Then
lR = ShellExecuteForExplore(Owner, sOperation, sFIle, 0, 0, essSW_SHOWNORMAL)
Else
lR = ShellExecute(Owner, sOperation, sFIle, sParameters, sDefaultDir, eShowCmd)
End If
If (lR < 0) Or (lR > 32) Then
ShellEx = True
Else
' raise an appropriate error: *ERROR CODES GO HERE*
End If
End Function
It looks like you are missing C:\ in your ShellEx command just prior to PicStorage string?
Is there any way to convert from \Device\HarddiskVolume1\programfile\explorer.exe to C:\programfile\explorer.exe in visual basic 6?
thanks
Try this
Option Explicit
Private Declare Function QueryDosDevice Lib "kernel32" Alias "QueryDosDeviceA" (ByVal lpDeviceName As String, ByVal lpTargetPath As String, ByVal ucchMax As Long) As Long
Private Sub Command1_Click()
Debug.Print pvReplaceDevice("\Device\HarddiskVolume1\aaa.txt")
End Sub
Private Function pvReplaceDevice(sPath As String) As String
Dim sDrive As String
Dim sDevice As String
Dim lIdx As Long
For lIdx = 0 To 25
sDrive = Chr$(65 + lIdx) & ":"
sDevice = Space(1000)
If QueryDosDevice(sDrive, sDevice, Len(sDevice)) <> 0 Then
sDevice = Left$(sDevice, InStr(sDevice, Chr$(0)) - 1)
' Debug.Print sDrive; "="; sDevice
If LCase$(Left$(sPath, Len(sDevice))) = LCase$(sDevice) Then
pvReplaceDevice = sDrive & Mid$(sPath, Len(sDevice) + 1)
Exit Function
End If
End If
Next
pvReplaceDevice = sPath
End Function
If you want an efficient use of API functions, create a class - "DiskDevice"
Option Explicit
Private Declare Function GetLogicalDriveStrings Lib "Kernel32" Alias "GetLogicalDriveStringsW" ( _
ByVal nBufferLength As Long, _
ByVal lpBuffer As Long _
) As Long
Private Declare Function QueryDosDevice Lib "Kernel32.dll" Alias "QueryDosDeviceW" ( _
ByVal lpDeviceName As Long, _
ByVal lpTargetPath As Long, _
ByVal ucchMax As Long _
) As Long
Private m_colDrivesKeyedByDevice As VBA.Collection
Private Sub Class_Initialize()
Dim sDriveStrings As String
Dim vasDriveStrings As Variant
Dim nIndex As Long
Dim sDrive As String
' Allocate max size buffer [A-Z]:\\\0 and retrieve all drives on the system.
sDriveStrings = Space$(105)
GetLogicalDriveStrings 1000, StrPtr(sDriveStrings)
' Split over the null chars between each substring.
vasDriveStrings = Split(sDriveStrings, vbNullChar)
Set m_colDrivesKeyedByDevice = New VBA.Collection
' Iterate through each drive string (escaping later if any item is null string).
For nIndex = 0 To UBound(vasDriveStrings)
sDrive = Left$(vasDriveStrings(nIndex), 2) ' Ignore the backslash.
If Len(sDrive) = 0 Then
Exit For
End If
' Create mapping from Drive => Device
m_colDrivesKeyedByDevice.Add sDrive, GetDeviceForDrive(sDrive)
Next nIndex
End Sub
' Retrieve the device string \device\XXXXXX for the drive X:
Private Function GetDeviceForDrive(ByRef the_sDrive As String)
Const knBufferLen As Long = 1000
Dim sBuffer As String
Dim nRet As Long
sBuffer = Space$(knBufferLen)
nRet = QueryDosDevice(StrPtr(the_sDrive), StrPtr(sBuffer), knBufferLen)
GetDeviceForDrive = Left$(sBuffer, nRet - 2) ' Ignore 2 terminating null chars.
End Function
Public Function GetFilePathFromDevicePath(ByRef the_sDevicePath As String) As String
Dim nPosSecondBackslash As Long
Dim nPosThirdBackslash As Long
Dim sDevice As String
Dim sDisk As String
' Path is always \Device\<device>\path1\path2\etc. Just get everything before the third backslash.
nPosSecondBackslash = InStr(2, the_sDevicePath, "\")
nPosThirdBackslash = InStr(nPosSecondBackslash + 1, the_sDevicePath, "\")
sDevice = Left(the_sDevicePath, nPosThirdBackslash - 1)
sDisk = m_colDrivesKeyedByDevice.Item(sDevice) ' Lookup
' Reassemble, this time with disk.
GetFilePathFromDevicePath = sDisk & Mid$(the_sDevicePath, nPosThirdBackslash)
End Function
Now, you use code like:
Set m_oDiskDevice = New DiskDevice
...
sMyPath = m_oDiskDevice.GetFilePathFromDevicePath("\Device\HarddiskVolume1\programfile\explorer.exe")
That way you don't have to call the API functions multiple times - you just do a collection lookup.
I want to convert a Double variable into an 8-bytes array, this is what I've come with so far:
Dim b(0 To 7) As Byte
Dim i As Integer
dim d as double
d = 1 ' for simplicity, I sit the variable "d" to 1
For i = 0 To 7
Call CopyMemory(b(i), ByVal VarPtr(d) + i, 1)
Next i
' b => [0, 0, 0, 0, 0, 0, 240, 63]
What I'm doing wrong?
Don't use a loop, use the length argument:
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
ByRef Destination As Any, _
ByRef Source As Any, _
ByVal Length As Long)
Sub DblToByte(ByVal D As Double)
Dim Bytes(LenB(D) - 1) As Byte
Dim I As Integer
Dim S As String
CopyMemory Bytes(0), D, LenB(D)
For I = 0 To UBound(Bytes)
S = S & CStr(Bytes(I)) & " "
Next
MsgBox S
End Sub
Private Sub Form_Load()
DblToByte 1
Unload Me
End Sub
You don't show your declare statement, but CopyMemory can be declared differently for different uses of it. Try:
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
ByVal pDst As Long, _
ByVal pSrc As Long, _
ByVal ByteLen As Long _
)