IBindCtx RegisterObjectParam for string params not requiring an interface?

November 27, 2016, 12:45 am

≫ Next: VB6 existing text file usage

≪ Previous: [RESOLVED] Get value of next row select listview

$

0

0

So I've searched all over the place and can't find a single example of any of the dozens and dozens of STR_x bind context parameters being used that don't expect an interface.

Like STR_FILE_SYS_BIND_DATA expects the IUnknown parameter to point to a class implementing IFileSystemBindData. And that's no problem to do.

But many others, like STR_DONT_RESOLVE_LINK, don't have an associated interface to pass. So what am I supposed to pass for the IUnknown object? Tried passing Nothing, runtime error. Tried passing an uninitialized IUnknown variable, runtime error. Is there some other way to specify null, or do I need to just create a class implementing IUnknown? Would I actually have to do something in it, or just throw E_NOTIMPL for everything?

Unbelievable how there's not a single example of this to be found anywhere, yet tons for any string needing an interface.

Currently defined as

Code:

---

    HRESULT RegisterObjectParam(
        [in] LPWSTR pszKey,
        [in] stdole.IUnknown*punk);

---

Edit: Creating a dummy class that implements IUnknown seems to be a problem itself too. Looks like I'd have to create a new version without the void*

---

VB6 existing text file usage

November 27, 2016, 6:45 am

≫ Next: Save hBitmap to File Problem, how to SetBkColor?

≪ Previous: IBindCtx RegisterObjectParam for string params not requiring an interface?

$

0

0

I would like to take an large text file into a project and make it a resource file. Is there any way of doing this without manually taking the contents of the file and copying them into a empty res file?

Thanks

Jeff

Save hBitmap to File Problem, how to SetBkColor?

November 27, 2016, 7:40 am

≫ Next: file associated with my program?

≪ Previous: VB6 existing text file usage

$

0

0

I find picture produced by my code is all Black, unless I set a backColor in the word document.
I m confused, how to SetBkColor for my file...

I tried to use Device Context, because in VBA IDE there is no pictureBox control.
and also Device Context is a good thing for this one
Place in WordVBA Module

Code:

---

Private Declare Function GetDC Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function SetEnhMetaFileBits& Lib "gdi32.dll" (ByVal DataLen&, pData As Any)
Private Declare Function PlayEnhMetaFile& Lib "gdi32" (ByVal hdc&, ByVal hEMF&, pRect As Any)
Private Declare Function DeleteEnhMetaFile& Lib "gdi32.dll" (ByVal hEMF As Long)
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function FillRect Lib "user32.dll" (ByVal hdc As Long, ByRef lpRect As Any, ByVal hBrush As Long) As Long
Private Declare Function InvertRect Lib "user32.dll" (ByVal hdc As Long, ByRef lpRect As Any) As Long

Sub MyTest()
Dim aRECT(0 To 3) As Long
Dim hScrDC&
Dim hMemDC&
Dim hBitmap&, hBitTemp&
Dim oPage As Word.Page
Dim arr() As Byte, hEMF&
Set oPage = ThisDocument.Windows(1).Panes(1).Pages(1)
aRECT(2) = PointsToPixels(oPage.Width, False)
aRECT(3) = PointsToPixels(oPage.Height, True)
arr = oPage.EnhMetaFileBits

hEMF = SetEnhMetaFileBits(UBound(arr) + 1, arr(0))
hScreenDC = GetDC(0&)
hMemDC = CreateCompatibleDC(hScreenDC)
hBitmap = CreateCompatibleBitmap(hScreenDC, aRECT(2), aRECT(3))
hBitTemp = SelectObject(hMemDC, hBitmap)

InvertRect hMemDC, aRECT(0)  'Add This Line
                                                  'You can use FillRect too
If hEMF Then
    PlayEnhMetaFile hMemDC, hEMF, aRECT(0)
    DeleteEnhMetaFile hEMF
End If

hBitmap = SelectObject(hMemDC, hBitTemp)

MsgBox SavehBitmapToFile(hBitmap, "c:\1.png", Png, 100, 300)

DeleteObject hBitmap
DeleteDC hMemDC
DeleteDC hScreenDC
End Sub

---

And Place This code in WORD VBA, another module

Code:

---

'*************************************************************************
'**    作    者 ：    laviewpbt
'**    函 数 名 ：    SavehBitmapToFile
'**    输    入 ：    Stdpic(StdPicture)        -  图象句柄
'**            ：    FileName(String)      -  保存路径
'**            ：    FileFormat(ImageFileFormat)      -  保存格式，默认jpg
'**            ：    JpgQuality(Long)          -  JPG图象质量
'**            ：    Resolution(Single)  -  设置分辨率
'**    输    出 ：    无
'**    功能描述 ：    把图象保存为JPG、PNG、GIF、BMP格式
'**    修 改 人 ：  laviewpbt
'**    日    期 ：    2012-03-02 22:56
'**    版    本 ：    终结版
'*************************************************************************
Option Explicit

