Quantcast
Channel: VBForums - Visual Basic 6 and Earlier
Viewing all 22090 articles
Browse latest View live

USB interface between VB6 and PIC18F4550 (mikroC)

$
0
0
Good evening gentlemen.
I am a student from Europe. I need help with the USB interface.

Here's the link to the interface:
https://libstock.mikroe.com/projects...-visual-basic6

The above program is created according to this book (Chapter 8):
http://www.doa.go.th/aeri/files/KM/b...v_pic_in_c.pdf

Please, someone can edit the program according to the attachments "Description.pdf , Wiring diagram.pdf".

Thank you very much for your answer.

Honzik from Czech Republic (Europe)
Attached Images

HttpWebRequest-usage (against PInterest.com)

$
0
0
Just an example here, how to work with "Winhttp.WinHttpRequest.5.1" against
the official WebAPI of PInterest.

Setup of an empty VB-Project:
- include a reference to vbRichClient5 (to be able to deal with JSON more comfortably)
- Setup an empty Form like shown below

(Two Labels, Two CommandButtons, two ListBoxes, and one PictureBox, all with their default-names)

To work with the PInterest-API, one needs to get an AccessToken -
and for ones own UserAccount on PInterest this can be accomplished by creating an App first -
and then one can get an AccessToken for that "private Test-App" by using this helper-page:
https://developers.pinterest.com/tools/access_token/?

Once such an AccessToken is successfully retrieved, one can use it together with the Class below
(passing it over into the InitWithToken-Method of that Class):

Into a Class, named cPInterestAPI:
Code:

Option Explicit

Private Const ApiBaseUrl As String = "https://api.pinterest.com/v1/"

Private mAccessToken As String, mUserName As String

Public Sub InitWithToken(AccessToken As String)
  mAccessToken = AccessToken
 
  mUserName = Split(GetMyBoards.Prop("data").Item(0).Prop("url"), "/")(3)
End Sub

Public Function GetMyBoards() As cCollection
  On Error GoTo 1
    Set GetMyBoards = RPC("me/boards/?access_token=" & mAccessToken)
1 If Err Then HandlePinError
End Function

Public Property Get UserName() As String
  UserName = mUserName
End Property

Public Function GetBoardPins(BoardName As String) As cCollection
  On Error GoTo 1
    Set GetBoardPins = RPC("boards/" & mUserName & "/" & BoardName & "/pins/?access_token=" & mAccessToken & "&fields=image,id,note")
1 If Err Then HandlePinError
End Function

Public Function GetPinDetails(PinID As String) As cCollection
  On Error GoTo 1
    Set GetPinDetails = RPC("pins/" & PinID & "/?access_token=" & mAccessToken & "&fields=image,id,note,board,color,counts,creator")
1 If Err Then HandlePinError
End Function

Public Function DeletePinImage(PinID As String) As cCollection
  On Error GoTo 1
    Set DeletePinImage = RPC("pins/" & PinID & "/?access_token=" & mAccessToken, "DELETE")
1 If Err Then HandlePinError
End Function

Public Function UploadPinImage(BoardName As String, PinNote As String, ImgBytes() As Byte, Optional ByVal TimeOutSec As Long = 10) As cCollection
  On Error GoTo 1
    With New_c.JSONObject
      .Prop("board") = mUserName & "/" & BoardName
      .Prop("note") = PinNote
      .Prop("image_base64") = New_c.Crypt.Base64Enc(ImgBytes)
      Set UploadPinImage = RPC("pins/?access_token=" & mAccessToken, "POST", .SerializeToJSONUTF8, TimeOutSec)
    End With
1 If Err Then HandlePinError
End Function

