Userform print pdf with file name and path

S

sureshtrb

Board Regular
Joined
Mar 24, 2013
Messages
106
I am not an expert in vba and with the forum guide created userform and works well.
I want to save the userform in pdf with textbox file name which i am trying for the past 2 days and unsuccessful.
advice requested.
my code
Code: 
Dim OldPrinter As String, NewPrinter As String    OldPrinter = Left$(Application.ActivePrinter, InStrRev(Application.ActivePrinter, "on ") - 2)
    Application.Dialogs(xlDialogPrinterSetup).Show
    NewPrinter = Left$(Application.ActivePrinter, InStrRev(Application.ActivePrinter, "on ") - 2)


    
    Dim sFilename As String
    Dim cname, tagNumber, customer, newHour, newMinute, newSecond, waitTime
    Dim fpath As String
    
    With rvcform
            newHour = Hour(Now())
            newMinute = Minute(Now())
            newSecond = Second(Now()) + 2
            waitTime = TimeSerial(newHour, newMinute, newSecond)
            Application.Wait waitTime
            cname = NO.Value
            tagNumber = TAGN.Value
            customer = CUSTO.Value
            sFilename = customer & "-RVC-" & cname & "-" & tagNumber & ".pdf"
            fpath = "C:\Users\VSD\Desktop\RVC_Printed_Copies\"
     
            Application.ScreenUpdating = True
            SendKeys fpath & sFilename & "{ENTER}", False
            MsgBox fpath & sFilename
            .PrintForm
        End With

Everytime when print, it prompts for "Microsoft Visual Basic" as file name instead of the given file name.
Help please!
 
Sort by date Sort by votes

Excel Facts