Private Const UnitPixel                  As Long = 2
Private Const EncoderQuality            As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"

Private Type GdiplusStartupInput
    GdiplusVersion          As Long
    DebugEventCallback      As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs  As Long
End Type

Private Enum EncoderParameterValueType
    EncoderParameterValueTypeByte = 1
    EncoderParameterValueTypeASCII = 2
    EncoderParameterValueTypeShort = 3
    EncoderParameterValueTypeLong = 4
    EncoderParameterValueTypeRational = 5
    EncoderParameterValueTypeLongRange = 6
    EncoderParameterValueTypeUndefined = 7
    EncoderParameterValueTypeRationalRange = 8
End Enum

Private Type EncoderParameter
    GUID(0 To 3)        As Long
    NumberOfValues      As Long
    Type                As EncoderParameterValueType
    Value              As Long
End Type

Private Type EncoderParameters
    Count              As Long
    Parameter          As EncoderParameter
End Type

Private Type ImageCodecInfo
    ClassID(0 To 3)    As Long
    FormatID(0 To 3)    As Long
    CodecName          As Long
    DllName            As Long
    FormatDescription  As Long
    FilenameExtension  As Long
    MimeType            As Long
    Flags              As Long
    Version            As Long
    SigCount            As Long
    SigSize            As Long
    SigPattern          As Long
    SigMask            As Long
End Type

Private Declare Function GdiplusStartup Lib "gdiplus" (Token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal Token As Long)
Private Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal hImage As Long, ByVal sFilename As Long, clsidEncoder As Any, encoderParams As Any) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As Long) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As Long, ByVal hPal As Long, BITMAP As Long) As Long
Private Declare Function GdipGetImageEncodersSize Lib "gdiplus" (numEncoders As Long, Size As Long) As Long
Private Declare Function GdipGetImageEncoders Lib "gdiplus" (ByVal numEncoders As Long, ByVal Size As Long, Encoders As Any) As Long

Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function lstrlenW Lib "KERNEL32" (ByVal psString As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpszProgID As Long, pCLSID As Any) As Long
Private Declare Function GdipBitmapSetResolution Lib "gdiplus" (ByVal BITMAP As Long, ByVal xdpi As Single, ByVal ydpi As Single) As Long


Public Enum ImageFileFormat
    bmp = 1
    Jpg = 2
    Png = 3
    Gif = 4
End Enum

Public Function SavehBitmapToFile(hBitmap As Long, ByVal FileName As String, _
                              Optional ByVal FileFormat As ImageFileFormat = Jpg, _
                              Optional ByVal JpgQuality As Long = 80, _
                              Optional Resolution As Single) As Boolean
    Dim clsid(3)        As Long
    Dim BITMAP          As Long
    Dim Token          As Long
    Dim Gsp            As GdiplusStartupInput

    Gsp.GdiplusVersion = 1                      'GDI+ 1.0版本
    GdiplusStartup Token, Gsp                  '初始化GDI+
    GdipCreateBitmapFromHBITMAP hBitmap, 0, BITMAP
    If BITMAP <> 0 Then                          '说明我们成功的将StdPic对象转换为GDI+的Bitmap对象了
        GdipBitmapSetResolution BITMAP, Resolution, Resolution
        Select Case FileFormat
        Case ImageFileFormat.bmp
            If Not GetEncoderClsid("Image/bmp", clsid) = -1 Then
                SavehBitmapToFile = (GdipSaveImageToFile(BITMAP, StrPtr(FileName), clsid(0), ByVal 0) = 0)
            End If
        Case ImageFileFormat.Jpg                    'JPG格式可以设置保存的质量
            Dim aEncParams()        As Byte
            Dim uEncParams          As EncoderParameters
            If GetEncoderClsid("Image/jpeg", clsid) <> -1 Then
                uEncParams.Count = 1                                        ' 设置自定义的编码参数，这里为1个参数
                If JpgQuality < 0 Then
                    JpgQuality = 0
                ElseIf JpgQuality > 100 Then
                    JpgQuality = 100
                End If
                ReDim aEncParams(1 To Len(uEncParams))
                With uEncParams.Parameter
                    .NumberOfValues = 1
                    .Type = EncoderParameterValueTypeLong                  ' 设置参数值的数据类型为长整型
                    Call CLSIDFromString(StrPtr(EncoderQuality), .GUID(0))  ' 设置参数唯一标志的GUID，这里为编码品质
                    .Value = VarPtr(JpgQuality)                                ' 设置参数的值：品质等级，最高为100，图像文件大小与品质成正比
                End With
                CopyMemory aEncParams(1), uEncParams, Len(uEncParams)
                SavehBitmapToFile = (GdipSaveImageToFile(BITMAP, StrPtr(FileName), clsid(0), aEncParams(1)) = 0)
            End If
        Case ImageFileFormat.Png
            If Not GetEncoderClsid("Image/png", clsid) = -1 Then
                SavehBitmapToFile = (GdipSaveImageToFile(BITMAP, StrPtr(FileName), clsid(0), ByVal 0) = 0)
            End If
        Case ImageFileFormat.Gif
            If Not GetEncoderClsid("Image/gif", clsid) = -1 Then                '如果原始的图像是24位，则这个函数会调用系统的调色板来将图像转换为8位，转换的效果会不尽人意,但也有可能系统不自动转换，保存失败
                SavehBitmapToFile = (GdipSaveImageToFile(BITMAP, StrPtr(FileName), clsid(0), ByVal 0) = 0)
            End If
        End Select
    End If
    GdipDisposeImage BITMAP      '注意释放资源
    GdiplusShutdown Token      '关闭GDI+。
