Solved

Add-in for Excel

Posted on 2001-06-26
14
748 Views
Last Modified: 2010-05-18
Hi,
I would like to create an add-in button for excel that has the following functionality:
- When I click on it it execute some VB Code that writes values in some cells
Have you got an example?
Michele
0
Comment
Question by:css
  • 8
  • 2
  • 2
  • +2
14 Comments
 
LVL 4

Expert Comment

by:WolfgangKoenig
ID: 6226960
1) First you must put this code in the table1 code section.

2) Second activate table1 through clicking table2 and then again table 1 -> the button appears and when clicking it values are written in the table

Private Sub CommandButton1_Click()
    Range("D4").Select
    ActiveCell.FormulaR1C1 = "The"
    Range("D6").Select
    ActiveCell.FormulaR1C1 = "result"
    Range("D8").Select
    ActiveCell.FormulaR1C1 = "is:"
    Range("D10").Select
    ActiveCell.FormulaR1C1 = "10000"
End Sub

Private Sub Worksheet_Activate()
    ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", Link:=False _
        , DisplayAsIcon:=False, Left:=60, Top:=25.5, Width:=60.75, Height:= _
        26.25).Select
    Selection.ShapeRange.ScaleWidth 1.31, msoFalse, msoScaleFromTopLeft
    ActiveSheet.OLEObjects("CommandButton1").Object.Caption = "Press me"
End Sub
0
 

Author Comment

by:css
ID: 6226985
I would like to have a new button on toolbar (add-in) ... this seems to add a button on the table ...
0
 
LVL 4

Accepted Solution

by:
WolfgangKoenig earned 100 total points
ID: 6227359
This is code for the module1 code section:

Sub Macro1()
    Application.CommandBars.Add(Name:="MyOwnToolbar").Visible = True
    Application.CommandBars("MyOwnToolbar").Controls.Add Type:=msoControlButton, _
        Id:=2950, Before:=1
    Application.CommandBars("MyOwnToolbar").Controls.Item(1).OnAction = "FillCells"
End Sub

Sub FillCells()
With ActiveWorkbook.Sheets(1)
   Range("D4").Select
   ActiveCell.FormulaR1C1 = "The"
   Range("D6").Select
   ActiveCell.FormulaR1C1 = "result"
   Range("D8").Select
   ActiveCell.FormulaR1C1 = "is:"
   Range("D10").Select
   ActiveCell.FormulaR1C1 = "10000"
End With
End Sub

When done this you must call the macro:
Macro1()
0
 
LVL 1

Expert Comment

by:kodiakbear
ID: 6229542
WolfgangKoenig,
I am not rejecting this proposed answer because you are the only expert helping on this question at this time.
Please look at my comments on the I did reject your proposed answer on.

EE is a great place for experts to work with each other to solve a problem. Notice I did say with each other.
Locking a question takes the question out of the area where other experts look to see if they can help.

Again welcome to Experts Exchange and look forward to seeing you helping here.

kb
Community Support Moderator
Experts Exchange
0
 

Author Comment

by:css
ID: 6230377
Sorry but to accept an answer I have to test the solution and at the moment I've not time ... I will ASAP
0
 

Expert Comment

by:costello
ID: 6400369
css,

I will give you 4 days to test the comment, if no feedback is given from you before that date, I will force accept Wolfgang's comment.

costello
Community Support Moderator @ Experts-Exchange
0
 
LVL 1

Expert Comment

