I am trying to initialize the API for Canon EDSDK, but for some reason the err = EdsInitializeSDK() is not returing the correct value "0" or EDS_ERR_OK. This is causing it to skip all of the remaning if statements.
Here is the code:
Private Sub VBSample_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
Dim err As Integer = EDS_ERR_OK
Dim cameraList As IntPtr = Nothing
Dim camera As IntPtr = Nothing
Dim count As Integer = 0
Dim isSDKLoaded As Boolean = False
Dim propObj As New CameraProperty
' connect property id to combobox.
m_cmbTbl.Add(kEdsPropID_AEMode, Me.AEModeCmb)
m_cmbTbl.Add(kEdsPropID_ISOSpeed, Me.ISOSpeedCmb)
m_cmbTbl.Add(kEdsPropID_Av, Me.AvCmb)
m_cmbTbl.Add(kEdsPropID_Tv, Me.TvCmb)
m_cmbTbl.Add(kEdsPropID_MeteringMode, Me.MeteringModeCmb)
m_cmbTbl.Add(kEdsPropID_ExposureCompensation, Me.ExposureCompCmb)
m_cmbTbl.Add(kEdsPropID_ImageQuality, Me.ImageQualityCmb)
err = EdsInitializeSDK()
If err = EDS_ERR_OK Then
isSDKLoaded = True
End If
If err = EDS_ERR_OK Then
err = EdsGetCameraList(cameraList)
End If
If err = EDS_ERR_OK Then
err = EdsGetChildCount(cameraList, count)
If count = 0 Then
err = EDS_ERR_DEVICE_NOT_FOUND
End If
End If
'// Get the first camera.
If err = EDS_ERR_OK Then
err = EdsGetChildAtIndex(cameraList, 0, camera)
End If
Dim deviceInfo As EdsDeviceInfo = Nothing
If err = EDS_ERR_OK Then
err = EdsGetDeviceInfo(camera, deviceInfo)
If err = EDS_ERR_OK And IsNothing(camera) = True Then
err = EDS_ERR_DEVICE_NOT_FOUND
End If
End If
If IsNothing(cameraList) = False Then
EdsRelease(cameraList)
End If
'// Create the camera model
If err = EDS_ERR_OK Then
model = cameraModelFactory(camera, deviceInfo)
If IsNothing(model) = True Then
err = EDS_ERR_DEVICE_NOT_FOUND
End If
End If
If err <> EDS_ERR_OK Then
MessageBox.Show("Cannot detect camera")
End If"
I think I have the API set up correctly, but I could be wrong.
This code might be helpful:
Option Strict Off
Option Explicit On
Imports System.Runtime.InteropServices
Public Module EDSDK
'===================================================
'
' EDSDK.h
'
'===================================================
'/******************************************************************************
'*******************************************************************************
'//
'// initialize / terminate
'//
'*******************************************************************************
'******************************************************************************/
'/*-----------------------------------------------------------------------------
'//
'// Function: EdsInitializeSDK
'//
'// Description:
'// Initializes the libraries.
'// When using the EDSDK libraries, you must call this API once
'// before using EDSDK APIs.
'//
'// Parameters:
'// In: None
'// Out: None
'//
'// Returns: Any of the sdk errors.
'-----------------------------------------------------------------------------*/
Public Declare Function EdsInitializeSDK Lib "EDSDK" () As Integer"
Should I be doing something else when I delare the function?
Related
My goal is to generate strings that contain code to be evaluated for a given set of variables. I found some similar efforts in these questions:
VBA execute code in string
How can I evaluate a string into an object in VBA?
Because in the code provided above in (2) there are issues with ScriptControl in x64, I found some patch for this at:
Getting ScriptControl to work with Excel 2010 x64
Unfortunately, there were more issues as due to some windows patches, the GUID could not be issued.
This prevented sSignature = Left(CreateObject("Scriptlet.TypeLib").GUID, 38) to return a proper GUID due to lack of permission.
This was highlighted in the following posts:
MS Access VBA Error: Run time error '70' Permission Denied
VBA 'set typelib = createobject("scriptlet.typelib")' Permission Denied
Based on the reference (5), I added some code to generate the GUID.
Unfortunately, this code is still not working and I keeo getting an error code # 13, "Type mismatch", when executing: oShellWnd.GetProperty(sSignature).
Note: I think the code for cMSHTAx86Host should be changed to avoid looping indefinitely (probably will only allow a certain number of retry and maybe a short pause between, to avoid an infinite loop and hog the processor).
I would very much like some help and posted below the code that I used below.
A class cMSHTAx86Host ( cMSHTAx86Host.cls)
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "cMSHTAx86Host"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function CoCreateGuid Lib "ole32" (ByRef GUID As Byte) As LongPtr
#Else
Declare Function CoCreateGuid Lib "ole32" (ByRef GUID As Byte) As Long
#End If
Private oWnd As Object
Private Sub Class_Initialize()
#If Win64 Then
Set oWnd = CreateWindow()
oWnd.execScript "Function CreateObjectx86(sProgID): Set CreateObjectx86 = CreateObject(sProgID) End Function", "VBScript"
#End If
End Sub
Private Function CreateWindow()
' source http://forum.script-coding.com/viewtopic.php?pid=75356#p75356
Dim sSignature, oShellWnd, oProc
On Error Resume Next
'Bug due to security patch see:
' https://stackoverflow.com/questions/45332357/ms-access-vba-error-run-time-error-70-permission-denied
' https://stackoverflow.com/questions/45082258/vba-set-typelib-createobjectscriptlet-typelib-permission-denied
'sSignature = Left(CreateObject("Scriptlet.TypeLib").GUID, 38)
sSignature = Left(GenerateGUID, 38)
CreateObject("WScript.Shell").Run "%systemroot%\syswow64\mshta.exe 'x86Host'</script><hta:application showintaskbar=no /><object id='shell' classid='clsid:8856F961-340A-11D0-A96B-00C04FD705A2'><param name=RegisterAsBrowser value=1></object><script>shell.putproperty('" & sSignature & "',document.parentWindow);</script></head>""", 0, False
Do
For Each oShellWnd In CreateObject("Shell.Application").Windows
Set CreateWindow = oShellWnd.GetProperty(sSignature)
If Err.Number = 0 Then Exit Function
Err.Clear
Next
'TODO: need to include code here to sleep and avoid infinite loops
Loop
End Function
Function CreateObjectx86(sProgID)
#If Win64 Then
If InStr(TypeName(oWnd), "HTMLWindow") = 0 Then Class_Initialize
Set CreateObjectx86 = oWnd.CreateObjectx86(sProgID)
#Else
Set CreateObjectx86 = CreateObject(sProgID)
#End If
End Function
Function Quit()
#If Win64 Then
If InStr(TypeName(oWnd), "HTMLWindow") > 0 Then oWnd.Close
#End If
End Function
Private Sub Class_Terminate()
Quit
End Sub
Private Function GenerateGUID() As String
Dim ID(0 To 15) As Byte
Dim N As Long
Dim GUID As String
Dim Res As Long
Res = CLng(CoCreateGuid(ID(0)))
For N = 0 To 15
GUID = GUID & IIf(ID(N) < 16, "0", "") & Hex$(ID(N))
If Len(GUID) = 8 Or Len(GUID) = 13 Or Len(GUID) = 18 Or Len(GUID) = 23 Then
GUID = GUID & "-"
End If
Next N
GenerateGUID = GUID
End Function
Public Function eval(strEvalContent As String) As Object
With CreateObjectx86("ScriptControl")
.Language = "VBScript"
.AddObject "app", Application, True
Set eval = .eval(strEvalContent)
End With
End Function
A module as shown below (Note that I am unsure how to pass in the variables available when running oHost.eval)
Sub testEvalCode()
Dim strEvalContent As String
Dim oHost As New cMSHTAx86Host
Dim oResult As Object
someText = "Value"
strEvalContent = "someText & "" - added"""
Set oResult = oHost.eval(strEvalContent) 'unsure how to pass all variable available for the evaluation
MsgBox CStr(objQueryTable) 'NOTE, I am yet unsure how the oResult will look like
End Sub
I am having issues returning a value from a collection using the key.
The GetPercentsUpdateCharts sub is creating a new collection and placing a new value into it with key {{percentOpen}} and value "Test".
The Contains function written with Debug.Print is outputting true which proves the key exists in the collection.
The Retrieve function always returns "Not Found".
Where did I go wrong with this?
Private Sub GetPercentsUpdateCharts()
Set colPercentTokens = Nothing
Set colPercentTokens = New Collection
'Calculate Percents and Update Charts
Store colPercentTokens, "{{percentOpen}}", "Test"
Debug.Print Contains(colPercentTokens, "{{percentOpen}}")
Debug.Print Retrieve(colPercentTokens, "{{percentOpen}}")
End Sub
Public Function Contains(col As Collection, key As String) As Boolean
On Error GoTo NotFound
Dim itm As Object
Set itm = col(key)
Contains = True
MyExit:
Exit Function
NotFound:
Contains = False
Resume MyExit
End Function
Public Function Retrieve(col As Collection, key As String) As String
On Error GoTo NotFound
Dim itm As Object
Set itm = col(key)
Retrieve = CStr(itm)
MyExit:
Exit Function
NotFound:
Retrieve = "Not Found"
Resume MyExit
End Function
Public Sub Store(col As Collection, k As String, v As String)
Dim kv As Object
If (Contains(col, k)) Then
Set kv = col(k)
kv.value = v
Else
Set kv = New KeyValue
kv.Init k, v
col.Add kv, k
End If
End Sub
I am trying to change categories color of a current selected mail in outlook 2013 using the explorer object to get the current selected item. Everything seems to be well except when I save it gives the error mentioned above. I have been looking for solutions and no luck any ideas? Thanks. here is my code in VB
Private Sub exp_SelectionChange() Handles exp.SelectionChange ' errrrorr
Try
waitapprovemail = Application.Session.GetItemFromID(exp.Selection.Item(1).EntryID)
if (CheckForRedCategory(waitapprovemail)) Then
If (CheckToReleaseMail(waitapprovemail)) Then
waitapprovemail.Categories = "Green Category"
waitapprovemail.Save() ''' this gives the error
End If
End If
Catch Exc As System.Runtime.InteropServices.COMException
MsgBox(Exc.Message & " " & Exc.Source)
Catch exc As System.InvalidCastException
MsgBox("Casting problem")
End Try
End Sub
Private Function CheckToReleaseMail(mail As MailItem) As Boolean ' errrrrr
' check the id with the ids in the locked mail, if found id then check the other flag if it is false or true, if found true then set the category of that waitemail to empty "" else keep it
Dim r As Boolean = True
Dim sarray As String()
' ofile2 = fso2.OpenTextFile("C:\Users\" & userName & "\Documents\Outlook Files\LockedMail.txt", 8, True) '8 for appending in arg2 0 for tristatefalse optional opens as ascii
Try
Using sr As New StreamReader("C:\Users\" & userName & "\Documents\Outlook Files\LockedMail.txt")
Dim line As String
Do
line = sr.ReadLine()
If (line.Equals("") Or line Is Nothing) Then
r = True
Continue Do
Else
sarray = line.Split(",")
If (sarray.Count > 0) Then
If (sarray(0).Equals(mail.EntryID, StringComparison.InvariantCultureIgnoreCase)) Then
r = False
sr.Close()
mail.Close(OlInspectorClose.olDiscard)
Return r
End If
End If
End If
Loop Until line Is Nothing
sr.Close()
End Using
Catch exc As System.Exception
End Try
mail.Close(OlInspectorClose.olDiscard)
Return r
End Function
Private Function CheckForRedCategory(mail As MailItem) As Boolean ' errrrrr
Dim b As Boolean = False
Try
If (mail.Categories.Equals("Red Category")) Then
b = True
mail.Close(OlInspectorClose.olDiscard)
Return b
Else
b = False
End If
Catch exc As System.NullReferenceException
b = False
mail.Close(OlInspectorClose.olDiscard)
End Try
mail.Close(OlInspectorClose.olDiscard)
Return b
End Function
I try to send command to a device and read data back via serial port, however it gives me a weird behavior. I have to sendData() a couple of times(most twice) to get the data. I do not want to use writeLine and I do not write a loop in my code (I have figured out already). My schema works like this. I set ReceivedByteThreshold to 1, so that each time the it receives the data from the device, the ReceivedData event handler is fired. I read one byte at a time. When it read CR, whose ascii is 13, I display the data on the label, but I have to send data (*idn?) more than once(sometimes can be done in one time but not consistent). See the pic for reference. I am not sure why it happens. Thank you in advance
Private Sub DataReceived(sender As Object, e As IO.Ports.SerialDataReceivedEventArgs) Handles SerialPort.DataReceived
Dim ret As Integer
ret = SerialPort.ReadByte()
If ((ret <> 13) And (ret <> 10)) Then
str &= System.Convert.ToChar(ret)
End If
If ret = 13 Then
ret = SerialPort.ReadByte()
If ret = 10 Then
Me.Label2.Text = str
str = ""
End If
End If
End Sub
Sub SendData(ByVal data As String)
Try
SerialPort.Write(data)
Catch ex As Exception
MsgBox("fail to send data")
End Try
End Sub
[update]
I changed my approach. I just used a Do loop but the result is still not consistent. I chose not to use timer any more but just use ReceiveData Event Handler.
Private Sub DataReceived(sender As Object, e As IO.Ports.SerialDataReceivedEventArgs) Handles SerialPort.DataReceived
Dim ret As Integer
Do
ret = SerialPort.ReadByte()
str &= System.Convert.ToChar(ret)
If ret = 13 Then
ret = SerialPort.ReadByte()
If ret = 10 Then
Exit Do
End If
End If
Loop
Me.Label2.Text = str
str = ""
End Sub
I use Docklight to test my code, you can tell sometimes it sends twice in a row before get the data back. I am not if it has race condition issue involved, thank.
Hi to give some context the code below is from an Access database that was left to me from the previous employee, Unfortunately I am not very good at VBA.
I would appreciate any help in identifying its purpose.
Private Sub Command83_Click()
On Error GoTo Err_Command83_Click
Dim stDialStr As String
Dim PrevCtl As Control
Const ERR_OBJNOTEXIST = 2467
Const ERR_OBJNOTSET = 91
Const ERR_CANTMOVE = 2483
Set PrevCtl = Screen.PreviousControl
If TypeOf PrevCtl Is TextBox Then
stDialStr = IIf(VarType(PrevCtl) > V_NULL, PrevCtl, "")
ElseIf TypeOf PrevCtl Is ListBox Then
stDialStr = IIf(VarType(PrevCtl) > V_NULL, PrevCtl, "")
ElseIf TypeOf PrevCtl Is ComboBox Then
stDialStr = IIf(VarType(PrevCtl) > V_NULL, PrevCtl, "")
Else
stDialStr = ""
End If
Application.Run "utility.wlib_AutoDial", stDialStr
Exit_Command83_Click:
Exit Sub
Err_Command83_Click:
If (Err = ERR_OBJNOTEXIST) Or (Err = ERR_OBJNOTSET) Or (Err = ERR_CANTMOVE) Then
Resume Next
End If
MsgBox Err.Description
Resume Exit_Command83_Click
End Sub
Const ERR_... are Error Codes
The script checks whether PrevCtl is a Text-, List or ComboBox and sets the string of stDialStr depending on the Box. In the end it starts an external AutoDial program with the given parameter.
Application.Run "utility.wlib_AutoDial", stDialStr