Public Function DownloadPinImage(ByVal PinID As String) As cCairoSurface
  On Error GoTo 1
    Dim PinDetails As cCollection, ImgUrl As String
    Set PinDetails = GetPinDetails(PinID).Prop("data")
        ImgUrl = PinDetails.Prop("image").Prop("original").Prop("url")
   
    With CreateObject("Winhttp.WinHttpRequest.5.1")
      .Open "GET", ImgUrl, 0 'synchronous request-mode
      .Send
      If .Status = 200 Then Set DownloadPinImage = Cairo.CreateSurface(0, 0, , .ResponseBody): Exit Function
      If LCase$(Right$(ImgUrl, 4)) = ".jpg" Then
        .Open "GET", Left$(ImgUrl, Len(ImgUrl) - 4) & ".png", 0 'fallback from default-jpg to PNG (bug in Pinterest)
        .Send
        If .Status = 200 Then Set DownloadPinImage = Cairo.CreateSurface(0, 0, , .ResponseBody): Exit Function
        Err.Raise vbObjectError, , "Error: http-status=" & .Status & " " & .StatusText & vbCrLf & .ResponseText
      End If
    End With
1 If Err Then HandlePinError
End Function

'****** End of Public-Interface - what follows are just 2 small Helper-Functions *******

Private Sub HandlePinError()
  MsgBox Err.Description 'alternatively, raise an Event here, or log the Message, or whatever
End Sub

'that's the workhorse for the PInterest-WebAPI (returning a JSON-Object as an RC5.cCollection)
Private Function RPC(RelUrl As String, Optional Method As String = "GET", Optional Bytes, Optional ByVal TimeOutSec As Long = 3) As cCollection
  With CreateObject("Winhttp.WinHttpRequest.5.1")
    .Open Method, ApiBaseUrl & RelUrl, 1 'asynchronous request-mode
   
    If IsMissing(Bytes) Then .Send Else .SetRequestHeader "Content-Type", "application/json": .Send Bytes
    If .WaitForResponse(TimeOutSec) Then 'we use the appropriate async-wait-method of WinHttp5.1 (not DoEvents)
      Select Case .Status
        Case 200, 201: Set RPC = New_c.JSONDecodeToCollection(CStr(.ResponseText))
        Case Else: Err.Raise vbObjectError, , "Error: http-status=" & .Status & " " & .StatusText & vbCrLf & .ResponseText
      End Select
    Else
      Err.Raise vbObjectError, , "Error: TimeOut of " & TimeOutSec & " reached."
    End If
  End With
End Function

The usage of the above Class is demonstrated with the following Form-Code (which one should paste into the Form which was set-up as described further above):
Code:

Option Explicit

Private PinAPI As New cPinterestAPI, i As Long, CurPins As cCollection
 
Private Sub Form_Load()
  Command1.Caption = "Add": Command2.Caption = "Remove"
  Label1.AutoSize = True: Label2.AutoSize = True
 
  PinAPI.InitWithToken "... put your own Access-Token here..."
  Label1.AutoSize = True: Label1.Caption = "UserName: " & PinAPI.UserName
 
  Dim AuthUsersPublicBoards As cCollection
  Set AuthUsersPublicBoards = PinAPI.GetMyBoards.Prop("data")
  For i = 0 To AuthUsersPublicBoards.Count - 1
    List1.AddItem AuthUsersPublicBoards(i).Prop("name")
  Next
End Sub

Private Sub List1_Click()
  If List1.ListIndex >= 0 Then UpdatePins List1.Text
End Sub

Private Sub List2_Click()
  If List2.ListIndex >= 0 Then DownloadAndRenderPin List1.ListIndex, List2.Text
End Sub

Private Sub Command1_Click()
  If List1.ListIndex >= 0 Then
    PinAPI.UploadPinImage List1.Text, "SomeNote " & Now, CreateSamplePngImg
    UpdatePins List1.Text
  End If
  If List2.ListCount Then List2.ListIndex = 0
End Sub
Private Sub Command2_Click()
  If List2.ListIndex >= 0 Then
    Set Picture1.Picture = Nothing
    PinAPI.DeletePinImage List2.Text
    UpdatePins List1.Text
  End If