End Function


Private Function GetEncoderClsid(strMimeType As String, ClassID() As Long) As Long
    Dim num        As Long
    Dim Size        As Long
    Dim i          As Long
    Dim Info()      As ImageCodecInfo
    Dim Buffer()    As Byte
    GetEncoderClsid = -1
    GdipGetImageEncodersSize num, Size              '得到解码器数组的大小
    If Size <> 0 Then
      ReDim Info(1 To num) As ImageCodecInfo      '给数组动态分配内存
      ReDim Buffer(1 To Size) As Byte
      GdipGetImageEncoders num, Size, Buffer(1)            '得到数组和字符数据
      CopyMemory Info(1), Buffer(1), (Len(Info(1)) * num)    '复制类头
      For i = 1 To num            '循环检测所有解码
          If (StrComp(PtrToStrW(Info(i).MimeType), strMimeType, vbTextCompare) = 0) Then        '必须把指针转换成可用的字符
              CopyMemory ClassID(0), Info(i).ClassID(0), 16  '保存类的ID
              GetEncoderClsid = i      '返回成功的索引值
              Exit For
          End If
      Next
    End If
End Function

Private Function PtrToStrW(ByVal lpsz As Long) As String
    Dim Out        As String
    Dim Length      As Long
    Length = lstrlenW(lpsz)
    If Length > 0 Then
        Out = StrConv(String$(Length, vbNullChar), vbUnicode)
        CopyMemory ByVal Out, ByVal lpsz, Length * 2
        PtrToStrW = StrConv(Out, vbFromUnicode)
    End If
End Function

---

file associated with my program?

November 27, 2016, 2:48 pm

≫ Next: Correct way to connect to sql server database [all version]

≪ Previous: Save hBitmap to File Problem, how to SetBkColor?

$

0

0

If i double click on a .txt file, it opens in NotePad by default. Now, i know i can change that default program to Whatever else.

My vb6 app saves and opens files with an extension, lets just say .abc. I'd like the user, after installing my app, to be able to double-click on an .abc file and open in my program.

So, how can my program instruct the users Windows OS to open any .abc file in my program?

Correct way to connect to sql server database [all version]

November 27, 2016, 6:59 pm

≫ Next: [RESOLVED] VB6 existing text file usage

≪ Previous: file associated with my program?

$

0

0

Hi, i just want to know how is the correct way to connect to sql server database in vb6 ?

i read the best way is to use adodb connection but i little bit confused with connection string because some article/thread say sql oledb is the best connection string to use to connect to database but others say sql oledb is old.
so i try some connection string and found that oledb can connect to almost sql server version from 2008, 2012 , and sql server 2014

for example this standard sql server connection can't use to conenct to sql server 2014

Code:

---

Server=myServerAddress;Database=myDataBase;User Id=myUsername;
Password=myPassword;

or

Provider=SQLNCLI11;Server=myServerAddress;Database=myDataBase;Uid=myUsername;
Pwd=myPassword;

---

this is will cause a problem when a company upgrading their sql server version they need to re-compile their vb application to connect to new sql server version.
so do you think sql oledb is the best because it can connect to almost sql server version so we don't need to re-compile our application when sql server is upgrade or downgrade ?

---
background story:
fyi currently my company use RDO connection not adodb and it can connect to almost sql server version. We have upgraded our database from 2008 to 2012 and then to 2014 now. besides that we have other database server to test environtment to performing some test before publishing and use main databse server (dbserver). sometimes we need to point our application to different databse version and RDO connection can handle it but since i read some thread here that say RDO is old i want to try to use adodb but i need adodb can connect to whatever is sql database version.
Which connection string should i use?

[RESOLVED] VB6 existing text file usage

November 27, 2016, 6:45 am