Why does 9 mean SUM in SUBTOTAL?
It is because Sum is the 9th alphabetically in Average, Count, CountA, Max, Min, Product, StDev.S, StDev.P, Sum, VAR.S, VAR.P.
try this code
Code: 
Private Sub CommandButton3_Click()
Dim OldPrinter As String ', oDO As New MSForms.DataObject
[COLOR=#ff0000]  Dim oDO As Object
  Set oDO = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    oDO.SetText Me.TextBox1.Text 
    oDO.PutInClipboard
    Set oDO = Nothing[/COLOR]
  Dim NewPrinter As String
  OldPrinter = Left(Application.ActivePrinter, InStrRev(Application.ActivePrinter, "su ") - 2)
  If Application.Dialogs(xlDialogPrinterSetup).Show Then
    NewPrinter = Left(Application.ActivePrinter, InStrRev(Application.ActivePrinter, "su ") - 2)
    'n.b.:  a seconda della versione di Windows
    '    potrebbe essere necessario sostituire "su " con "on "
    ChangePrinter NewPrinter

    Me.PrintForm
    ChangePrinter OldPrinter
  End If
End Sub
you can replace the proposed file name with Ctrl + v
 
Upvote 0
ok its a multi-step process requiring mapping to a template the below will show you the desktop path. the best bet is to record a macro to find your template
Code: 
Private Sub CommandButton2_Click()
 Application.SendKeys "(%{1068})"
 DoEvents
' the above mimicks alt print screen
 

Workbooks.Open Filename:="C:\Users\Desktop\FInancaltemp.xlsx"
' above the file I am opening name it what you need to
    Windows("document1.xlsm").Activate
    Windows("FInancaltemp.xlsx").Activate
    Range("A1").Select
    ActiveSheet.Paste



    Application.Width = 909.75
    Application.Height = 687
    Selection.ShapeRange.ScaleWidth 0.59, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleHeight 0.8599171337, msoFalse, msoScaleFromTopLeft
'above will be the resizing to fit the PDF


    Application.CutCopyMode = False
    ChDir "C:\Users\Desktop"
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        "C:\Users\E57509\Desktop\FInancal.pdf", Quality:=xlQualityStandard, _
        IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:= _
        False

' above saves the Temp file as a pdf 


   Application.DisplayAlerts = False
ActiveWorkbook.Close SaveChanges:=False
    
Above closes the excel template 


End Sub
 
Last edited by a moderator:
Upvote 0
Thanks for the effort and reply.
The printsceen will not be helpful for me as the userform is in scroll view(exceed the screen size).
I have found an alternate way and will post the same soon.
Regards
 
Upvote 0
trishgyrl said:
Thanks! I know it's been awhile since this post.
Click to expand...

Here the code used. Retrieved from my form. Edited and sent only related to the print form. I am not sure if I have wrongly deleted any print related codes.
Please check.
code in the userform:


Code: 
Option Explicit
Private Const HWND_BROADCAST As Long = &HFFFF&
Private Const WM_WININICHANGE As Long = &H1A


[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
Private Declare PtrSafe Function SendNotifyMessage Lib "user32" Alias "SendNotifyMessageA" ( _
ByVal hwnd As LongPtr, _
ByVal Msg As Long, _
ByVal wParam As Long, _
lParam As Any) As LongPtr


Private Declare PtrSafe Function SetDefaultPrinter Lib "winspool.drv" Alias "SetDefaultPrinterA" ( _
ByVal pszPrinter As String) As LongPtr


[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
Private Declare Function SetDefaultPrinter Lib "winspool.drv" Alias "SetDefaultPrinterA" ( _
ByVal pszPrinter As String) As Long


'Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, _
     ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
 ' Private Declare Function WinAPISetFocus Lib "user32" _
                  Alias "SetFocus" (ByVal hwnd As Long) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
                  
Private Sub UserForm_Activate()
With Me
        'This will create a vertical scrollbar
        .ScrollBars = fmScrollBarsVertical
       
     'AutoScroll = True
    'Change the values of 2 as Per your requirements
        .ScrollHeight = .InsideHeight * 1.4
        .ScrollWidth = .InsideWidth * 1
        End With
End Sub


Private Sub userform_initialize()


Me.Repaint
End Sub


Public Sub ChangePrinter(NewPrinter As String)


SetDefaultPrinter NewPrinter


'broadcast the change
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
Call SendNotifyMessage(HWND_BROADCAST, _
WM_WININICHANGE, _
0, ByVal "windows")
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
End Sub
Private Sub CommandButton1_Click()




'Call AutoSize
    Dim Msg As String
    Dim ireply As Integer


        ireply = MsgBox("Print Report in PDF", vbQuestion + vbOKCancel)
        Select Case ireply
            Case vbOK
                GoTo line123456
            Case vbCancel
            rvcform.cmdUpdate = True
            Unload Me
                  Exit Sub
          End Select
          
line123456:
    
    Dim OldPrinter As String
    Dim NewPrinter As String
   OldPrinter = Left$(Application.ActivePrinter, InStrRev(Application.ActivePrinter, "on ") - 2)
Application.Dialogs(xlDialogPrinterSetup).Show
NewPrinter = Left$(Application.ActivePrinter, InStrRev(Application.ActivePrinter, "on ") - 2)


ChangePrinter NewPrinter
UserForm9.CommandButton1.Visible = False


 With Me
'Hide ScrollBars during print
 .ScrollBars = False
 End With


Me.PrintForm


ChangePrinter OldPrinter


  Unload UserForm9
  Unload rvcform
Exit Sub


End Sub

Code used in Class1:
Code: 
Option Explicit
Public WithEvents odist As PdfDistiller
Public blnFinished As Boolean
Private Sub Class_Initialize()
    Set odist = New PdfDistiller
End Sub
Private Sub odist_OnJobDone(ByVal strInputPostScript As String, ByVal strOutputPDF As String)
    blnFinished = True
    Kill strInputPostScript
End Sub
Private Sub odist_OnJobFail(ByVal strInputPostScript As String, ByVal strOutputPDF As String)
    blnFinished = True
End Sub
Private Sub odist_OnJobStart(ByVal strInputPostScript As String, ByVal strOutputPDF As String)
    blnFinished = False
End Sub


Sub PrintPDF()
     'From the worksheet goto File>Print .. select the Distiller
     'Goto  Properties & uncheck the tickbox under
     'Adobe PDF Settings entitled "Do Not Send Fonts to Distiller
     '
     '#############################################################
     '#The Code uses the following external reference libraries:  #
     '#Microsoft Office 10.0 Object Library (9.0 also works)      #
     '#Acrobat Distiller                                          #
     '#Go to Tools > References in the VB Editor and check them   #
     '#############################################################
     
    Dim appDist As cAcroDist 'see class module
    Dim stActivePrinter As String
    Dim stOutputDir As String
    Dim stInputPS As String
    Dim stOutputPDF As String
    Dim stJobOptions As String
     
    Dim stFileName As String
     
     'On Error GoTo ExitDueError
     
    Set appDist = New cAcroDist
    stActivePrinter = Application.ActivePrinter
     
     'Application.ActivePrinter = "Adobe PDF on Ne03:"
    Application.Dialogs(xlDialogPrinterSetup).Show
     
    Application.ScreenUpdating = False
     'We don't want to see the distiller window
    appDist.odist.bShowWindow = False
     
     'We are using Start/Done events. If we spool, they don't fire
    appDist.odist.bSpoolJobs = False
     
    With Worksheets("Data")
        stFileName = "MyPrintout"
         
        stOutputDir = "C:\Users\VSD\Desktop\RVC_Printed_Copies\"
         
        stInputPS = stOutputDir & stFileName & ".ps"
        stOutputPDF = stOutputDir & stFileName & ".pdf"
         'Excel can print to a PostScript file and name it, but it can't print to a PDF file and name it.
         
        .Visible = True
        .Activate
        .PrintOut PrToFileName:=stInputPS, PrintToFile:=True 'create PS file
        .Visible = False
    End With
     
     'This uses our distiller class mod to make the PDF file
     'Upon successful completion, it deletes the PostScript file
    Call appDist.odist.FileToPDF(stInputPS, stOutputPDF, stJobOptions)
     ' convert PS to PDF (above)
     'Distiller is  SLOW. We have to sit here until the JobDone Event fires and  changes blnFinished to true
     
    Do While Not appDist.blnFinished
        DoEvents
    Loop
     
    MsgBox stFileName & " Printed" & vbLf & vbLf & "Print To PDF Successful!", vbInformation, "Notice"
     
ExitDueError:
    Application.ActivePrinter = stActivePrinter
    Set appDist = Nothing
    Application.ScreenUpdating = True
End Sub
code used in Class2:
Code: 
 'Create a Class module named cAcroDist with the following
Option Explicit
Public WithEvents odist As PdfDistiller
 
Private Sub Class_Initialize()
    Set odist = New PdfDistiller
End Sub
code used in Module:

Code: 
Option Explicit
Option Base 1
 
Private Type POINTAPI
    x As Long
    y As Long
End Type
 
Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As String * 1
    lfUnderline As String * 1
    lfStrikeOut As String * 1
    lfCharSet As String * 1
    lfOutPrecision As String * 1
    lfClipPrecision As String * 1
    lfQuality As String * 1
    lfPitchAndFamily As String * 1
    lfFaceName As String * 32
End Type
 
Private oLabel As Object
Private sText As String
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
Private Declare PtrSafe Function FindWindow Lib "user32" _
Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
Private Declare PtrSafe Function GetDC Lib "user32" _
(ByVal hwnd As Long) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
Private Declare Function GetDC Lib "user32" _
(ByVal hwnd As Long) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
Private Declare PtrSafe Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, _
ByVal hdc As Long) As Long
 [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
 Private Declare Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, _
ByVal hdc As Long) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
Private Declare PtrSafe Function TextOut Lib "gdi32" _
Alias "TextOutA" _
(ByVal hdc As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal lpString As String, _
ByVal nCount As Long) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
Private Declare Function TextOut Lib "gdi32" _
Alias "TextOutA" _
(ByVal hdc As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal lpString As String, _
ByVal nCount As Long) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
Private Declare PtrSafe Function SetBkMode Lib "gdi32" _
(ByVal hdc As Long, _
ByVal nBkMode As Long) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
Private Declare Function SetBkMode Lib "gdi32" _
(ByVal hdc As Long, _
ByVal nBkMode As Long) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
Private Declare PtrSafe Function SetWindowLong Lib "user32" _
Alias "SetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
Private Declare Function SetWindowLong Lib "user32" _
Alias "SetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
Private Declare PtrSafe Function CallWindowProc Lib "user32" _
Alias "CallWindowProcA" _
(ByVal lpPrevWndFunc As Long, _
ByVal hwnd As Long _
, ByVal Msg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
Private Declare Function CallWindowProc Lib "user32" _
Alias "CallWindowProcA" _
(ByVal lpPrevWndFunc As Long, _
ByVal hwnd As Long _
, ByVal Msg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
 
Private Const GWL_WNDPROC = (-4)
Private Const WM_MOVE = &H3
Private Const WM_ACTIVATEAPP = &H1C
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
Private Declare PtrSafe Function MoveWindow Lib "user32" _
(ByVal hwnd As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal bRepaint As Long) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
Private Declare Function MoveWindow Lib "user32" _
(ByVal hwnd As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal bRepaint As Long) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
Private Declare PtrSafe Function CreateFontIndirect Lib "gdi32" _
Alias "CreateFontIndirectA" _
(lpLogFont As LOGFONT) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
Private Declare Function CreateFontIndirect Lib "gdi32" _
Alias "CreateFontIndirectA" _
(lpLogFont As LOGFONT) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
Private Declare PtrSafe Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hObject As Long) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hObject As Long) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
Private Declare PtrSafe Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
Private Declare PtrSafe Function GetTextExtentPoint32 Lib "gdi32" _
Alias "GetTextExtentPoint32A" _
(ByVal hdc As Long, _
ByVal lpsz As String, _
ByVal cbString As Long, _
lpSize As POINTAPI) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
Private Declare Function GetTextExtentPoint32 Lib "gdi32" _
Alias "GetTextExtentPoint32A" _
(ByVal hdc As Long, _
ByVal lpsz As String, _
ByVal cbString As Long, _
lpSize As POINTAPI) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If


Private lOldFont As Long
Private lHwnd As Long
Private lPrevWnd As Long
 
Private Function CallBack _
(ByVal hwnd As Long, ByVal Msg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
 
    Dim textSize As POINTAPI
    Dim tPt1 As POINTAPI
    Dim sCurString As String
    Dim sString As String
    Dim sCurChar As String * 1
    Dim lDC As Long
    Dim lLeft As Long
    Dim lTop  As Long
    Dim lRight  As Long
    Dim lBottom  As Long
    Dim i As Long
    Dim sglCurTextWidth As Single
 
 
    sString = sText
    Select Case Msg
        Case WM_MOVE, WM_ACTIVATEAPP
            lDC = GetDC(hwnd)
            SetBkMode lDC, 1
            For i = 1 To Len(sString)
                sCurChar = Mid(sString, i, 1)
                If sCurChar <> "_" And sCurChar <> "^" Then
                    With oLabel
                        lTop = .Top * 1.3333
                        lLeft = .Left * 1.3333
                        lRight = (.Left + .Width) * 1.333
                        lBottom = (.Top + .Height) * 1.333
                    End With
                    tPt1.x = lLeft
                    GetTextExtentPoint32 lDC, sCurString, _
                    Len(sCurString), textSize
                    sglCurTextWidth = textSize.x
                    Call SetFont(lDC, SmallFont:=True)
                    On Error Resume Next
                    WorksheetFunction.Match i, _
                    AssignSuperSubScriptCharPosToArray(sString), 0
                    If Err = 0 Then
                        On Error GoTo 0
                        TextOut lDC, lLeft + sglCurTextWidth, _
                        lBottom, sCurChar, Len(sCurChar)
                        GoTo nxt
                    End If
                    On Error Resume Next
                    WorksheetFunction.Match i, _
                    AssignSuperSubScriptCharPosToArray(sString, True), 0
                    If Err = 0 Then
                        On Error GoTo 0
                        TextOut lDC, lLeft + sglCurTextWidth, _
                        lTop, sCurChar, Len(sCurChar)
                        GoTo nxt
                    End If
                    Call SetFont(lDC)
                    TextOut lDC, lLeft + sglCurTextWidth, _
                    lTop, sCurChar, Len(sCurChar)
nxt:
                    SelectObject lDC, lOldFont
                    sCurString = (sCurString & sCurChar)
                End If
            Next
            ReleaseDC hwnd, lDC
            Exit Function
    End Select
    CallBack = CallWindowProc _
    (lPrevWnd, hwnd, Msg, wParam, ByVal lParam)
 
End Function
 
Private Sub SetFont(DC As Long, Optional SmallFont As Boolean)
    Dim uFont As LOGFONT
    Dim lFHwnd As Long
 
    With uFont
        .lfFaceName = "Arial" & Chr$(0)
        If SmallFont Then
            .lfHeight = 8 ' change these font params as required
            .lfWidth = 7 '
            lFHwnd = CreateFontIndirect(uFont)
            lOldFont = SelectObject(DC, lFHwnd)
        Else
            .lfHeight = 14 ' change these font params as required
            .lfWidth = 8 '
        End If
    End With
    lFHwnd = CreateFontIndirect(uFont)
    lOldFont = SelectObject(DC, lFHwnd)
    DeleteObject lFHwnd
 
End Sub
 
Sub SubSuperScript(text As String, label As Object)
 
    Call SuClassForm(text, label)
 
End Sub
 
Private Sub SuClassForm(text As String, label As Object)
 
    Dim i As Long
    Dim dOldtimer As Double
 
    dOldtimer = Timer
    Set oLabel = label
    oLabel.AutoSize = True
    sText = text
    lHwnd = FindWindow(vbNullString, label.Parent.Caption)
    lPrevWnd = SetWindowLong(lHwnd, GWL_WNDPROC, AddressOf CallBack)
    Do
        i = i + 1
        DoEvents
    Loop Until Timer - dOldtimer > 0.0001
    With label.Parent
        .Move .Left + 1, .Top, .Width, .Height
        .Move .Left - 1, .Top, .Width, .Height
    End With
 
End Sub
 
Private Function AssignSuperSubScriptCharPosToArray _
(text As String, Optional Superscript As Boolean) _
As Long()
 
    Dim ar1() As Long
    Dim ar2() As Long
    Dim loops
    Dim n As Long
    Dim i As Long
    Dim j As Long
    Dim k As Long
 
    On Error Resume Next
 
    If Superscript Then
        n = 1
        For i = 1 To Len(text)
            If Mid(text, i, 1) = "^" Then
                ReDim Preserve ar1(n)
                ar1(n) = i
                n = n + 1
            End If
        Next
    Else
        n = 1
        For i = 1 To Len(text)
            If Mid(text, i, 1) = "_" Then
                ReDim Preserve ar1(n)
                ar1(n) = i
                n = n + 1
            End If
        Next
    End If
    For i = 1 To UBound(ar1) Step 2
        loops = (ar1(i + 1) - ar1(i)) - 1
        For j = 1 To loops
            k = k + 1
            ReDim Preserve ar2(k)
            ar2(k) = ar1(i) + j
        Next j
    Next i
 
    AssignSuperSubScriptCharPosToArray = (ar2)
 
End Function
 
Sub RemoveSubclass()
 
    SetWindowLong lHwnd, GWL_WNDPROC, lPrevWnd
 
End Sub
My apology in anyway I have given an inappropriate info.
Please check and let me know.
 
Upvote 0
You must log in or register to reply here.

Similar threads

H
  • Question
Macro: Convert pdf into Excel and extract certain data to put together with file name
Replies
1
Views
2K
HeinrichPaul
H
M
  • Solved
VBA | Save Excel Sheets as PDF and keep Excel File Name and Path
Replies
4
Views
846
Trebor76
T
S
  • Question
Save e-mail message as ".pdf" file in specified file path...
Replies
3
Views
650
sspatriots
S
D
  • Question
Export to PDF macro fails on Excel Office 365, not on Pro Plus 2019
Replies
9
Views
3K
ddewilt
D
D
  • Question
Excel Macro to print pdf file to location based on cell value and file name based on cell value
Replies
1
Views
2K
daverunt
D

Forum statistics

Threads
1,215,106
Messages
6,123,120
Members
449,096
Latest member
provoking

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top