End Sub

Private Sub UpdatePins(BoardName As String)
  Set CurPins = PinAPI.GetBoardPins(BoardName).Prop("data")
  List2.Clear
  If CurPins Is Nothing Then Exit Sub
  For i = 0 To CurPins.Count - 1
    List2.AddItem CurPins(i).Prop("id")
  Next
End Sub

Private Sub DownloadAndRenderPin(ListIndex As Long, PinID As String)
  Label2.Caption = CurPins(ListIndex).Prop("note")
  Set Picture1.Picture = PinAPI.DownloadPinImage(PinID).Picture
End Sub

Private Function CreateSamplePngImg() As Byte()
  With Cairo.CreateSurface(100, 200).CreateContext '<-- the Pinterest-Minimum-ImageDimensions are 100x200 Pixels
    .Paint , Cairo.CreateSolidPatternLng(vbWhite)
    .SelectFont "Arial", 16
    .DrawText 0, 0, .Surface.Width, .Surface.Height, Format$(Now, "dd\. mmmm yyyy hh:nn:ss"), False, vbCenter, 2, 1
   
    .Surface.WriteContentToPngByteArray CreateSamplePngImg
  End With
End Function
 
Private Sub Form_Terminate()
  If Forms.Count = 0 Then New_c.CleanupRichClientDll
End Sub

Now the Demo can be run, looking like this:


The Add and Remove-Buttons will add (or remove) dynamically created "plain white PNG-images with the current Date and Time"
(as shown in the PictureBox to the right).

When one does look at the Code of the Public Functions in the cPInterestAPI-Class, there is not really much to it.
Most API-Methods can be implemented in a single Line, once the "RPC-workhorse" exists (which is also not very large codewise).

I'm posting this, because I assume that the recent threads which had this topic, were prematurely closed
(not giving the OP a chance to explain himself) - in my opinion his usage of the WebBrowser-Control or
"plain-Winsock-based requests" were only due to not knowing how to deal with WinHttp 5.1 and the proper
WebAPI of PInterest, which is explained here: https://developers.pinterest.com/docs/api/overview/

Instead of accusations of "WebScraping" or worse, the more experienced developers here could at least make
an attempt to post links to the WebAPI-pages of the sites in question - and offer assistance in interpreting -
or implementing them... (In my experience, Newbies have simply no clear imagination, what a WebAPI is
or what it means to work against such an animal with a proper Request-Object... instead what they are
going to find per google is in most cases only the "all-too-common-WebBrowser-control", which then in turn
leads to these suspicious looking Code-Snippets they post when questions like "what have you tried so far?" come in...


Olaf

Class Modules Functions

$
0
0
I believe everything in a class module should be contained in *that* module.
Does that mean a function may be repeated (or duplicated) if it's used elsewhere ?
Is there any special consideration for a function used by 2 or more class modules ?

[RESOLVED] how do i detect same phone number or same names in the databae?

$
0
0
hey,
i have a customer database that has duplicates phone numbers and duplicates name
is there a way to detect duplicates?
regards
salsa31 :)

VB6 Generated email

$
0
0
Hi,

I am creating a automated email from my VB6 program. This is my first attempt at this. I am using the MAPI to create the email as i have taken over a project where emails are created using this metod previously. I have been able to generate the email with the required information and display it in outlook ready to edit / sent by the user. What i would really like to do is insert a table into the email and populate the table with information from my program. Is this possible and if so could someone give me pointers as to where to start?

Many thanks,

[RESOLVED] is there a way to detect same values in listview and highlight them?

$
0
0
hey
i have a list with some names and phone numbers.
now in this list there are duplicates of names and phone numbers.
is there a way to click on an Row and when i click it search the list view
for the same phone number(duplicates )
and if there is a match then both of them will be colored in red
E.X
salsa 986526555
mambo 986526555
other 256326565
i tried some code but it dosnt work lol.
Code:

Private Sub LsVw_ItemClick
    Dim StrSamePhone As String
    StrSamePhone = LsVw.SelectedItem.SubItems(2)
    Dim X As Integer
    For X = 1 To LsVw.ListItems.Count
        If LsVw.SelectedItem.SubItems(X) = StrSamePhone Then
            LsVw.SelectedItem.ForeColor = vbRed
        End If
    Next



tnx for any help amigos
regards
salsa :)

Inno setup question

$
0
0
My VB6 application contains 5 programs beside the main one, i want to include all of them in the Start menu, no problem here, what i want is grouping by adding menu separator, how can i do?

here is an example of the inno's script [Icons] section explain what i want to do.
Code:

[Icons]
Name: "{group}\Main Program"; Filename: "{app}\Main Program.exe"
;------------------------ I want separator line here
Name: "{group}\Program 1"; Filename: "{app}\Program 1.exe"
Name: "{group}\Program 2"; Filename: "{app}\Program 2.exe"
Name: "{group}\Program 3"; Filename: "{app}\Program 3.exe"
;------------------------ I want separator line here
Name: "{group}\Program 4"; Filename: "{app}\Program 4.exe"
Name: "{group}\Program 5"; Filename: "{app}\Program 5.exe"
;------------------------ I want separator line here
Name: "{group}\Uninstall"; Filename: "{app}\Uninstall.exe"

[RESOLVED] Finding Index in Array (from pattern)

$
0
0
Just wondering if there's a better or faster way to achieve this, other than :

Code:

z = Filter(MyArray, ToFind, True)
If UBound(z) = 0 Then  'ToFind found
For d = 1 To UBound(MyArray)
If bbFiles(d) Like "*" & ToFind & "*" Then
MyIndex= d
Exit For
End If
Next

And if there's any advantage to using Filter first to confirm the item exists.
Thanks, Alex.

VB6 Generated DDL called from a VB6 EXE Pass String Variable > 255 Get LPStr back

$
0
0
Hello All.

I have a DLL written in VB6 and linked through a windows DLL linking code (replaces LINK.EXE temporarily) The function calls work fine from the EXE (Also written in VB6). However, It seems that 255 characters is the max string length I can pass and manipulate . The string is modified and returned to the calling program (exe) via the DLL exposed Functions declared in the exe.