≫ Next: Running Run("cmd.exe") commands from VB

≪ Previous: Correct way to connect to sql server database [all version]

$

0

0

I would like to take an large text file into a project and make it a resource file. Is there any way of doing this without manually taking the contents of the file and copying them into a empty res file?

Thanks

Jeff

Running Run("cmd.exe") commands from VB

November 28, 2016, 3:28 am

≫ Next: Maintain Aspect Ratio Of Nested Shape Controls When Resized

≪ Previous: [RESOLVED] VB6 existing text file usage

$

0

0

Hi everyone,

I've been trying to invoke commands that I normally would with the Windows run.exe but from VB.
And what got me into this is because there are some commands that connat be executed using shell.
for example, using batch sometimes I use: Call & Star to execute something.
meanwhile in VB I have to turn "Call" or "Start" into Shell as I cannot use them.

Dim command As String
'command = "C:\Coding> echo Main-Class: Coding >manifest.txt"
Shell "cmd.exe /c Command here"

I will appreciate any help.
Thanks

Maintain Aspect Ratio Of Nested Shape Controls When Resized

November 28, 2016, 8:13 am

≫ Next: Understanding a Strange VB6 Behavior Involving Re-Called Events

≪ Previous: Running Run("cmd.exe") commands from VB

$

0

0

This is what happens when old farts get rusty from inactivity with VB. Either that or my brain is failing to perform simple logic!

Anyway, I have 3 Shape Controls on a UserControl. Shape2 & Shape3 are nested within Shape1. Shape3 being the inner most Shape. Shape1 is resized with no problem as it resizes in the UserControl.Resize event.

Code:

---

Private Sub UserControl_Resize()
    Shape1.Height = UserControl.ScaleHeight
    Shape1.Width = UserControl.ScaleWidth
End Sub

---

When resizing on Form1 I want Shape2 & Shape3 to maintain their aspect ratio to Shape1 but no matter what formulas or code structure I concoct I can't seem to nail it down. I Know I'm missing something basic here but it eludes me.

I've searched the forum but my search terms haven't hit exactly what I'm looking for.

Any help would be appreciated.

Thanks,
Chris

---

Understanding a Strange VB6 Behavior Involving Re-Called Events

November 28, 2016, 9:18 am

≫ Next: finding the max from data imported from CSV file

≪ Previous: Maintain Aspect Ratio Of Nested Shape Controls When Resized

$

0

0

I have a fairly complex program I maintain in VB6, and today I encountered a bug in which an event of one of my objects was getting called over and over.

I think it's actually a small bug in VB6, but I'm not sure so I'm hoping some of the smarter minds around here can lend some insight. I've found a work around for the issue, so its all academic but its still kind of interesting.

I've attached a small project which is the simplest version of the code which causes the issue. The basic structure is this:

The main form has a class which it calls to generate an event (clsEventSource), and has a WithEvents instance of this called objSrc.

The main form is listening for this event, but it's not listening directly, it's listening via a rebroadcaster (clsEventGenerator) named objGen.

objSrc is told to initially generate events via objGen. In the more complex production code, which objSrc has control and is generating events can change wildly during execution, and there can be many of them, so each objSrc an request the ability say they will now be generating events via an interface called clsIEventSetter. The main form implements this event, so it knows which objGen to listen to. Which objGen it listens to can change as well. Its greatly simplified in this example.

Basically, it comes down to this: If objGen is changed at all while somewhere in the call stack the call originated from objGen, when we return to that point in the call stack, the event will fire a second time, with the same parameters, even if the actual object is the same object.

You can see this because in the EventsFromMe function there is a line that if you uncomment, it all works fine. That line just checks to see if they are they same object, which they are, and if so, doesn't set it.

It looks like VB6 is trying to be diligent about events handlers changing while an event on that handler is running by re-running the event, but it doesn't seem to determine if the objects in question are actually any different, it only marks if they have changed.

Anyone have any insight into this behavior or can explain whats going on a bit better?

This is all for curiosity's sake but I still find it interesting.

Attached Files

• Image may be NSFW.
  Clik here to view. Event Sample.zip (2.8 KB)

finding the max from data imported from CSV file

November 28, 2016, 3:08 pm

≫ Next: [RESOLVED] Save hBitmap to File Problem, how to SetBkColor?

≪ Previous: Understanding a Strange VB6 Behavior Involving Re-Called Events

$

0

0

Hello,

I have to write a program that requires me to import three exam scores from a csv file and then calculate their average - I have done this.

But I also have to find out which, of 20 pupils have the highest average exam score.

How do I go about finding the highest percentage?

The percentage so far is calculated from 3 scores imported from a csv file and then displayed in a text box - for example "jack got 40%"

[RESOLVED] Save hBitmap to File Problem, how to SetBkColor?

November 27, 2016, 7:40 am

