Solved: .jpg file in image software

Okay - I didn't wait for you to let me know if that is what you wanted. It interesting - so here it is.

Save the text from the following message into a file and name it "WhatEverYouWant.frm".

Start a new standard project.
Add components:
1. Windows Common Dialog Controls
2. Windows Common Controls

Remove the existing empty form (Form1)
Add the "WhatEverYouWant.frm"
press F5 - you will get an error about the startup.
Change the startup to your form in the dialog box that pops up with the error.

There are instructions on a label on the form.

It works on mine - hope it works on yours.

wileecoy

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form frmAssoUtil
Caption = "File Association Utility"
ClientHeight = 8832
ClientLeft = 1140
ClientTop = 1500
ClientWidth = 7692
LinkTopic = "Form1"
PaletteMode = 1 'UseZOrder
ScaleHeight = 8832
ScaleWidth = 7692
Begin VB.PictureBox Picture1
Height = 2136
Left = 144
ScaleHeight = 2088
ScaleWidth = 7380
TabIndex = 12
Top = 2520
Width = 7428
End
Begin MSComctlLib.ListView lvwAsso
Height = 3960
Left = 108
TabIndex = 2
TabStop = 0 'False
Top = 4788
Width = 7488
_ExtentX = 13208
_ExtentY = 6985
View = 3
LabelEdit = 1
Sorted = -1 'True
LabelWrap = -1 'True
HideSelection = -1 'True
FullRowSelect = -1 'True
GridLines = -1 'True
_Version = 393217
ForeColor = -2147483640
BackColor = -2147483643
BorderStyle = 1
Appearance = 1
NumItems = 0
End
Begin VB.CommandButton Command2
Caption = "Find JPG"
Height = 300
Left = 6588
TabIndex = 9
Top = 2160
Width = 876
End
Begin VB.CommandButton Command1
Caption = "Open Application"
Height = 300
Left = 4212
TabIndex = 8
Top = 1188
Width = 3252
End
Begin VB.TextBox Text1
Height = 288
Index = 3
Left = 108
TabIndex = 7
Top = 2160
Width = 6456
End
Begin VB.TextBox Text1
Enabled = 0 'False
Height = 288
Index = 2
Left = 108
TabIndex = 6
Top = 1656
Width = 7356
End
Begin VB.TextBox Text1
Enabled = 0 'False
Height = 288
Index = 1
Left = 2160
TabIndex = 5
Top = 1188
Width = 2028
End
Begin VB.TextBox Text1
Enabled = 0 'False
Height = 288
Index = 0
Left = 108
TabIndex = 4
Top = 1188
Width = 2028
End
Begin MSComDlg.CommonDialog CommonDialog1
Left = 72
Top = 2412
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.CommandButton cmdExit
Caption = "Exit"
BeginProperty Font
Name = "MS Sans Serif"
Size = 7.8
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 1260
TabIndex = 1
TabStop = 0 'False
Top = 72
Width = 1005
End
Begin VB.CommandButton cmdList
Caption = "List"
BeginProperty Font
Name = "MS Sans Serif"
Size = 7.8
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 108
TabIndex = 0
TabStop = 0 'False
Top = 72
Width = 1005
End
Begin VB.Label lblMessage
Appearance = 0 'Flat
AutoSize = -1 'True
BackColor = &H80000005&
BackStyle = 0 'Transparent
BorderStyle = 1 'Fixed Single
ForeColor = &H80000008&
Height = 216
Left = 2592
TabIndex = 11
Top = 108
Width = 60
End
Begin VB.Label Label1
Caption = "Enter path of JPG file below, or find by clicking ""Find JPG"" button to the right."
Height = 264
Left = 108
TabIndex = 10
Top = 1944
Width = 7392
End
Begin VB.Label lblProgress
Caption = "In progress...."
BeginProperty Font
Name = "MS Sans Serif"
Size = 9.6
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 252
Left = 108
TabIndex = 3
Top = 864
Width = 2016
End
End
Attribute VB_Name = "frmAssoUtil"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' AssoUtil.frm
'
' By Herman Liu
'
' Adapted By Norm Floria
'
Option Explicit

Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type

Private Type SecurityAttributes
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Boolean
End Type

Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" _
(ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, _
ByVal samDesired As Long, phkResult As Long) As Long

Private Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" _
(ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, _
lpcbName As Long, ByVal lpReserved As Long, ByVal lpClass As String, _
lpcbClass As Long, lpftLastWriteTime As FILETIME) As Long

Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" _
(ByVal mkey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _
lpType As Long, ByVal lpData As String, lpcbData As Long) As Long