by:swdld
ID: 6451520
Hi css,
the following I post code of 6 bas modules. These modules Adobe uses to add a "PDFWriter.xla" in almost every Version of Microsoft Excel (desired icon bar inclusive).
- Copy the code between "--- begin of code ---" and "--- end of code ---" to textfiles, named like indicated in the first line of code.
- Open Excel.
- Press "ALT" + "F11" (to open VBA Editor).
- Load the created 6 files to the currently opened Excel file
- Switch to Excel (from VBA editor" and save file as "PDFWriter.xla".
- Close Excel
- Open Excel and have the new icon bar with functionalyty.
- Change the code for your needs (Step through starting with "Auto_Open()" from "Autoexec.bas"

c.u.,
swdld
0
Top 6 Sources for Identifying Threat Actor TTPs

Understanding your enemy is essential. These six sources will help you identify the most popular threat actor tactics, techniques, and procedures (TTPs).

 
LVL 1

Expert Comment

by:swdld
ID: 6451522
'--- begin of code ---
'Filename: AutoExec.bas
Attribute VB_Name = "AutoExec"
Option Explicit
#Const ExcelCompile = True

Public bWin95 As Boolean
Public bWinNT As Boolean
Public bWinNT351 As Boolean
Public bWinNT40 As Boolean
Public nOSMajorVersion As Integer
Public nOSMinorVersion As Integer

Public theDoc As Worksheet

Private bDistMonOk As Boolean
Private iniFilename As String

Private PDFWriterName As String
Private Port As String

Private Declare Function CopyIconToClipboard Lib "CopyIcon" () As Boolean

Private Declare Function SendMessage Lib "User32" Alias "SendMessageA" _
    (ByVal hWnd As Integer, _
    ByVal wMsg As Integer, ByVal wParam As Integer, _
    lParam As Any) As Long

Private Declare Function WriteProfileString Lib "kernel32" Alias "WriteProfileStringA" _
      (ByVal lpApplicationName As String, ByVal lpKeyName As String, _
      ByVal lpString As String) As Integer

Private Const WM_WININICHANGE = &H1A
Private Const HWND_BROADCAST = &HFFFF

Private Type POINT
    x As Long
    y As Long
End Type

Private Type msg
    hWnd As Integer
    message As Integer
    wParam As Integer
    lParam As Long
    time As Long
    pt As POINT
End Type

Private Declare Function PeekMessage Lib "User32" Alias "PeekMessageA" _
    (ByRef lpMsg As msg, ByVal hWnd As Integer, ByVal wMsgFilterMin As Integer, _
    ByVal wMsgFilterMax As Integer, ByVal wRemoveMsg As Integer) As Boolean
   
Private Const PM_REMOVE = &H1

Private Declare Function TranslateMessage Lib "User32" Alias "TranslateMessageA" _
    (ByRef lpMsg As msg) As Boolean

Private Declare Function DispatchMessage Lib "User32" Alias "DispatchMessageA" _
    (ByRef lpMsg As msg) As Long

Declare Function GetVersion Lib "kernel32" () As Long
Declare Function IsPDFWriterInstalled Lib "DistMon" (ByVal PDFWriterName As String, ByVal Port As String) As Long

Dim bExcel As Boolean
Dim SystemRoot$

Private IniPromptSetting As String

Private Function GetPrivateProfileSetting(Optional iniFilename As String, _
                    Optional BaseKey As Long, _
                    Optional Section As String, _
                    Optional Setting As String) As String
                   
    If IsMissing(iniFilename) Or Len(iniFilename) = 0 Then
        GetPrivateProfileSetting = QueryValue(BaseKey, Section, Setting)
    Else
        GetPrivateProfileSetting = GetIniSetting(iniFilename, Section, Setting)
    End If
   
End Function

Private Sub SetPrivateProfileSetting(Optional iniFilename As String, _
                    Optional BaseKey As Long, _
                    Optional Section As String, _
                    Optional Setting As String, _
                    Optional Value As String)
                   
    If IsMissing(iniFilename) Or Len(iniFilename) = 0 Then
        SetKeyValue BaseKey, Section, Setting, Value, 1
    Else
        SetIniSetting iniFilename, Section, Setting, Value
    End If
   
End Sub

Function EnsurePDFWriterIsInstalled(PDFWriterName As String, Port As String) As Boolean
    Dim found As Long
    Dim starPos As Long
   
    On Error Resume Next
   
    EnsurePDFWriterIsInstalled = False
    PDFWriterName = String(100, "*")
    Port = String(100, "*")
   
    If (Not bDistMonOk) Then
        MsgBox IDS_CANT_FIND_DISTMON, vbOKOnly, Title:=IDS_APP_NAME
    Else
        found = IsPDFWriterInstalled(PDFWriterName, Port)
        If (found = 1) Then
            EnsurePDFWriterIsInstalled = True
            starPos = InStr(1, PDFWriterName, "*")
            PDFWriterName = Left(PDFWriterName, starPos - 2)
            starPos = InStr(1, Port, "*")
            Port = Left(Port, starPos - 2)
        End If
    End If

    If (Not EnsurePDFWriterIsInstalled) Then
        MsgBox IDS_NO_PDFWRITER, vbOKOnly, Title:=IDS_APP_NAME
    End If
End Function
Sub TogglePDFToolbar()
    Dim Status As String
    Dim NewStatus As String
    Dim SaveStatus As String
   
    On Error GoTo ExitSub
   
    Status = GetPrivateProfileSetting(iniFilename, _
                0, _
                "Acrobat PDFWriter", _
                IniPromptSetting)
    If Status = "" Then Status = "Prompt"
   
    If Status = "Prompt" Then
        NewStatus = IDS_PDFWRITER_NO_PROMPT
        SaveStatus = "Auto"
    Else
        NewStatus = IDS_PDFWRITER_PROMPT
        SaveStatus = "Prompt"
    End If
    CommandBars(IDS_TOOLBAR_NAME).Controls.Item(2).Caption = NewStatus
   
    SetPrivateProfileSetting iniFilename, _
                0, _
                "Acrobat PDFWriter", _
                IniPromptSetting, _
                SaveStatus

ExitSub:
End Sub

Sub DetermineWhichApp()
    bExcel = True
End Sub
Public Sub PrintPDFFile()
    Dim Status As String
    Dim outputFilename As String
    Dim dotPos As Long
    Dim prevDotPos As Long
    Dim slashPos As Long
    Dim saveCurrentPrinter As String
   
    If (Application.Workbooks.Count = 0) Then
        Exit Sub
    End If
    DetermineWhichApp
    If Application.Sheets.Count = 0 Then Exit Sub

    Dim printCurrentPageOnly As Boolean
    printCurrentPageOnly = False
   
    If (bWinNT) Then
        SystemRoot$ = GetPrivateProfileSetting(BaseKey:=HKEY_LOCAL_MACHINE, _
                    Section:="Software\Microsoft\Windows NT\CurrentVersion", _
                    Setting:="SystemRoot")
        iniFilename = SystemRoot$ + "\System32\Spool\Drivers\W32X86\"
        If (bWinNT351) Then
            iniFilename = iniFilename + "1\__pdf.ini"
        Else
            iniFilename = iniFilename + "2\__pdf.ini"
        End If
    Else
        SystemRoot$ = GetPrivateProfileSetting(BaseKey:=HKEY_LOCAL_MACHINE, _
                    Section:="Software\Microsoft\Windows\CurrentVersion", _
                    Setting:="SystemRoot")
        iniFilename = SystemRoot$ + "\System\PDFWritr.ini"
    End If
           
    ' Make sure PDFWriter is installed
    If EnsurePDFWriterIsInstalled(PDFWriterName, Port) = True Then
        Status = GetPrivateProfileSetting(iniFilename, _
                    0, _
                    "Acrobat PDFWriter", _
                    IniPromptSetting)
        If Status = "" Then Status = "Prompt"
           
        ' Build a full pathname to the output file
        Set theDoc = Application.ActiveSheet()
        outputFilename = theDoc.Parent.FullName    ' Workbook owns the FullName
           
        ' Delete the extension (if any). Find the last period in the filename
        dotPos = InStr(1, outputFilename, ".")
        prevDotPos = dotPos
        While dotPos > 1
            dotPos = InStr(dotPos + 1, outputFilename, ".")
            If dotPos > 1 Then prevDotPos = dotPos
        Wend
        If prevDotPos > 1 Then      ' there's an extension
            outputFilename = Left(outputFilename, prevDotPos) + "PDF"
        Else                        ' no extension
            outputFilename = outputFilename + ".PDF"
        End If
           
        ' Make sure we have a folder path. If not, use wdTempFilePath
        slashPos = InStr(1, outputFilename, "\")
        If (slashPos = 0) Then
            outputFilename$ = Application.DefaultFilePath + "\" + _
                            outputFilename
        End If
       
        ' Tell PDFWriter to whether use this filename or prompt the user
        If Status = "Prompt" Then
            SetPrivateProfileSetting iniFilename, 0, _
                "Acrobat PDFWriter", "PDFFileName", ""
        Else
            SetPrivateProfileSetting iniFilename, 0, _
                "Acrobat PDFWriter", "PDFFileName", outputFilename
        End If
           
        Dim rangeVariant As Variant
           
        ' The different Office apps all have different ways of priting to
        ' a particular printer. Word lets you set the Application.ActivePrinter
        ' property. Excel's help file says you can do this, but you can't. But
        ' it allows you to specify the desired printer in the PrintOut method.
        ' PowerPoint doesn't do either of these, unfortunately.
           
        ' Set PDFWriter as the printer to use
        saveCurrentPrinter = Application.ActivePrinter
           
        On Error Resume Next
        ' Disallow background printing
        ' Don't append
        ' Page range
        theDoc.PrintOut ActivePrinter:=PDFWriterName
               
           
        SetPrivateProfileSetting iniFilename, 0, "Acrobat PDFWriter", "PDFFileName", ""
    End If
End Sub

Sub AddOurMenuItem()
    Dim fileMenu As CommandBar
    Dim filePrintItem As CommandBarControl
    Dim ourIndex
    Dim createPDFItem
   
    ' This function adds the menu item 'Create Adobe PDF...' to the File menu
   
    ' Add our CommandBarControl
    Set fileMenu = CommandBars(IDS_FILE_MENU_NAME)
   
    '
    ' The Temporary:=True setting in Add doesn't seem to work; the menu
    ' item appears automatically the next time we run Word.
    ' So we need to determine if that menu item is already there.
    ' The FindControl method returns Nothing if the menu item isn't found,
    ' but there's no way to test for Nothing (the documented IsNothing method
    ' doesn't actually seem to exist). So we're forced to iterate through
    ' the File menu and use a boolean to determine if CreateAdobePDF is
    ' there already.
    '
    Dim fileMenuItem
    Dim found
    found = False
    For Each fileMenuItem In fileMenu.Controls
        If fileMenuItem.Tag = "CreateAdobePDF" Then
            found = True
            Exit For
        End If
    Next
   
    If Not found Then
        ' Add the item to the File menu
        Set filePrintItem = fileMenu.FindControl(Type:=msoControlButton, Id:=4, _
            Recursive:=True)
        ourIndex = filePrintItem.Index + 1
        Set createPDFItem = fileMenu.Controls.Add(Type:=msoControlButton, _
            Before:=ourIndex, Temporary:=True)
        createPDFItem.Caption = IDS_FILE_MENU_ITEM
        createPDFItem.OnAction = "PrintPDFFile"
        createPDFItem.Tag = "CreateAdobePDF"
    End If
       
End Sub
Sub AddOurToolbar()
    Dim Status As String
    Dim toolbarPrintButton As CommandBarButton
    Dim toolbarToggleButton As CommandBarButton
    Dim ourToolbar As CommandBar
   
    ' NOTE: This function must only be run by the macro developer at design time. It should be
    ' deleted from the shipping .xla file so that user's cannot run it.
    ' Before running it, you must:
    '   1. Exit Excel 97.
    '   2. Remove PDFWriter.xla from the XLStart directory.
    '   3. Run Excel 97 and load PDFWriter.xls
    '   4. Click Tools/Customize, select the PDF toolbar, and Delete it.
   
    ' Add the toolbar
    On Error Resume Next
   
    Set ourToolbar = CommandBars.Add(Name:=IDS_TOOLBAR_NAME, Position:=msoBarFloating)
    ourToolbar.Visible = True
    Set toolbarPrintButton = ourToolbar.Controls.Add(Type:=msoControlButton, Id:=1, Temporary:=False)
    Set toolbarToggleButton = ourToolbar.Controls.Add(Type:=msoControlButton, Id:=1, Temporary:=False)
   
    toolbarPrintButton.Move     ' Move to the end of the toolbar
    toolbarToggleButton.Move
   
    With toolbarPrintButton
        .Style = msoButtonIcon
        .OnAction = "PrintPDFFile"
        .TooltipText = IDS_TOOLTIP1_TEXT
        .DescriptionText = IDS_STATUSBAR1_TEXT
        .Caption = IDS_TOOLBAR_PRINT_BUTTON_CAPTION
        .BeginGroup = True
       
        ' You need CopyIcon.dll and PDFTB.bmp, both in the Windows directory,
        ' or in the directory where Word and Excel are located, for this to
        ' work
        Call CopyIconToClipboard
        .PasteFace
    End With
   
    Status = GetPrivateProfileSetting(iniFilename, _
                0, _
                "Acrobat PDFWriter", _
                IniPromptSetting)
    If Status = "" Then Status = "Prompt"
    SetPrivateProfileSetting iniFilename, 0, _
            "Acrobat PDFWriter", "PDFFileName", ""
   
    With toolbarToggleButton
        .Style = msoButtonCaption
        .OnAction = "TogglePDFToolbar"
        .TooltipText = IDS_TOOLTIP2_TEXT
        .DescriptionText = IDS_STATUSBAR2_TEXT
        .Caption = IDS_PDFWRITER_PROMPT
        .Tag = "TogglePDF"
    End With
   
    TogglePDFToolbar        ' Toggle twice to ensure the toolbar reflects
    TogglePDFToolbar        ' the ini file setting

End Sub
Sub Main()
    On Error Resume Next

    DetermineOSVersion
    DetermineWhichApp
    bDistMonOk = InitializeDistMon
   
    ' Delete the old toolbar
    If (CommandBars("PDF").Name = "PDF") Then
        CommandBars("PDF").Delete
    End If

    ' Figure out where the system files are
    If (bWinNT) Then
        SystemRoot$ = GetPrivateProfileSetting(BaseKey:=HKEY_LOCAL_MACHINE, _
                    Section:="Software\Microsoft\Windows NT\CurrentVersion", _
                    Setting:="SystemRoot")
        iniFilename = SystemRoot$ + "\System32\Spool\Drivers\W32X86\"
        If (bWinNT351) Then
            iniFilename = iniFilename + "1\__pdf.ini"
        Else
            iniFilename = iniFilename + "2\__pdf.ini"
        End If
    Else
        SystemRoot$ = GetPrivateProfileSetting(BaseKey:=HKEY_LOCAL_MACHINE, _
                    Section:="Software\Microsoft\Windows\CurrentVersion", _
                    Setting:="SystemRoot")
        iniFilename = SystemRoot$ + "\System\PDFWritr.ini"
    End If
   
    ' The module containing this macro is called AutoExec. If the .dot file
    ' containing this module is placed in the Office Startup folder, the Main
    ' function of this module will be executed when an Office app is launched.
   
    IniPromptSetting = "CreatePDFExcelMacroShowDialog"

'    TogglePDFToolbar        ' Toggle twice to ensure the toolbar reflects
'    TogglePDFToolbar        ' the ini file setting

End Sub

Sub Auto_Open()
    Main
End Sub

Sub DetermineOSVersion()
    Dim versionNum As Long
    Dim temp As Long
   
    bWin95 = False
    bWinNT = False
    bWinNT351 = False
    bWinNT40 = False
    nOSMajorVersion = 0
    nOSMinorVersion = 0
   
    versionNum = GetVersion()
    If ((versionNum And &H80000000) = 0) Then
        bWinNT = True
    End If
    bWin95 = Not bWinNT
   
    nOSMajorVersion = versionNum And &HFF
    temp = (versionNum - (versionNum And &HFFFF0000)) / 256
    nOSMinorVersion = temp
   
    If (bWinNT) Then
        If (nOSMajorVersion = 4) Then bWinNT40 = True
        If (nOSMajorVersion = 3) Then bWinNT351 = True
    End If
   
    AddOurMenuItem
End Sub

'--- end of code ---
0
 
LVL 1

Expert Comment

by:swdld
ID: 6451527
'--- begin of code ---
'Filename: AutoExit.bas
Attribute VB_Name = "AutoExit"
Sub Main()
    On Error Resume Next
   
    '' Don't need to call ShutdownDistMon explicitly, because
    '' the DLL has already gotten a call to DLLMain with
    '' DLL_PROCESS_DETACH, has done the shutdown, and has, in fact,
    '' been unloaded from memory
'''    ShutdownDistMon
End Sub
'--- end of code ---
0
 
LVL 1

Expert Comment

by:swdld
ID: 6451529
'--- begin of code ---
'Filename: DistMon.bas
Attribute VB_Name = "DistMon"
Option Explicit

Declare Function DistMonInitialize Lib "DistMon" () As Long
Declare Sub DistMonCleanup Lib "DistMon" ()

Function InitializeDistMon()
    Dim retVal As Long
   
    InitializeDistMon = False
    On Error GoTo InitializeDistMonError
   
    retVal = DistMonInitialize()
    If (retVal = 1) Then InitializeDistMon = True
   
InitializeDistMonError:
End Function
Sub ShutdownDistMon()
    On Error Resume Next
    DistMonCleanup
End Sub
'--- end of code ---
0
 
LVL 1

Expert Comment

by:swdld
ID: 6451531
'--- begin of code ---
'Filename: IniFiles.bas
Attribute VB_Name = "IniFiles"
Option Explicit

Declare Function GetPrivateProfileString Lib "kernel32.dll" _
    Alias "GetPrivateProfileStringA" (ByVal lpSection As String, _
    ByVal lpSetting As String, _
    ByVal lpDefault As String, _
    ByVal lpReturnedString As String, _
    ByVal nSize As Long, _
    ByVal lpFileName As String) As Long
   
Declare Function SetPrivateProfileString Lib "kernel32.dll" _
    Alias "WritePrivateProfileStringA" (ByVal lpSection As String, _
    ByVal lpSetting As String, _
    ByVal lpValue As String, _
    ByVal lpFileName As String) As Long


Public Function GetIniSetting(ByRef iniFilename As String, _
        ByRef Section As String, _
        ByRef Setting As String) As String
   
    Dim Count As Long
    Dim ReturnedString As String
    ReturnedString = String(256, 0)
   
    Count = GetPrivateProfileString(Section, Setting, "", _
        ReturnedString, 255, iniFilename)
    GetIniSetting = Left$(ReturnedString, Count)
End Function

           
Public Sub SetIniSetting(ByRef iniFilename As String, _
        ByRef Section As String, _
        ByRef Setting As String, _
        ByRef Value As String)
       
    SetPrivateProfileString Section, Setting, Value, iniFilename
End Sub
'--- end of code ---
0
 
LVL 1

Expert Comment

by:swdld
ID: 6451534
'--- begin of code ---
'Filename: RegistrationDatabase.bas
Attribute VB_Name = "RegistrationDatabase"
Option Explicit
 
Global Const REG_SZ As Long = 1
Global Const REG_DWORD As Long = 4
 
Global Const HKEY_CLASSES_ROOT = &H80000000
Global Const HKEY_CURRENT_USER = &H80000001
Global Const HKEY_LOCAL_MACHINE = &H80000002
Global Const HKEY_USERS = &H80000003
 
Global Const ERROR_NONE = 0
Global Const ERROR_BADDB = 1
Global Const ERROR_BADKEY = 2
Global Const ERROR_CANTOPEN = 3
Global Const ERROR_CANTREAD = 4
Global Const ERROR_CANTWRITE = 5
Global Const ERROR_OUTOFMEMORY = 6
Global Const ERROR_INVALID_PARAMETER = 7
Global Const ERROR_ACCESS_DENIED = 8
Global Const ERROR_INVALID_PARAMETERS = 87
Global Const ERROR_NO_MORE_ITEMS = 259
 
Global Const KEY_QUERY_VALUE = &H1
Global Const KEY_ALL_ACCESS = &H3F
 
Global Const REG_OPTION_NON_VOLATILE = 0

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

Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias _
    "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, _
    ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions _
    As Long, ByVal samDesired As Long, ByVal lpSecurityAttributes _
    As Long, phkResult As Long, lpdwDisposition As Long) As Long

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

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

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

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

Declare Function RegSetValueExString Lib "advapi32.dll" Alias _
    "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
    ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As _
    String, ByVal cbData As Long) As Long

Declare Function RegSetValueExLong Lib "advapi32.dll" Alias _
    "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
    ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, _
    ByVal cbData As Long) As Long


Public Function SetValueEx(ByVal hKey As Long, sValueName As String, _
lType As Long, vValue As Variant) As Long
    Dim lValue As Long
    Dim sValue As String
    Select Case lType
        Case REG_SZ
            sValue = vValue
            SetValueEx = RegSetValueExString(hKey, sValueName, 0&, _
lType, sValue, Len(sValue))
        Case REG_DWORD
            lValue = vValue
            SetValueEx = RegSetValueExLong(hKey, sValueName, 0&, _
lType, lValue, 4)
        End Select
End Function
 
Function QueryValueEx(ByVal lhKey As Long, ByVal szValueName As _
String, vValue As Variant) As Long
    Dim cch As Long
    Dim lrc As Long
    Dim lType As Long
    Dim lValue As Long
    Dim sValue As String
 
    On Error GoTo QueryValueExError
 
    ' Determine the size and type of data to be read
    lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)
    If lrc <> ERROR_NONE Then Error 5
 
    Select Case lType
        ' For strings
        Case REG_SZ:
            sValue = String(cch, 0)
            lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, _
                    sValue, cch)
            If lrc = ERROR_NONE Then
                vValue = Left$(sValue, cch - 1)
            Else
                vValue = Empty
            End If
        ' For DWORDS
        Case REG_DWORD:
            lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, _
                    lValue, cch)
            If lrc = ERROR_NONE Then vValue = lValue
        Case Else
            'all other data types not supported
            lrc = -1
    End Select
 
QueryValueExExit:
    QueryValueEx = lrc
    Exit Function
QueryValueExError:
    Resume QueryValueExExit
End Function

Public Function QueryValue(ByVal hKey As Long, sKeyName As String, sValueName As String) As String
    Dim lRetVal As Long         'result of the API functions
    Dim vValue As Variant      'setting of queried value
    Dim hOpenKey As Long
 
    lRetVal = RegOpenKeyEx(hKey, sKeyName, 0, KEY_QUERY_VALUE, hOpenKey)
    lRetVal = QueryValueEx(hOpenKey, sValueName, vValue)
    RegCloseKey (hOpenKey)
    QueryValue = vValue
End Function

Public Sub SetKeyValue(ByVal hKey As Long, sKeyName As String, _
                sValueName As String, vValueSetting As Variant, lValueType As Long)
    Dim lRetVal As Long         'result of the SetValueEx function
    Dim hOpenKey As Long         'handle of open key
 
    'open the specified key
    lRetVal = RegOpenKeyEx(hKey, sKeyName, 0, KEY_ALL_ACCESS, hOpenKey)
    lRetVal = SetValueEx(hOpenKey, sValueName, lValueType, vValueSetting)
    RegCloseKey (hOpenKey)
End Sub
'--- end of code ---
0
 
LVL 1

Expert Comment

by:swdld
ID: 6451538
'--- begin of code ---
'Filename: Strings.bas
Attribute VB_Name = "Strings"
Option Explicit

' This module contains strings that will need to be internationalized
' The dialogs will also have to be internationalized

' Application name for title bar of dialogs
Public Const IDS_APP_NAME As String = "Adobe PDF erstellen"

' MsgBox alerts
Public Const IDS_NO_PDFWRITER As String = "PDFWriter ist nicht installiert."
Public Const IDS_CANT_FIND_DISTMON As String = "Das PDFWriter-Monitorprogramm fur Adobe PDF erstellen wurde" + vbCrLf + "nicht gefunden. Bitte installieren Sie Adobe PDF erstellen neu."

' PDFWriter strings
Public Const IDS_PDFWRITER_PROMPT As String = "Eingabeaufforderung"
Public Const IDS_PDFWRITER_NO_PROMPT As String = "Autom"

' Menu strings
Public Const IDS_FILE_MENU_ITEM As String = "Adobe PDF erstellen..."

' NOTE: We have determined that there is no need to translate the name FILE. It is
' common to all languages.
Public Const IDS_FILE_MENU_NAME As String = "File"

' Toolbar strings
Public Const IDS_TOOLBAR_PRINT_BUTTON_CAPTION As String = "PDF"
Public Const IDS_TOOLTIP1_TEXT As String = "Druckt diese Datei zu PDF"
Public Const IDS_STATUSBAR1_TEXT As String = "Druckt diese Datei zu PDF"

Public Const IDS_TOOLTIP2_TEXT As String = "Aktiviert/Deaktiviert Eingabeaufforderungen fur PDF-Dateinamen"
Public Const IDS_STATUSBAR2_TEXT As String = "Aktiviert/Deaktiviert Eingabeaufforderungen fur PDF-Dateinamen"

Public Const IDS_TOOLBAR_NAME As String = "PDF 4.0"
'--- end of code ---
0
 
LVL 1

Expert Comment

by:swdld
ID: 6451546
If U have questions, don't hesitate to mail me at
swdld@gmx.net

c.u.,
swdld
0

Featured Post

Find Ransomware Secrets With All-Source Analysis

Ransomware has become a major concern for organizations; its prevalence has grown due to past successes achieved by threat actors. While each ransomware variant is different, we’ve seen some common tactics and trends used among the authors of the malware.

Join & Write a Comment

The debugging module of the VB 6 IDE can be accessed by way of the Debug menu item. That menu item can normally be found in the IDE's main menu line as shown in this picture.   There is also a companion Debug Toolbar that looks like the followin…
When trying to find the cause of a problem in VBA or VB6 it's often valuable to know what procedures were executed prior to the error. You can use the Call Stack for that but it is often inadequate because it may show procedures you aren't intereste…
As developers, we are not limited to the functions provided by the VBA language. In addition, we can call the functions that are part of the Windows operating system. These functions are part of the Windows API (Application Programming Interface). U…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

746 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

10 Experts available now in Live!

Get 1:1 Help Now