≫ Next: Program shutdown hack, opinions?

≪ Previous: finding the max from data imported from CSV file

$

0

0

I find picture produced by my code is all Black, unless I set a backColor in the word document.
I m confused, how to SetBkColor for my file...

I tried to use Device Context, because in VBA IDE there is no pictureBox control.
and also Device Context is a good thing for this one
Place in WordVBA Module

Code:

---

Private Declare Function GetDC Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function SetEnhMetaFileBits& Lib "gdi32.dll" (ByVal DataLen&, pData As Any)
Private Declare Function PlayEnhMetaFile& Lib "gdi32" (ByVal hdc&, ByVal hEMF&, pRect As Any)
Private Declare Function DeleteEnhMetaFile& Lib "gdi32.dll" (ByVal hEMF As Long)
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function FillRect Lib "user32.dll" (ByVal hdc As Long, ByRef lpRect As Any, ByVal hBrush As Long) As Long
Private Declare Function InvertRect Lib "user32.dll" (ByVal hdc As Long, ByRef lpRect As Any) As Long

Sub MyTest()
Dim aRECT(0 To 3) As Long
Dim hScrDC&
Dim hMemDC&
Dim hBitmap&, hBitTemp&
Dim oPage As Word.Page
Dim arr() As Byte, hEMF&
Set oPage = ThisDocument.Windows(1).Panes(1).Pages(1)
aRECT(2) = PointsToPixels(oPage.Width, False)
aRECT(3) = PointsToPixels(oPage.Height, True)
arr = oPage.EnhMetaFileBits

hEMF = SetEnhMetaFileBits(UBound(arr) + 1, arr(0))
hScreenDC = GetDC(0&)
hMemDC = CreateCompatibleDC(hScreenDC)
hBitmap = CreateCompatibleBitmap(hScreenDC, aRECT(2), aRECT(3))
hBitTemp = SelectObject(hMemDC, hBitmap)

InvertRect hMemDC, aRECT(0)  'Add This Line
                                                  'You can use FillRect too
If hEMF Then
    PlayEnhMetaFile hMemDC, hEMF, aRECT(0)
    DeleteEnhMetaFile hEMF
End If

hBitmap = SelectObject(hMemDC, hBitTemp)

MsgBox SavehBitmapToFile(hBitmap, "c:\1.png", Png, 100, 300)

DeleteObject hBitmap
DeleteDC hMemDC
DeleteDC hScreenDC
End Sub

---

And Place This code in WORD VBA, another module

Code:

---

'*************************************************************************
'**    作    者 ：    laviewpbt
'**    函 数 名 ：    SavehBitmapToFile
'**    输    入 ：    Stdpic(StdPicture)        -  图象句柄
'**            ：    FileName(String)      -  保存路径
'**            ：    FileFormat(ImageFileFormat)      -  保存格式，默认jpg
'**            ：    JpgQuality(Long)          -  JPG图象质量
'**            ：    Resolution(Single)  -  设置分辨率
'**    输    出 ：    无
'**    功能描述 ：    把图象保存为JPG、PNG、GIF、BMP格式
'**    修 改 人 ：  laviewpbt
'**    日    期 ：    2012-03-02 22:56
'**    版    本 ：    终结版
'*************************************************************************
Option Explicit

Private Const UnitPixel                  As Long = 2
Private Const EncoderQuality            As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"

Private Type GdiplusStartupInput
    GdiplusVersion          As Long
    DebugEventCallback      As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs  As Long
End Type

Private Enum EncoderParameterValueType
    EncoderParameterValueTypeByte = 1
    EncoderParameterValueTypeASCII = 2
    EncoderParameterValueTypeShort = 3
    EncoderParameterValueTypeLong = 4
    EncoderParameterValueTypeRational = 5
    EncoderParameterValueTypeLongRange = 6
    EncoderParameterValueTypeUndefined = 7
    EncoderParameterValueTypeRationalRange = 8
End Enum

Private Type EncoderParameter
    GUID(0 To 3)        As Long
    NumberOfValues      As Long
    Type                As EncoderParameterValueType
    Value              As Long
End Type

Private Type EncoderParameters
    Count              As Long
    Parameter          As EncoderParameter
End Type

Private Type ImageCodecInfo
    ClassID(0 To 3)    As Long
    FormatID(0 To 3)    As Long
    CodecName          As Long
    DllName            As Long
    FormatDescription  As Long
    FilenameExtension  As Long
    MimeType            As Long
    Flags              As Long
    Version            As Long
    SigCount            As Long
    SigSize            As Long
    SigPattern          As Long
    SigMask            As Long
End Type