Private Declare Function RegEnumValueType Lib "advapi32.dll" Alias "RegEnumValueA" _
(ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, _
lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, _
ByVal null1 As Long, ByVal null2 As Long) As Long

Private Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" _
(ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, _
lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, lpData As Byte, _
lpcbData As Long) As Long

Private Declare Function RegEnumValueString Lib "advapi32.dll" Alias "RegEnumValueA" _
(ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, _
lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, lpData As String, _
lpcbData As Long) As Long

Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long

Private Const HKEY_CLASSES_ROOT = &H80000000
Private Const HKEY_LOCAL_MACHINE = &H80000002

' Reg key security attribute
Private Const KEY_QUERY_VALUE = &H1&
Private Const KEY_SET_VALUE = &H2&
Private Const KEY_ALL_ACCESS = &H3F
Private Const KEY_CREATE_SUBKEY = &H4&
Private Const KEY_ENUMERATE_SUBKEY = &H8&
Private Const KEY_NOTIFY = &H10&
Private Const KEY_CREATE_LINK = &H20
Private Const READ_CONTROL = &H20000
Private Const WRITE_OWNER = &H80000
Private Const STANDARD_RIGHTS_REQUIRED = &HF0000
Private Const STANDARD_RIGHTS_READ = READ_CONTROL
Private Const STANDARD_RIGHTS_WRITE = READ_CONTROL
Private Const STANDARD_RIGHTS_EXECUTE = READ_CONTROL
Private Const KEY_READ = STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or _
KEY_ENUMERATE_SUBKEY Or KEY_NOTIFY
Private Const KEY_WRITE = STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUBKEY

' Data types
Private Const REG_NONE = 0
Private Const REG_SZ = 1 ' Unicode null terminated string
Private Const REG_EXPAND_SZ = 2
Private Const REG_BINARY = 3 ' Binary
Private Const REG_DWORD = 4 ' 32-bit number
Private Const REG_DWORD_LITTLE_ENDIAN = 4
Private Const REG_DWORD_BIG_ENDIAN = 5
Private Const REG_LINK = 6
Private Const REG_MULTI_SZ = 7
Private Const REG_RESOURCE_LIST = 8
Private Const REG_FULL_RESOURCE_DESCRIPTOR = 9
Private Const REG_RESOURCE_REQUIREMENTS_LIST = 10

Private Const OPTION_NON_VOLATILE = &H0 ' Info is stored in a file and is preserved

Private Const MainKey = HKEY_LOCAL_MACHINE
Private Const SubKey = "SOFTWARE\Classes"
Private Const ShellSubKey = "Shell\Open\Command"

Dim mLVIndex As Integer
Dim mStage As Integer
Dim mStopFlag As Boolean
Dim mresult
Private Const ERROR_SUCCESS = 0&