1. Need to pass very large strings and receive very large strings back.
2. The send string example is "This is a test string" (but may have non-printable characters in it but show as chr(x) printable.)
3. The return string example is "This is a new test string" (but may have non-printable characters in it but show as a chr(x) printable.
4. However, the string return currently is like " T h i s i s a n e w t e s t s t r i n g"
5. I can step through the return string to get "This is a new test string" but I don't want to handle the manipulation in the exe but rather have the correct string returned to the exe. from the DLL function.

Any Ideas on solving these two issues. Be gentle, I'm obviously not an expert so don't take for granted that your solution will be self evident. Need some example code to go by.

Thanks

IContextMenu InvokeCommand by direct verb?

$
0
0
So you're supposed to be able to invoke a command directly by passing a pointer to the verb string instead of a menu item number... but while this works for .GetCommandString, it does not work for InvokeCommand. I have also tried CMINVOKECOMMANDINFOEX with lpVerbW instead; no difference. It *always* interprets the value as a menu item id. While I've found a workaround, it's ugly, and probably has a few edge cases where it might not work: looping through the menu and looking for the target verb.

pcm.GetCommandString StrPtr(sVerb), GCS_VERBW, 0&, StrPtr(sVerb), Len(sVerb) -- this works and returns the original verb (or its help text if I use GCS_HELPTEXTW).

but,
tCmdInfo.cbSize = Len(tCmdInfo)
tCmdInfo.lpVerb = StrPtr(sVerb)
pcm.InvokeCommand VarPtr(tCmdInfo)

Does not work, nor does any way I've come up with so far of passing the pointer, including VarPtr to a Long containing it, and VarPtr to a byte array containing it. Only passing a menu item ID works, so this is my (hopefully temporary) ugly but working solution:
Code:

Private Function InvokeVerb(pcm As oleexp.IContextMenu, ByVal pszVerb As String, Optional lFlags As InvokeCommandMask = 0&) As Long
On Error GoTo InvokeVerb_Err
Dim hMenu As Long
Dim tCmdInfo As oleexp.CMINVOKECOMMANDINFO
Dim tCmdInfoEx As oleexp.CMINVOKECOMMANDINFOEX
hMenu = CreatePopupMenu()
Dim sVerb As String
Dim lpCmd As Long
Dim nItems As Long
Dim i As Long
Dim bOk As Boolean
lpCmd = -1
sVerb = String(MAX_PATH, 0&)
If hMenu Then
    If (pcm Is Nothing) = False Then
        pcm.QueryContextMenu hMenu, 0&, 1&, &H7FFF, CMF_NORMAL
        nItems = GetMenuItemCount(hMenu)
        For i = 0 To nItems
            lpCmd = GetMenuItemID(hMenu, i)
            pcm.GetCommandString lpCmd - 1, GCS_VERBW, 0&, StrPtr(sVerb), Len(sVerb)
            sVerb = TrimNullW(sVerb)
            If sVerb = pszVerb Then bOk = True: Exit For
        Next i
        If bOk Then
            tCmdInfo.cbSize = Len(tCmdInfo)
            tCmdInfo.lpVerb = lpCmd - 1 'VarPtr(btPtr(0)) 'StrPtr("undelete") 'VarPtr(pszVerb) 'showing other methods tried
            tCmdInfo.fMask = lFlags
            pcm.InvokeCommand VarPtr(tCmdInfo) 'if you run this right now remove VarPtr; it's for the next oleexp version so CMINVOKECOMMANDINFOEX can be used too
        End If
        Call DestroyMenu(hMenu)
    End If
End If
Exit Function
InvokeVerb_Err:
    Debug.Print "modShell.InvokeVerb->" & Err.Description & " (" & Err.Number & ")"
End Function

Any ideas on how to avoid that menu search and use a pointer like GetCommandString? Obviously both the structure and interface defs are open to modification too.

treeview To XML !

$
0
0
Hi,

I know that there was a Thread before, but there were no answers.

I need some code to export a Treeview into a XML file. I don't know how to do it.

I'd be very thankful, if someone could help me.

Bye :wave:

[RESOLVED] Countdown timer script

$
0
0
Sorry I'm green in VB6 programming, I've a question on how to optimize my script when using countdown timer:confused:
here below is my program at first which can work without problem.
Code:

Private Sub Form_Load()
Timer1.Interval = 1000
Timer1.Enabled = True
Label1.Caption = "10"
End Sub

Private Sub Timer1_Timer()
Label1.Caption = Label1.Caption - 1
    If Label1.Caption = 0 Then
        Timer1.Enabled = False
        MsgBox "Times up"
        End
    End If
End Sub

I'd like to add some text into label1 directly but fail(see below). Of course I can add some more label behind or after label1 but I just want to learn why and what's wrong with my script.

Code:

Private Sub Form_Load()
Dim M As Integer
M = 10
Timer1.Interval = 1000
Timer1.Enabled = True
Label1.Caption = "Countdown in " & M & " sec"
End Sub

Private Sub Timer1_Timer()
M = M - 1
Label1.Caption = "Countdown in " & M & " sec"
    If M = 0 Then
        Timer1.Enabled = False
        MsgBox "Times up"
        End
    End If
End Sub

Can any brother tell me what's wrong with my script:cry:

text replace in text box

$
0
0
I want to replace text in a textbox and i used below code for replace text while typing in textbox :

text1.Text = Replace(text1.Text, "cx", "xc")
text1.Text = Replace(text1.Text, "bx", "xb")
text1.Text = Replace(text1.Text, "vx, "xv")
text1.Text = Replace(text1.Text, "bx", "xb")

it replace the text while typing in textbox, but problem occurs when if there are two or more similar letters in a word e.g. cbvx then x get the place with first letter i.e. xcbv, but i want it should be cbxv if typed after after v and not replace with other letter.

looking for help from vb masters. Thanks in advance :)

Play audio files

$
0
0
Hello, I have to decide something and I would like to have some advice from other more experienced developers on the subject.

To provide some context: in my program the user performs a search, that in some cases the result points that there is an audio related to the result.
Currently the program only tells to the user that there is an audio (and which one is), and in the case the user has the audio (it's not always the case) he needs to go, locate and play the audio by himself, if he wants.

The audios are usually organized in one main folder where each one is in a different sub-folder, and may consist on one mp3 file or more than one mp3 file each "audio".

I had a request for an user that he wants to be able to play the audio clicking in the results directly, of course first configuring the main folder where all the audios are.

I have several options:

1) No to do anything.
2) To open the folder where the audio file(s) is (or are) and let the user play them with whatever program he wants.
3) To play the files with the default program that is configured in Windows for playing mp3 (how to add more than one file, is there an standard protocol?).
4) To let the user configure with what program he wants to play them (also how to add more than one file, is there an standard protocol?)
5) To make my own audio player whithin the program.