Private Declare Function GdiplusStartup Lib "gdiplus" (Token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal Token As Long)
Private Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal hImage As Long, ByVal sFilename As Long, clsidEncoder As Any, encoderParams As Any) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As Long) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As Long, ByVal hPal As Long, BITMAP As Long) As Long
Private Declare Function GdipGetImageEncodersSize Lib "gdiplus" (numEncoders As Long, Size As Long) As Long
Private Declare Function GdipGetImageEncoders Lib "gdiplus" (ByVal numEncoders As Long, ByVal Size As Long, Encoders As Any) As Long

Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function lstrlenW Lib "KERNEL32" (ByVal psString As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpszProgID As Long, pCLSID As Any) As Long
Private Declare Function GdipBitmapSetResolution Lib "gdiplus" (ByVal BITMAP As Long, ByVal xdpi As Single, ByVal ydpi As Single) As Long


Public Enum ImageFileFormat
    bmp = 1
    Jpg = 2
    Png = 3
    Gif = 4
End Enum

Public Function SavehBitmapToFile(hBitmap As Long, ByVal FileName As String, _
                              Optional ByVal FileFormat As ImageFileFormat = Jpg, _
                              Optional ByVal JpgQuality As Long = 80, _
                              Optional Resolution As Single) As Boolean
    Dim clsid(3)        As Long
    Dim BITMAP          As Long
    Dim Token          As Long
    Dim Gsp            As GdiplusStartupInput

    Gsp.GdiplusVersion = 1                      'GDI+ 1.0版本
    GdiplusStartup Token, Gsp                  '初始化GDI+
    GdipCreateBitmapFromHBITMAP hBitmap, 0, BITMAP
    If BITMAP <> 0 Then                          '说明我们成功的将StdPic对象转换为GDI+的Bitmap对象了
        GdipBitmapSetResolution BITMAP, Resolution, Resolution
        Select Case FileFormat
        Case ImageFileFormat.bmp
            If Not GetEncoderClsid("Image/bmp", clsid) = -1 Then
                SavehBitmapToFile = (GdipSaveImageToFile(BITMAP, StrPtr(FileName), clsid(0), ByVal 0) = 0)
            End If
        Case ImageFileFormat.Jpg                    'JPG格式可以设置保存的质量
            Dim aEncParams()        As Byte
            Dim uEncParams          As EncoderParameters
            If GetEncoderClsid("Image/jpeg", clsid) <> -1 Then
                uEncParams.Count = 1                                        ' 设置自定义的编码参数，这里为1个参数
                If JpgQuality < 0 Then
                    JpgQuality = 0
                ElseIf JpgQuality > 100 Then
                    JpgQuality = 100
                End If
                ReDim aEncParams(1 To Len(uEncParams))
                With uEncParams.Parameter
                    .NumberOfValues = 1
                    .Type = EncoderParameterValueTypeLong                  ' 设置参数值的数据类型为长整型
                    Call CLSIDFromString(StrPtr(EncoderQuality), .GUID(0))  ' 设置参数唯一标志的GUID，这里为编码品质
                    .Value = VarPtr(JpgQuality)                                ' 设置参数的值：品质等级，最高为100，图像文件大小与品质成正比
                End With
                CopyMemory aEncParams(1), uEncParams, Len(uEncParams)
                SavehBitmapToFile = (GdipSaveImageToFile(BITMAP, StrPtr(FileName), clsid(0), aEncParams(1)) = 0)
            End If
        Case ImageFileFormat.Png
            If Not GetEncoderClsid("Image/png", clsid) = -1 Then
                SavehBitmapToFile = (GdipSaveImageToFile(BITMAP, StrPtr(FileName), clsid(0), ByVal 0) = 0)
            End If
        Case ImageFileFormat.Gif
            If Not GetEncoderClsid("Image/gif", clsid) = -1 Then                '如果原始的图像是24位，则这个函数会调用系统的调色板来将图像转换为8位，转换的效果会不尽人意,但也有可能系统不自动转换，保存失败
                SavehBitmapToFile = (GdipSaveImageToFile(BITMAP, StrPtr(FileName), clsid(0), ByVal 0) = 0)
            End If
        End Select
    End If
    GdipDisposeImage BITMAP      '注意释放资源
    GdiplusShutdown Token      '关闭GDI+。
End Function


Private Function GetEncoderClsid(strMimeType As String, ClassID() As Long) As Long
    Dim num        As Long
    Dim Size        As Long
    Dim i          As Long
    Dim Info()      As ImageCodecInfo
    Dim Buffer()    As Byte
    GetEncoderClsid = -1
    GdipGetImageEncodersSize num, Size              '得到解码器数组的大小
    If Size <> 0 Then
      ReDim Info(1 To num) As ImageCodecInfo      '给数组动态分配内存
      ReDim Buffer(1 To Size) As Byte
      GdipGetImageEncoders num, Size, Buffer(1)            '得到数组和字符数据
      CopyMemory Info(1), Buffer(1), (Len(Info(1)) * num)    '复制类头
      For i = 1 To num            '循环检测所有解码
          If (StrComp(PtrToStrW(Info(i).MimeType), strMimeType, vbTextCompare) = 0) Then        '必须把指针转换成可用的字符
              CopyMemory ClassID(0), Info(i).ClassID(0), 16  '保存类的ID
              GetEncoderClsid = i      '返回成功的索引值
              Exit For
          End If
      Next
    End If