Private Sub Command1_Click()
Dim FilePath() As String
Dim sPath As String
FilePath = Split(Text1(2).Text, "%1", -1, vbTextCompare)
sPath = Left(FilePath(0), Len(FilePath(0)) - 3) & """ """ & Text1(3).Text & """"
ShellAndWait (sPath)
Picture1.Picture = LoadPicture(Text1(3).Text)
End Sub

Private Sub Command2_Click()
On Error GoTo errhandler
Dim gcdg As Object
Set gcdg = CommonDialog1
gcdg.Filter = "(*.jpg Picture Files)|*.jpg|(*.*)|*.*|"
gcdg.FilterIndex = 1
gcdg.DefaultExt = "jpg"
gcdg.Flags = cdlOFNFileMustExist
gcdg.FileName = ""
gcdg.CancelError = True
gcdg.ShowOpen
If gcdg.FileName = "" Then
Exit Sub
End If
Text1(3).Text = gcdg.FileName
Picture1.Picture = LoadPicture(Text1(3).Text)
Exit Sub

errhandler:
If Err <> 32755 Then
MsgBox "cmdDialogFileSpec_Click"
End If
End Sub

Private Sub Form_Load()
' Configure ListView control.
lvwAsso.ListItems.Clear
lvwAsso.ColumnHeaders.Clear
lvwAsso.ColumnHeaders.Add , , "Ext", 1000
lvwAsso.ColumnHeaders.Add , , "Title Ref", (3000)
lvwAsso.ColumnHeaders.Add , , "Association", (Me.Width - 4200)
lvwAsso.LabelEdit = lvwManual
lvwAsso.FullRowSelect = True
lvwAsso.HideSelection = False
lvwAsso.HideColumnHeaders = False
lvwAsso.View = lvwReport
lblProgress.Visible = False

lblMessage = "1. Press 'List' Button" & vbCrLf & _
"2. Double-Click the 'JPG' format in the listview" & vbCrLf & _
"3. Enter the path of the JGP file or press 'Find JPG' button." & vbCrLf & _
"4. Press 'Open Application' Button"

End Sub
Private Sub cmdList_Click()
Dim mlistitem As ListItem
Dim colSubKeys As Collection
Dim arrAsso() As String
Dim mkey As Long
Dim mBuffer As String * 256
Dim mBufSize As Long
Dim mClassBuffer As String
Dim mClassBufSize As Long
Dim typLastWriteTime As FILETIME
Dim SubKeyName As String
Dim SubKeyValue As String
Dim mValType As Long
Dim mIndex As Integer
Dim mKeyRef As String
Dim mCtn As Integer
Dim mHasOne As Boolean
Dim mPercent As Integer
Dim tmp As String, mChr As String
Dim i As Integer, j As Integer

Set colSubKeys = New Collection

If RegOpenKeyEx(MainKey, SubKey, 0&, KEY_ALL_ACCESS, mkey) <> 0& Then
Exit Sub
End If

lvwAsso.Visible = True
lblProgress.Visible = True
DoEvents
Screen.MousePointer = vbHourglass
mStopFlag = False

' Enumerate the Subkey's colSubKeys
mIndex = 0
Do
mClassBuffer = ""
mClassBufSize = 0
mBufSize = 256
SubKeyName = Space$(mBufSize)
mresult = RegEnumKeyEx(mkey, mIndex, SubKeyName, mBufSize, 0, mClassBuffer, _
mClassBufSize, typLastWriteTime)
If mresult <> 0& And mresult <> 234 Then
If Left(SubKeyName, 10) = " " Then
Exit Do
End If
End If
SubKeyName = Left$(SubKeyName, InStr(SubKeyName, Chr$(0)) - 1)
If Left$(SubKeyName, 1) = "." Then
colSubKeys.Add SubKeyName
End If
mIndex = mIndex + 1
Loop

lvwAsso.ListItems.Clear
' Recursively get information on the keys.
For i = 1 To colSubKeys.Count
ListEntryValues0 MainKey, SubKey & "\" & colSubKeys(i)
Next i
RegCloseKey mkey

mCtn = lvwAsso.ListItems.Count
lblProgress.Visible = False
If mCtn = 0 Then
Screen.MousePointer = vbDefault
MsgBox "No file association found"
Exit Sub
End If

' Fill commands in Listview.
' We start from 1 as ListItems is 1-based
For i = 1 To mCtn
mKeyRef = lvwAsso.ListItems(i).SubItems(1)
mLVIndex = i
DoEnumSubKeys MainKey, SubKey & "\" & mKeyRef & "\" & ShellSubKey
Next i

' Check and delete those items without a command, if any
ReDim arrAsso(mCtn - 1, 2)
mHasOne = False
For i = 1 To mCtn
If Len(Trim(lvwAsso.ListItems(i).SubItems(2))) > 0 Then
arrAsso(i - 1, 0) = lvwAsso.ListItems(i).Text
arrAsso(i - 1, 1) = lvwAsso.ListItems(i).SubItems(1)
arrAsso(i - 1, 2) = lvwAsso.ListItems(i).SubItems(2)
Else
mHasOne = True
End If
Next i
If mHasOne Then
lvwAsso.ListItems.Clear
For i = 0 To UBound(arrAsso)
If Len(Trim(arrAsso(i, 2))) > 0 Then
Set mlistitem = lvwAsso.ListItems.Add(, , Text:=arrAsso(i, 0))
mlistitem.SubItems(1) = arrAsso(i, 1)
mlistitem.SubItems(2) = arrAsso(i, 2)
End If
Next i
End If
mCtn = lvwAsso.ListItems.Count

lblProgress.Visible = False
Screen.MousePointer = vbDefault
If mCtn > 0 Then
MsgBox "Listing completed. Total " & CStr(mCtn)
' Let hightlight visible
If Not Me.WindowState = 1 Then
lvwAsso.SetFocus
End If
Else
MsgBox "No file association found"
End If
End Sub

Private Sub DoEnumSubKeys(ByVal inMainKey As Long, ByVal inSubKey As String)
Dim mkey As Long
Dim colSubKeys As Collection
Dim colSubKeyValues As Collection

Dim mBuffer As String * 256
Dim mBufSize As Long
Dim mClassBuffer As String * 256
Dim mClassBufSize As Long
Dim typLastWriteTime As FILETIME

Dim SubKeyName As String
Dim SubKeyValue As String
Dim mValType As Long
Dim mIndex As Integer
Dim i As Integer
Dim tmp As String, mChr As String

Dim Ok As Boolean

Set colSubKeys = New Collection

If RegOpenKeyEx(inMainKey, inSubKey, 0&, KEY_ALL_ACCESS, mkey) <> 0& Then
mStopFlag = True
Exit Sub
End If

tmp = ""
For i = Len(inSubKey) To 1 Step -1
mChr = Mid(inSubKey, i, 1)
If mChr = "\" Then
Exit For
End If
tmp = mChr & tmp
Next i

ListEntryValues1 inMainKey, inSubKey

' Enumerate the Subkey's colSubKeys
mIndex = 0
Do
mClassBuffer = ""
mClassBufSize = 0
mBufSize = 256
SubKeyName = Space$(mBufSize)
mresult = RegEnumKeyEx(mkey, mIndex, SubKeyName, mBufSize, 0, mClassBuffer, _
mClassBufSize, typLastWriteTime)
If mresult <> 0& Then
Exit Do
End If
SubKeyName = Left$(SubKeyName, InStr(SubKeyName, Chr$(0)) - 1)
If Len(Trim(SubKeyName)) > 0 Then
colSubKeys.Add SubKeyName
End If
mIndex = mIndex + 1
Loop
RegCloseKey mkey

' Recursively get information on the keys.
For i = 1 To colSubKeys.Count
If mStopFlag Then
Exit Sub
End If
DoEnumSubKeys inMainKey, inSubKey & "\" & colSubKeys(i)
Next i
End Sub

Private Sub ListEntryValues0(ByVal inMainKey As Long, ByVal inSubKey As String)
Dim mkey
Dim mEntry As String
Dim mEntryLength As Long
Dim mDataType As Long
Dim arrDataByte(1 To 1024) As Byte
Dim mDataByteLength As Long
Dim mDataByteValue As String
Dim i As Integer
Dim mIndex As Integer
Dim NetSubKey As String, mChr As String
Dim mlistitem As ListItem

mresult = RegOpenKeyEx(inMainKey, inSubKey, 0&, KEY_ALL_ACCESS, mkey)
If mresult <> 0 Then
Exit Sub
End If

NetSubKey = ""
For i = Len(inSubKey) To 1 Step -1
mChr = Mid(inSubKey, i, 1)
If mChr = "\" Then
Exit For
End If
NetSubKey = mChr & NetSubKey
Next i
mIndex = 0
'Here is where you would add an if statment to only continue if
' NetSubKey is the file type (extension) that you want to find.
' ex: If lcase(NetSubKey) = ".jpg" then
' Do
' mEntryLength = 1024... etc
Do
mEntryLength = 1024
mDataByteLength = 1024
mEntry = Space$(mEntryLength)
mresult = RegEnumValue(mkey, mIndex, mEntry, mEntryLength, 0, _
mDataType, arrDataByte(1), mDataByteLength)
If mresult <> 0 Then ' No more
Exit Do
End If

mEntry = Left$(mEntry, mEntryLength)
' Note if value is "(No value set)" then the following
' will not be displayed, i.e. as if no entry exists.
If mEntry = "" And mDataByteLength > 0 Then ' (Default)
If mDataType = REG_SZ Then
mDataByteValue = ""
For i = 1 To mDataByteLength - 1
mDataByteValue = mDataByteValue & Chr$(arrDataByte(i))
Next i
If Trim(mDataByteValue) <> "" Then
Set mlistitem = lvwAsso.ListItems.Add(, , Text:=NetSubKey)
mlistitem.SubItems(1) = mDataByteValue
End If
End If
Exit Do
End If
mIndex = mIndex + 1
Loop
RegCloseKey mkey
End Sub

Private Sub ListEntryValues1(ByVal inMainKey As Long, ByVal inSubKey As String)
Dim mkey As Long
Dim mEntry As String
Dim mEntryLength As Long
Dim mDataType As Long
Dim arrDataByte(1 To 1024) As Byte
Dim mDataByteLength As Long
Dim mDataByteValue As String
Dim i As Integer
Dim mIndex As Integer

mresult = RegOpenKeyEx(inMainKey, inSubKey, 0&, KEY_ALL_ACCESS, mkey)
If mresult <> 0 Then
Exit Sub
End If

mIndex = 0
mEntryLength = 1024
mDataByteLength = 1024
mEntry = Space$(mEntryLength)
mresult = RegEnumValue(mkey, mIndex, mEntry, mEntryLength, 0, _
mDataType, arrDataByte(1), mDataByteLength)
If mresult <> 0 Then ' No more
Exit Sub
End If

mEntry = Left$(mEntry, mEntryLength)
' Note if value is "(No value set)" then the following
' will not be displayed, i.e. as if no entry exists.
If mEntry = "" And mDataByteLength > 0 Then ' (Default)
If mDataType = REG_SZ Then
mDataByteValue = ""
For i = 1 To mDataByteLength - 1
mDataByteValue = mDataByteValue & Chr$(arrDataByte(i))
Next i
If Trim(mDataByteValue) <> "" Then
lvwAsso.ListItems(mLVIndex).SubItems(2) = mDataByteValue
Else
lvwAsso.ListItems(mLVIndex).SubItems(2) = ""
End If
End If
End If
RegCloseKey mkey
End Sub

' Here we resize lvwAsso and picProgressContainer only
Private Sub Form_Resize()
Dim h As Single, w As Single
' Avoid runtime error
h = Me.ScaleHeight - lvwAsso.Top
If h < 150 Then
h = 150
End If
lvwAsso.Move 0, lvwAsso.Top, Me.ScaleWidth, h
w = (lvwAsso.ColumnHeaders(1).Width + lvwAsso.ColumnHeaders(2).Width + 200)
If Me.Width > w Then
lvwAsso.ColumnHeaders(3).Width = (Me.Width - w)
End If
End Sub

Private Sub cmdExit_Click()
Unload Me
End Sub

Private Sub cmdCancel_Click()
lvwAsso.Visible = True
End Sub

Private Function GetRegEntry(ByVal inMainKey As Long, ByVal inSubKey As String, ByVal inEntry As String) As String
Dim mkey As Long
Dim mBuffer As String * 255
Dim mBufSize As Long
mresult = RegOpenKeyEx(inMainKey, inSubKey, 0, KEY_READ, mkey)
If mresult = 0 Then
mBufSize = Len(mBuffer)
mresult = RegQueryValueEx(mkey, inEntry, 0, REG_SZ, mBuffer, mBufSize)
If mresult = 0 Then
If mBuffer <> "" Then
GetRegEntry = Mid$(mBuffer, 1, mBufSize)
End If
RegCloseKey mkey
Else ' Value may be simply not exist, not an error
GetRegEntry = ""
End If
Else
MsgBox "Unable to open " & inSubKey
GetRegEntry = ""
End If
End Function

'**************************************
' Name: Best Shell & Wait (No API's!)
' By: Matt Roberts
'
' Inputs:FileName - The name of the file
' you wish to run with any required switch
' es included.
'
' Returns:True if the file was run and
' returned.
'False If there was a file open or save error.
'EXAMPLE: ShellAndWait ("notepad.exe c:\temp\teset.txt)
'

Function ShellAndWait(FileName As String)
Dim objScript
Dim shellapp
On Error GoTo ERR_OpenForEdit
Set objScript = CreateObject("WScript.Shell")
shellapp = objScript.Run(FileName, 1, True)
ShellAndWait = True
EXIT_OpenForEdit:
Exit Function
ERR_OpenForEdit:
MsgBox Err.Number & Err.Description
GoTo EXIT_OpenForEdit
End Function
Private Sub lvwAsso_DblClick()
Text1(0).Text = lvwAsso.SelectedItem.Text
Text1(1).Text = lvwAsso.SelectedItem.SubItems(1)
Text1(2).Text = lvwAsso.SelectedItem.SubItems(2)
End Sub

sar1478

ASKER

Can you povide sample or example working application.

wileecoy

The above code is a working application.

Follow the instructions in my second previous comment, and copy and paste the code in my first previous comment, and you should have a form with all the code.

Let me know what kind of problems you are having. If it is bad enough, I could e-mail the code to you, I guess.

Wileecoy.

sar1478

ASKER

dear wileecoy

please mail me the working code.
my mail address is viv2575@hotmail.com

DanRollins

Hi sar1478,
It appears that you have forgotten this question. I will ask Community Support to close it unless you finalize it within 7 days. I will ask a Community Support Moderator to:

Accept wileecoy's comment(s) as an answer.

sar1478, if you think your question was not answered at all or if you need help, just post a new comment here; Community Support will help you. DO NOT accept this comment as an answer.

EXPERTS: If you disagree with that recommendation, please post an explanatory comment.
==========
DanRollins -- EE database cleanup volunteer

Netminder

Per recommendation, force-accepted.

Netminder
CS Moderator