I'm thinking that perhaps the best option is 2)

To play the files directly would be a nice feature, but I don't want problems. I don't know how each Windows is configured (or misconfigured).
I think I can rely in that Windows Media Player will be always available, but perhaps some will want to use another player...

Option 5) would avoid problems, but I think it's too much work for adding this "feature".

Opinions?

PS: I cannot go to the users houses to solve problems, many of them are far away.

Thanks in advance.

[RESOLVED] VB6 Generated email

$
0
0
Hi,

I am creating a automated email from my VB6 program. This is my first attempt at this. I am using the MAPI to create the email as i have taken over a project where emails are created using this metod previously. I have been able to generate the email with the required information and display it in outlook ready to edit / sent by the user. What i would really like to do is insert a table into the email and populate the table with information from my program. Is this possible and if so could someone give me pointers as to where to start?

Many thanks,

i'm stuck....

$
0
0
i'm sure this is super simple but i can't figure it out.all i want to do is use common dialog control to open a text file and load it into a listbox.i have this code that works for a textbox but i can't make it work for a listbox...:(



Private Sub Command1_Click()

CommonDialog1.Filter = "Text Files (*.txt)|*.txt| " & _
"All Files (*.*)|*.*| "

CommonDialog1.FilterIndex = 9

CommonDialog1.ShowOpen
strFileName = CommonDialog1.FileName

Open strFileName For Input As #1
Text1.Text = Input(LOF(1), 1)
Close #1
Exit Sub

End Sub

Since which Windows version the main VB6 runtime DLL was already in system32?

$
0
0
I know that the VB5 runtime is not available by default in any Windows version.

But, VB6 runtime dll, since which Windows version is already present in Windows after just installing Windows?

VB Email code to multiple people with multiple employees?

$
0
0
So basically, I have an excel sheet with 5 columns:

EMPLID

SEQ_ID

NAME

HOLDER_EMAIL

LastOfHOLDER_NAME

Now, some holders have single employees and some have multiple employees under them. So I need to email the holders saying that these are your employees. How do I automate this process using preferably VB or any other method since the records are almost 500?

Mode and Median function

$
0
0
I want to know how I can create Mode and Median functions with VBA, without using WorksheetFunction.
:(:(:(:(

mode

median

in this form :

Public function median(.....) as ...

median formula

End function

[RESOLVED] Filtering an Array

$
0
0
Is is possible to filter an array, leaving only entries that are not "" ?
Viewing all 22090 articles
Browse latest View live


<script src="https://jsc.adskeeper.com/r/s/rssing.com.1596347.js" async> </script>