End Function

Private Function PtrToStrW(ByVal lpsz As Long) As String
    Dim Out        As String
    Dim Length      As Long
    Length = lstrlenW(lpsz)
    If Length > 0 Then
        Out = StrConv(String$(Length, vbNullChar), vbUnicode)
        CopyMemory ByVal Out, ByVal lpsz, Length * 2
        PtrToStrW = StrConv(Out, vbFromUnicode)
    End If
End Function

---

Program shutdown hack, opinions?

November 29, 2016, 2:43 am

≫ Next: [RESOLVED] find in string?

≪ Previous: [RESOLVED] Save hBitmap to File Problem, how to SetBkColor?

$

0

0

Hi all,

I have a program which uses an ActiveX-DLL.
This DLL parses large text files and creates large counts of class instances while doing that.
The result is a single string after parsing was done.
Destroying the class instances is very slow.

This large count of class instances is a known problem in VB6, similar to this:

http://www.vbforums.com/showthread.p...ry-slow-in-VB6

I tuned up the performance of the ActiveX-DLL a lot, I could do more but not yet.
I know I should rewrite the ActiveX-DLL in order to use arrays of UDTs instead of collection of class instances.
Doing this is a large, complicated and time consuming task I can't manage these days.

When the main program ends, the 'destroying class instances problem' kicks in again.
The main program is not visible but resides in the task manager until the memory is freed.
This can take several minutes.
Not very wanted...

I want to avoid this.
As the very last line in the program I now have

Code:

---

Shell ("TASKKILL /F /IM MAINPROG.EXE")

---

Works.

This is the opposite of elegant, I know.
But up to now I can't see any negative effects.
This kill is also not seen in the event viewer.

What do you think of this strange approach?

Karl

[RESOLVED] find in string?

November 29, 2016, 2:17 pm

≫ Next: [RESOLVED] What differences are known between IDE and compiled behaviour

≪ Previous: Program shutdown hack, opinions?

$

0

0

Lets say the user enters a phrase in a textbox and used parenthesis like this;

The quick fox (a mammal) jumped over the box.

Now, i want my program to find what the user has in the parenthesis.

It should be fairly simple, find the parenthesis, then record whatever is in them?

But, im stumped............

[RESOLVED] What differences are known between IDE and compiled behaviour

November 30, 2016, 1:01 am

≫ Next: Arrays and click events

≪ Previous: [RESOLVED] find in string?

$

0

0

I have a program which runs perfectly in the IDE but not when compiled. I am therefore asking for any known differences in behaviour.

I know about making a window “on top” works in form load when compiled but not in IDE and I have read this thread… http://www.vbforums.com/showthread.p...-vs-EXE-errors

Neither of these help. Is anything else known?

THE PROBLEM
The program is monitor aware and allows users to choose a different scale for each monitor. The scales they choose are kept in one file. The last window size and position are kept in another. On start up the window is drawn at the position, size and scale last used.

In the IDE, the window always appears at the correct position size and scale but when compiled, only the position and scale are always correct, the window height is less than it should be whenever the scale is greater that 125%.

Arrays and click events

November 30, 2016, 10:26 am

≫ Next: Odd form control behavior....

≪ Previous: [RESOLVED] What differences are known between IDE and compiled behaviour

$

0

0

I think i was asking about this one other time, but never figured it out. But, here goes.....

I have an array of Image controls. Lets say Image1(0), and Image1(1)

I want to set click events for each.

Code:

---

Private Sub Image1(0)_Click(Index As Integer)
and
Private Sub Image1(1)_Click(Index As Integer

---

This doesnt seem to work?

---

Odd form control behavior....

November 30, 2016, 2:28 pm

≫ Next: LongLong

≪ Previous: Arrays and click events

$

0

0

Hi All,

A user of one of my software products is reporting some odd behavior on some form controls. Specifically, the text associated with the Checkbox control and the Command Btn is too large. The user has a screen resolution that is identical to my development machine (1920 x 1080), and his text size is set to 'smaller', as is my system. I'm on a Windows 7 32 bit system, while the user is on a Windows 7 Enterprise 64 bit system.

An example of the issue is below:

Image may be NSFW.
Clik here to view.

This form looks perfect on my machine:

Image may be NSFW.
Clik here to view.

Any hints on what the issue might be?

Thanks,

John

Attached Images

Image may be NSFW.
Clik here to view. Image may be NSFW.
Clik here to view. 

LongLong

November 30, 2016, 6:20 pm

≫ Next: [RESOLVED] Program shutdown hack, opinions?

≪ Previous: Odd form control behavior....

$

0

0

Hi All,

I was inspired by a post by hwoarang over in the codebank to write a class (and a supporting bas) that I might actually use.

It's a class that provides the VBA LongLong type to VB6. Now, before everyone jumps on it, it's not "native" 8-byte integers, but it gets it all done as if it were. I'm sure it's slower than native 8-byte integers would be.

However, the only initial difference I can see from what I'm doing and what VBA does, is that I require the use of the "New" keyword when declaring variables. Here's some test code in a form:

Code:

---


Option Explicit


Private Sub Form_Load()
    Dim LL1 As New LongLong
    Dim LL2 As New LongLong
    Dim LL3 As New LongLong


    '
    ' Some simple tests.
    '
    LL1 = 5
    LL2 = LL1

    MsgBox LL1
    MsgBox LL2

    MsgBox LL1 + LL2
    MsgBox LL1 * LL2
    MsgBox LL1 / LL2
    MsgBox LL1 ^ LL2
    LL3 = LL1 ^ LL2
    MsgBox LL3



    '
    ' Some more rigorous tests.
    '
    LL1 = CLngLng("9223372036854775807") ' Largest LongLong value in VBA.
    MsgBox LL1
    'LL1 = LL1 + 1  ' This will be an overflow.

    LL1 = CLngLng("-9223372036854775807") ' (Almost) smallest LongLong value in VBA.
    MsgBox LL1
    LL1 = LL1 - 1  ' This not overflow.
    MsgBox LL1
    'LL1 = LL1 - 1  ' This will be an overflow.

    Dim d As Double
    d = 9.22337203685477E+18
    LL1 = d
    MsgBox LL1
    'LL1 = LL1 * 2 ' This will overflow.

End Sub


---

As you can see, the usage is VERY close to the way you'd use VBA LongLongs.

I've attached a sample project which includes the Class that gets it done, along with a supporting BAS module. In the BAS module, there's a CLngLng function that'll convert about anything to a Decimal (with overflow checks at LongLong ranges). This can be directly placed into a LongLong declared variable (as those are actually handed back as Decimals also so that math natively works).

I'm open to whatever critiques/bugs people would like to make/report about any of this. Maybe after I've polished it some more, I'll post it in the codebank.

Regards,
Elroy

Attached Files

• Image may be NSFW.
  Clik here to view. LongLong.zip (4.9 KB)

[RESOLVED] Program shutdown hack, opinions?

November 29, 2016, 2:43 am

≫ Next: [RESOLVED] Arrays and click events

≪ Previous: LongLong

$

0

0

Hi all,

I have a program which uses an ActiveX-DLL.
This DLL parses large text files and creates large counts of class instances while doing that.
The result is a single string after parsing was done.
Destroying the class instances is very slow.

This large count of class instances is a known problem in VB6, similar to this:

http://www.vbforums.com/showthread.p...ry-slow-in-VB6

I tuned up the performance of the ActiveX-DLL a lot, I could do more but not yet.
I know I should rewrite the ActiveX-DLL in order to use arrays of UDTs instead of collection of class instances.
Doing this is a large, complicated and time consuming task I can't manage these days.

When the main program ends, the 'destroying class instances problem' kicks in again.
The main program is not visible but resides in the task manager until the memory is freed.
This can take several minutes.
Not very wanted...

I want to avoid this.
As the very last line in the program I now have

Code:

---

Shell ("TASKKILL /F /IM MAINPROG.EXE")

---

Works.

This is the opposite of elegant, I know.
But up to now I can't see any negative effects.
This kill is also not seen in the event viewer.

What do you think of this strange approach?

Karl

[RESOLVED] Arrays and click events

November 30, 2016, 10:26 am

≫ Next: How to use Cairo classes to draw on an Excel userform?

≪ Previous: [RESOLVED] Program shutdown hack, opinions?

$

0

0

I think i was asking about this one other time, but never figured it out. But, here goes.....

I have an array of Image controls. Lets say Image1(0), and Image1(1)

I want to set click events for each.

Code:

---

Private Sub Image1(0)_Click(Index As Integer)
and
Private Sub Image1(1)_Click(Index As Integer

---

This doesnt seem to work?

How to use Cairo classes to draw on an Excel userform?

December 1, 2016, 2:05 am

≫ Next: [RESOLVED] LINK : fatal error LNK1158: cannot run "cvtres.exe"

≪ Previous: [RESOLVED] Arrays and click events

$

0

0

In VB6, I can do this:

vb Code:

Srf.DrawToDC TheForm.hDC

In VBA, there is no property hDC.