Solved

MS Access VBA Font Text Wrap After So Many Characters

Posted on 2016-11-02
25
32 Views
Last Modified: 2016-11-03
I have this code that I use to print labels from MS Access to a Dymo Printer. But the Font is way to tiny to read.  I need the text to wrap after 40 Characters including spaces to a second line. Same text box just different line. This invloves DymoLabels.SetField "title", ProductTitle in the code below.

Thanks.

Function PrintLabel()
    '****************************************************************************
    'This function prints the current record in the table
    'using the currently selected label
    '****************************************************************************
    Dim FileStr As String
    Dim Str As String, Pipe As String, Desc As String
    Dim hKey As Long, cb As Long, path As String
    Dim intK
    Dim q
    ProductTitle = Forms!frmSkusEntry!SkuNm                   'define Title of seminar
    Codebar = Forms!frmSkusEntry!sbfrmProducts.Form!Text10
    Pipe = Chr(13) + Chr(10) 'line delimiter
    FileStr = Forms![frmSkusEntry]!FileName.Caption
    
    'Read label files path from the Registry
    'RegOpenKeyEx HKEY_CURRENT_USER, "Software\DYMO\LabelWriter\Directories", 0, KEY_ALL_ACCESS, hKey
    'RegQueryValueExNULL hKey, "Label Directory", 0&, REG_SZ, 0&, cb
    'path = String(cb, 0)
    'RegQueryValueExString hKey, "Label Directory", 0&, REG_SZ, path, cb
    'path = Left(path, cb - 1) + "\"
    path = GetDymoLabelFilePath
    
    On Error Resume Next
    Call GetDesc(Desc)                            'gets description of current label
    Call GetObject(Obj)                           'defines object to paste text to
    Call CreateOLEObjects                          'create Dymo OLE objects
        'opens the template in DLS using the correct label type
    DymoAddIn.Open path + FileStr 'open label in DLS
    
DymoAddIn.UseFullFontHeight = True
       
        'change the Title on the label
        DymoLabels.SetField "title", ProductTitle 'send to the property names of your label template to DLS (Title is a textbox on the label template in DLS)
        DymoLabels.SetField "Code128", Codebar
            
   For intK = 1 To Forms!frmSkusEntry!PrintLabelQTY
        q = DymoAddIn.Print(1, True)               'print the label
   Next intK

        Call DestroyOLEObjects ' destroy objects

End Function

Open in new window

0
Comment
Question by:Dustin Stanley
  • 14
  • 7
  • 3
  • +1
25 Comments
 
LVL 34

Expert Comment

by:PatHartman
Comment Utility
Since the number of characters that will fit in a text box varies with the font and point size, you will probably have better success if you go with a non-proportional font such as Courier so you can size the box to fit exactly 40 characters.   With a non-proportional font, all characters are exactly the same width so the I is the same width as the M and the space. Then you don't need any code.  Access will wrap the text as long as the control and the section that contains it are both set to can shrink/can grow.
0
 

Author Comment

by:Dustin Stanley
Comment Utility
Sorry Pat I tried it and it don't work.  I tried it on the Dymo side for the template. DymoLabels.SetField "title", ProductTitle is sent off to the Dymo Software where it is then printed by API. So I need it coded before it hits the line 33.  I added the update correct code below. The first one above I had the loop lines in it when I didn't need it and a line I was testing. So I have to have it coded to wrap before line 33 where it is sent off to Dymo.

Function PrintLabel()
    '****************************************************************************
    'This function prints the current record in the table
    'using the currently selected label
    '****************************************************************************
    Dim FileStr As String
    Dim Str As String, Pipe As String, Desc As String
    Dim hKey As Long, cb As Long, path As String
    Dim intK
    Dim q
    ProductTitle = Forms!frmSkusEntry!SkuNm                   'define Title of seminar
    Codebar = Forms!frmSkusEntry!sbfrmProducts.Form!Text10
    Pipe = Chr(13) + Chr(10) 'line delimiter
    FileStr = Forms![frmSkusEntry]!FileName.Caption
    
    'Read label files path from the Registry
    'RegOpenKeyEx HKEY_CURRENT_USER, "Software\DYMO\LabelWriter\Directories", 0, KEY_ALL_ACCESS, hKey
    'RegQueryValueExNULL hKey, "Label Directory", 0&, REG_SZ, 0&, cb
    'path = String(cb, 0)
    'RegQueryValueExString hKey, "Label Directory", 0&, REG_SZ, path, cb
    'path = Left(path, cb - 1) + "\"
    path = GetDymoLabelFilePath
    
    On Error Resume Next
    Call GetDesc(Desc)                            'gets description of current label
    Call GetObject(Obj)                           'defines object to paste text to
    Call CreateOLEObjects                          'create Dymo OLE objects
        'opens the template in DLS using the correct label type
    DymoAddIn.Open path + FileStr 'open label in DLS

       
        'change the Title on the label
        DymoLabels.SetField "title", ProductTitle 'send to the property names of your label template to DLS (Title is a textbox on the label template in DLS)
        DymoLabels.SetField "Code128", Codebar
            
   q = DymoAddIn.Print(Forms!frmSkusEntry!PrintLabelQTY, True)
        Call DestroyOLEObjects ' destroy objects

End Function

Open in new window

0
 

Author Comment

by:Dustin Stanley
Comment Utility
I think the code to wrap the text may involve the (PIPE line delimiter) above.
0
 
LVL 30

Expert Comment

by:hnasr
Comment Utility
Is there a maximum number of characters?

How many lines of 40 characters?

You may divide the string by adding a new line Chr(10) character.
0
 

Author Comment

by:Dustin Stanley
Comment Utility
Is there a maximum number of characters?

Generally 80 but no more then lets say 120

How many lines of 40 characters?
Nomore then 3


You may divide the string by adding a new line Chr(10) character.

Would you have a example to share?


Thank you for the help
0
 

Author Comment

by:Dustin Stanley
Comment Utility
This will be used for product titles on labels. One line makes it to small to read.

Example: Big Yellow Bus 32" Long Toy Fun For Boys and Girls All Ages Real Working Lights
0
 
LVL 30

Assisted Solution

by:hnasr
hnasr earned 250 total points
Comment Utility
Try:
In query where adesc is a field in table a.
SELECT Mid(adesc,1,40) & IIf(Len(Mid(adesc,41,40))=0,"", Chr(13)) & Mid(adesc,41,40) & IIf(Len(Mid(adesc,81,40))=0,"",Chr(13)) & Mid(adesc,81,40) AS Fld
FROM a;

Open in new window

In code where adesc is a string. Try it in immediate window.
xxx = Mid(adesc,1,40) & IIf(Len(Mid(adesc,41,40))=0,"", Chr(13)) & Mid(adesc,41,40) & IIf(Len(Mid(adesc,81,40))=0,"",Chr(13)) & Mid(adesc,81,40)

Open in new window


Example: Big Yellow Bus 32" Long Toy Fun For Boys and Girls All Ages Real Working Lights
Result of Example:
Fld
"Big Yellow Bus 32"" Long Toy Fun For Boys
 and Girls All Ages Real Working Lights"
0
 

Author Comment

by:Dustin Stanley
Comment Utility
Ok this is a little new to me so please bare.  

In query where adesc is a field in table a.

You mean make a query.  If so Forms!frmSkusEntry!SkuNm comes from the table Skus my SQL would look like this:
SELECT Mid(SKUNm,1,40) & IIf(Len(Mid(SKUNm,41,40))=0,"", Chr(13)) & Mid(SKUNm,41,40) & IIf(Len(Mid(SKUNm,81,40))=0,"",Chr(13)) & Mid(SKUNm,81,40) AS Fld
FROM SKUs;

Open in new window


In code where adesc is a string. Try it in immediate window.
I have never used this but I see it and pasted the code into it. Dimmed SkuNm as string. But what is XXX and how do I run or use this?
xxx = Mid(SkuNm, 1, 40) & IIf(Len(Mid(SkuNm, 41, 40)) = 0, "", Chr(13)) & Mid(SkuNm, 41, 40) & IIf(Len(Mid(SkuNm, 81, 40)) = 0, "", Chr(13)) & Mid(SkuNm, 81, 40)

Open in new window

0
 
LVL 30

Expert Comment

by:hnasr
Comment Utility
For query: Yes Where
table is: SKUs
field is:SKUNm

The xxx this is to be used to check in immediate window.
xxx is a variable.
adesc = "1234567890 1234567890 1234567890 1234567890 1234567890 1234567890 1234567890"
xxx = Mid(adesc,1,40) & IIf(Len(Mid(adesc,41,40))=0,"", Chr(13)) & Mid(adesc,41,40) & IIf(Len(Mid(adesc,81,40))=0,"",Chr(13)) & Mid(adesc,81,40)
?xxx
Click on first line and press enter
then another enter on xxx line
then enter on ?xxx
You see this result:
1234567890 1234567890 1234567890 1234567
890 1234567890 1234567890 1234567890

Open in new window

0
 

Author Comment

by:Dustin Stanley
Comment Utility
Ok so the window just returns TRUE
I put in the window
?xxx = Mid(SkuNm, 1, 40) & IIf(Len(Mid(SkuNm, 41, 40)) = 0, "", Chr(13)) & Mid(SkuNm, 41, 40) & IIf(Len(Mid(SkuNm, 81, 40)) = 0, "", Chr(13)) & Mid(SkuNm, 81, 40)

Open in new window

0
 
LVL 30

Expert Comment

by:hnasr
Comment Utility
?xxx = Mid(SkuNm, 1, 40) & IIf(Len(Mid(SkuNm, 41, 40)) = 0, "", Chr(13)) & Mid(SkuNm, 41, 40) & IIf(Len(Mid(SkuNm, 81, 40)) = 0, "", Chr(13)) & Mid(SkuNm, 81, 40)

In immediate window,
If you put ? 1=1
the result is True, because you ask to print the result of 1=1 which is true.

The code in the immediate window is like this. Three lines
'first line to assign the value of string: SkuNm and press enter
SkuNm = "1234567890 1234567890 1234567890 1234567890 1234567890 1234567890 1234567890"

'Second line is to assign the split string to a variable xxx and press enter
xxx = Mid(SkuNm, 1, 40) & IIf(Len(Mid(SkuNm, 41, 40)) = 0, "", Chr(13)) & Mid(SkuNm, 41, 40) & IIf(Len(Mid(SkuNm, 81, 40)) = 0, "", Chr(13)) & Mid(SkuNm, 81, 40)
'Third line is to print the value of xxx and press enter
? xxx

The first enter assigns a value to SkuNum. You do not see any result displayed

The second enter assigns the split string to variable xxx. You do not see any result displayed.

The third enter you ask to print the value of xxx. You see the following result:
1234567890 1234567890 1234567890 1234567
890 1234567890 1234567890 1234567890

Note: The splitting is done by concatenating 3 pieces using mid function each of 40 characters.
It adds Chr(13) before second part or third part if it has a value, meaning more than 40 characters, and more than 80 characters.
0
 

Author Comment

by:Dustin Stanley
Comment Utility
I thank you very much for this and explaining it clearly. In the immediate window it is giving me results from my subform correctly as which one I am currently on. Immediate Window:

SkuNm = Forms!frmSkusEntry!SkuNm
xxx = Mid(SkuNm, 1, 40) & IIf(Len(Mid(SkuNm, 41, 40)) = 0, "", Chr(13)) & Mid(SkuNm, 41, 40) & IIf(Len(Mid(SkuNm, 81, 40)) = 0, "", Chr(13)) & Mid(SkuNm, 81, 40)
?XXX
HONEYWELL T87F 1859 T87F1859 HEATING COO
LING THERMOSTAT ROUND DIAL 24-30V

Open in new window



But how can I use this in my code:
Function PrintLabel()
    '****************************************************************************
    'This function prints the current record in the table
    'using the currently selected label
    '****************************************************************************
    Dim FileStr As String
    Dim Str As String, Pipe As String, Desc As String
    Dim hKey As Long, cb As Long, path As String
    Dim intK
    Dim q
    ProductTitle = Forms!frmSkusEntry!SkuNm                   'define Title of seminar
    Codebar = Forms!frmSkusEntry!sbfrmProducts.Form!Text10
    Pipe = Chr(13) + Chr(10) 'line delimiter
    FileStr = Forms![frmSkusEntry]!FileName.Caption
    
    'Read label files path from the Registry
    'RegOpenKeyEx HKEY_CURRENT_USER, "Software\DYMO\LabelWriter\Directories", 0, KEY_ALL_ACCESS, hKey
    'RegQueryValueExNULL hKey, "Label Directory", 0&, REG_SZ, 0&, cb
    'path = String(cb, 0)
    'RegQueryValueExString hKey, "Label Directory", 0&, REG_SZ, path, cb
    'path = Left(path, cb - 1) + "\"
    path = GetDymoLabelFilePath
    
    On Error Resume Next
    Call GetDesc(Desc)                            'gets description of current label
    Call GetObject(Obj)                           'defines object to paste text to
    Call CreateOLEObjects                          'create Dymo OLE objects
        'opens the template in DLS using the correct label type
    DymoAddIn.Open path + FileStr 'open label in DLS

       
        'change the Title on the label
        DymoLabels.SetField "title", ProductTitle 'send to the property names of your label template to DLS (Title is a textbox on the label template in DLS)
        DymoLabels.SetField "Code128", Codebar
            
   q = DymoAddIn.Print(Forms!frmSkusEntry!PrintLabelQTY, True)
        Call DestroyOLEObjects ' destroy objects

End Function

Open in new window



Where:
ProductTitle = Forms!frmSkusEntry!SkuNm

Open in new window

0
How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

 
LVL 30

Expert Comment

by:hnasr
Comment Utility
Not sure where to do that.

The code may need a little modification if it contains quotation marks.

Upload a sample database with objects relevant to this issue.

I am not aware of the printing device you refer to.
If you can replace the code to use a standard printer, this will be of help.
0
 

Author Comment

by:Dustin Stanley
Comment Utility
0
 

Author Comment

by:Dustin Stanley
Comment Utility
I can't replace the Dymo Code because that is their API Code found in the Dymo SDK. I use a Dymo 450Turbo and a 4XL.
0
 
LVL 30

Expert Comment

by:hnasr
Comment Utility
Try this, to take care of " in string.

    ProductTitle = Forms!frmSkusEntry!SkuNm                   'define Title of seminar
    ProductTitle = Replace(ProductTitle, """", "@")
    ProductTitle = Mid(ProductTitle, 1, 40) & IIf(Len(Mid(ProductTitle, 41, 40)) = 0, "", Chr(13)) & Mid(ProductTitle, 41, 40) & IIf(Len(Mid(ProductTitle, 81, 40)) = 0, "", Chr(13)) & Mid(ProductTitle, 81, 40)
    ProductTitle = Replace(ProductTitle, "@", """")
    Codebar = Forms!frmSkusEntry!sbfrmProducts.Form!Text10

Open in new window

0
 

Author Comment

by:Dustin Stanley
Comment Utility
Ok. Thanks. I am out of my office until morning. I will get back with you.
0
 
LVL 57

Accepted Solution

by:
Jim Dettman (Microsoft MVP/ EE MVE) earned 250 total points
Comment Utility
I'm not sure I would have broken it up in the SQL.

Rather what you can do is use a function like the one below to reformat the string that will be passed.   You would call it like this:

 DymoLabels.SetField "title", FillNotes(Forms!frmSkusEntry!SkuNm, 40)

The advantage to this is that it will do any number of lines, and you can changed the "width" of the formatting easily.   Note as well that the procedure honors embedded new lines that might be in the string.

And Pat pointed out, a mono spaced font is best.

Jim.

Public Function FillNotes(strNotes As String, intFormatTo As Integer) As String

          ' Formats and fills a string at a specified width.
          ' Routine honors vbCRLF embedded in strNotes.

          Const RoutineName = "FillNotes"
          Const Version = "2.0"

          Dim strLineText As String
          Dim intPosition As Integer

10        On Error GoTo FillNotes_Error

          ' Make sure we clean up the string for EDI
20        strNotes = FSForEDI(strNotes, Len(strNotes))
30        strNotes = dhTrimAll(strNotes, True)

40        FillNotes = ""

          ' Loop for all the lines
50        Do While InStr(strNotes, vbCrLf) > 0
              ' Get line
60            strLineText = left$(strNotes, InStr(strNotes, vbCrLf) - 1)
              ' Remove from notes
70            strNotes = Mid$(strNotes, InStr(strNotes, vbCrLf) + 2)

              ' Format line text into intFormatTo column lines
80            Do While strLineText & "" <> ""
90                intPosition = intFormatTo
100               If Len(strLineText) > intPosition Then
110                   Do Until Mid$(strLineText, intPosition, 1) = " " Or intPosition = 1
120                       intPosition = intPosition - 1
130                   Loop
140               End If

150               FillNotes = FillNotes & FS(strLineText, intPosition) & vbCrLf

160               If Len(strLineText) > intPosition Then
170                   strLineText = Mid$(strLineText, intPosition + 1)
180               Else
190                   strLineText = ""
200               End If
210           Loop
220       Loop

          ' Process last line
230       strLineText = strNotes

          ' Format line text into intFormatTo column lines
240       Do While strLineText & "" <> ""
250           intPosition = intFormatTo
260           If Len(strLineText) > intPosition Then
270               Do Until Mid$(strLineText, intPosition, 1) = " " Or intPosition = 1
280                   intPosition = intPosition - 1
290               Loop
300           End If

310           FillNotes = FillNotes & FS(strPrefix, intPrefixLength) & FSForEDI(strLineText, intPosition) & vbCrLf

320           If Len(strLineText) > intPosition Then
330               strLineText = Mid$(strLineText, intPosition + 1)
340           Else
350               strLineText = ""
360           End If
370       Loop

FillNotes_Exit:
380       On Error Resume Next

390       Exit Function

FillNotes_Error:
400       UnexpectedError ModuleName, RoutineName, Version, Err.Number, Err.Description, Err.Source, VBA.Erl
410       Resume FillNotes_Exit

End Function

Open in new window



Function FS(strInput, intLength As Integer) As String

          ' "FS" - Fixed string
          ' Returns a given string of a specific length
          Const RoutineName = "FS"
          Const Version = "1.0"

10        On Error GoTo FS_Error

20        FS = left$(strInput & Space(intLength), intLength)

FS_Exit:
30        On Error Resume Next
40        Exit Function

FS_Error:
50        UnexpectedError ModuleName, RoutineName, Version, Err.Number, Err.Description, Err.Source, VBA.Erl
60        Resume FS_Exit

End Function

Open in new window

0
 
LVL 57

Assisted Solution

by:Jim Dettman (Microsoft MVP/ EE MVE)
Jim Dettman (Microsoft MVP/ EE MVE) earned 250 total points
Comment Utility
BTW, you can take out lines 20 and 30.  They just cleanup the passed string.   The first was for EDI, which doesn't allow the sending of specific characters.

The second removes all white space (multiple spaces and tabs), and trims off leading and trailing spaces.   I can't post that routine however because it is copyrighted.

Jim.
0
 

Author Comment

by:Dustin Stanley
Comment Utility
Jim:
Rather what you can do is use a function like the one below to reformat the string that will be passed.   You would call it like this:

 DymoLabels.SetField "title", FillNotes(Forms!frmSkusEntry!SkuNm, 40)

Where would I place the FillNotes Function? In a Module of its own??

Also where would the FS function be placed?


and I would replace my
DymoLabels.SetField "title", ProductTitle

with your  
DymoLabels.SetField "title", FillNotes(Forms!frmSkusEntry!SkuNm, 40)

Correct?


Also what would intPrefixLength, FSForEDI, and strLineText be dimmed as in line 310?
0
 
LVL 57

Assisted Solution

by:Jim Dettman (Microsoft MVP/ EE MVE)
Jim Dettman (Microsoft MVP/ EE MVE) earned 250 total points
Comment Utility
<<Where would I place the FillNotes Function? In a Module of its own??

Also where would the FS function be placed?>>

  Yes.   I have one called "ocsStringRoutines" where they both live.

<<Correct?>>

 Yes.

<<Also what would intPrefixLength, FSForEDI, and strLineText be dimmed as in line 310?>>

  Sorry, I missed that.  Line 310 should be:

310 FillNotes = FillNotes & FS(strLineText, intPosition) & vbCrLf

I had a couple extra parameters on this routine originally.  The routine was used to format instructions on a pick slip that was being transmitted via EDI.

 Because of that, each line written needed a prefix of a set length added (that's what the inPrefixLength was about).

As for FSForEDI(), EDI doesn't like certain characters, so they need to be stripped out.  FSForEDI() is just like FS(), except for pulling those characters out.  

 I missed editing line 310 when I posted.

 Sorry for the confusion.

Jim.
0
 
LVL 30

Expert Comment

by:hnasr
Comment Utility
Dustin:
Did you try my comment, https:#a41871450 ?
Any feedback?
0
 

Author Comment

by:Dustin Stanley
Comment Utility
THANK YOU JIM! PERFECT!!!!

For future visitors this is what happened.

I have a subform called sbfrmProducts and I wanted to print text from a text box called Text10 to a Dymo Label template and the location Text10 was going to was called Code128 (This was a barcode in 128 format on the dymo  label)

I was also wanting to print the text from my mainform (frmSkusEntry) Control text box called SkuNm. SkuNm was going to the Dymo Label template and the location was called Title on the label.


The print was to so small it couldn't be read because it was printing on a single line.  I chose in the Dymo Template Consolas Font and set it at font size 10 Bold.

I have the Dymo Label in a Folder just under the Database application.

Here is the codes complete:

Module DymoLabelPrinter:

Option Compare Database
Option Explicit

'*********************************************************************************
'DLS is Abbreviation for Dymo Label Software. Just plain old Label Wrighter Software.
'High-Level OLE Demo program for Microsoft Access 97
'February 7, 1997
'Modified: October 24, 1997
'Written by: Andrew Shalhoub
'Modified: April 23, 1999
'Modified by: Sergey Smirnov
'
'Copyright 1997,2002 DYMO Corporation, Stamford CT
'
'This sample database and the code contained herein were designed to demonstrate
'a real world example of communicating with Dymo Label Software using High-Level
'OLE interface from MS Access.
'
'The sample is a simple database that could be used to track seminar attendees
'and print Address or Shipping labels or Name Badges for each record contained
'in the database.
'
'
'Permission to use, copy, modify, and distribute this software for any purpose
'and without fee is hereby granted.
'**********************************************************************************


'Windows API functions and constants to work with the Registry
Private Const REG_SZ As Long = 1
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const HKEY_CURRENT_USER = &H80000001
Private Const KEY_ALL_ACCESS = &H3F
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias _
        "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, _
        ByVal ulOptions As Long, ByVal samDesired As Long, phkResult _
        As Long) As Long
Private Declare Function 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
Private 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

Global Channum As Long, App As String, Obj As String
Global FileStr As String, ProductTitle As String, Codebar As String
'OLE objects to communicate with DLS
Global DymoAddIn As Object, DymoLabels As Object
Global Loaded As Boolean

Function ChangeLabel()
    '****************************************************************************
    'This function updates the Filename caption on the form "frmSkusEntry"
    'when the Label Type is changed
    '****************************************************************************
    Dim dbs As Database, rst As Recordset
    Dim FileStr As String, Label As String
    Set dbs = CurrentDb                               'set the database
    Set rst = dbs.OpenRecordset("LabelTypes")         'open table
        'set Value to current Filename
    Forms![frmSkusEntry]!FileName.Caption = Forms![frmSkusEntry]!LabelType.Value
    Label = Forms![frmSkusEntry]!LabelType.Value              'set Labels to Filename
    rst.MoveFirst
    Do
        If rst![Description] = Label Then             'if match
            FileStr = rst![FileName]                  'then set FileStr to Filename
        End If
        rst.MoveNext                                  'if not then goto next record
    Loop Until rst.EOF                                'search to end of table
    Forms![frmSkusEntry]!FileName.Caption = FileStr           'reset caption on form "frmSkusEntry"
End Function


Function Defaults()
    '****************************************************************************
    'This function sets the Filename caption on form "frmSkusEntry" to current Label Type
    'and sets the variable Loaded to True (assumes DLS is already running)
    '****************************************************************************
    Dim dbs As Database, rst As Recordset
    Dim FileStr As String, Label As String
    Set dbs = CurrentDb                             'set database
    Set rst = dbs.OpenRecordset("LabelTypes")       'open the table
        'set Value to current Filename
    Forms![frmSkusEntry]!FileName.Caption = Forms![frmSkusEntry]!LabelType.Value
    Label = Forms![frmSkusEntry]!LabelType.Value            'set Label to Filename
    rst.MoveFirst
    FileStr = rst![FileName]                        'set FileStr to Filename
    Forms![frmSkusEntry]!FileName.Caption = FileStr         'update Filename caption on form
    Loaded = True
End Function


Function GetDesc(Desc)
    '****************************************************************************
    'This function returns the current Label Description by searching
    'the values in the table "LabelTypes"
    '****************************************************************************
    Dim dbs As Database, rst As Recordset
    Dim FileStr As String, Label As String
    Set dbs = CurrentDb                             'set the database
    Set rst = dbs.OpenRecordset("LabelTypes")       'open table
    Label = Forms![frmSkusEntry]!FileName.Caption           'set Label to filename on form
    rst.MoveFirst
    Do
        If rst![FileName] = Label Then              'if match
            Desc = rst![Description]                'then return description
        End If
        rst.MoveNext                                'if not then goto next record
    Loop Until rst.EOF                              'search to end of table
End Function

Function GetObject(Obj)
    '****************************************************************************
    'This function searches the table "LabelTypes" for a match
    'of the current Filename, then returns the name of the object on
    'that label which is the target for the selected text
    '****************************************************************************
    Dim dbs As Database, rst As Recordset
    Dim Label As String
    Set dbs = CurrentDb                         'set the database
    Set rst = dbs.OpenRecordset("LabelTypes")   'open table
    Label = Forms![frmSkusEntry]!FileName.Caption       'set Label to filename on form
    rst.MoveFirst
    Do
        If rst![FileName] = Label Then          'if match
            Obj = rst![PasteObject]             'then return object name
        End If
        rst.MoveNext                            'if not then goto next record
    Loop Until rst.EOF                          'search to end of table
End Function


Function PrintLabel()
    '****************************************************************************
    'This function prints the current record in the table
    'using the currently selected label
    '****************************************************************************
    Dim FileStr As String
    Dim Str As String, Pipe As String, Desc As String
    Dim hKey As Long, cb As Long, path As String
    Dim intK
    Dim q
    Codebar = Forms!frmSkusEntry!sbfrmProducts.Form!Text10
    Pipe = Chr(13) + Chr(10) 'line delimiter
    FileStr = Forms![frmSkusEntry]!FileName.Caption
    
    'Read label files path from the Registry
    'RegOpenKeyEx HKEY_CURRENT_USER, "Software\DYMO\LabelWriter\Directories", 0, KEY_ALL_ACCESS, hKey
    'RegQueryValueExNULL hKey, "Label Directory", 0&, REG_SZ, 0&, cb
    'path = String(cb, 0)
    'RegQueryValueExString hKey, "Label Directory", 0&, REG_SZ, path, cb
    'path = Left(path, cb - 1) + "\"
    path = GetDymoLabelFilePath
    
    On Error Resume Next
    Call GetDesc(Desc)                            'gets description of current label
    Call GetObject(Obj)                           'defines object to paste text to
    Call CreateOLEObjects                          'create Dymo OLE objects
        'opens the template in DLS using the correct label type
    DymoAddIn.Open path + FileStr 'open label in DLS

       
        'change the Title on the label
        DymoLabels.SetField "title", FillNotes(Forms!frmSkusEntry!SkuNm, 40) 'send to the property names of your label template to DLS (Title is a textbox on the label template in DLS)
        DymoLabels.SetField "Code128", Codebar
            
   q = DymoAddIn.Print(Forms!frmSkusEntry!PrintLabelQTY, True)
        Call DestroyOLEObjects ' destroy objects

End Function
Function CreateOLEObjects()
    '****************************************************************************
    'This fuction creates Dymo OLE objects
    '****************************************************************************
    On Error Resume Next
    
    Set DymoAddIn = CreateObject("Dymo.DymoAddIn")
    Set DymoLabels = CreateObject("Dymo.DymoLabels")
    'check if successful
    If (DymoAddIn Is Nothing) Or (DymoLabels Is Nothing) Then
        MsgBox "Unable to create OLE objects"
    End If
End Function


Function DestroyOLEObjects()
    '*********************************s*******************************************
    'This function destroys OLE object
    '****************************************************************************
    On Error Resume Next
    Set DymoAddIn = Nothing
    Set DymoLabels = Nothing
End Function

Public Function GetDBPath() As String 'Use if your database is NOT split. SEE FUNCTION GetDymoLabelFilePath 4 info
    GetDBPath = CurrentProject.path & "\"
End Function

Public Function GetDBPathSplitDB() As String 'Use if you have a Split Database. SEE FUNCTION GetDymoLabelFilePath 4 info
    GetDBPathSplitDB = Replace(CurrentDb.TableDefs("LabelTypes").Connect, ";DATABASE=", "")
'This code below is removing db name
GetDBPathSplitDB = Left(GetDBPathSplitDB, InStrRev(GetDBPathSplitDB, "\"))

End Function


Public Function GetDymoLabelFilePath() As String 'Choose which one to use below.
'Choose One Not Both. Remove the ' in the front of GetDBFilePath or GetDBPathSplitDB but make sure one of them has a ' and the other does not.

    GetDymoLabelFilePath = GetDBPath & "Dymo Labels\" 'Use if your database is NOT split.
    'GetDymoLabelFilePath = GetDBPathSplitDB & "Dymo Labels\"  ''Use if you have a Split Database.
    
End Function

Open in new window


Module DymoLabelPrinterStringSeperator:

Option Compare Database
Option Explicit

Public Function FillNotes(strNotes As String, intFormatTo As Integer) As String

          ' Formats and fills a string at a specified width.
          ' Routine honors vbCRLF embedded in strNotes.

          Const RoutineName = "FillNotes"
          Const Version = "2.0"

          Dim strLineText As String
          Dim intPosition As Integer

        On Error GoTo FillNotes_Error

          ' Make sure we clean up the string for EDI

        FillNotes = ""

          ' Loop for all the lines
        Do While InStr(strNotes, vbCrLf) > 0
              ' Get line
            strLineText = Left$(strNotes, InStr(strNotes, vbCrLf) - 1)
              ' Remove from notes
            strNotes = Mid$(strNotes, InStr(strNotes, vbCrLf) + 2)

              ' Format line text into intFormatTo column lines
            Do While strLineText & "" <> ""
                intPosition = intFormatTo
               If Len(strLineText) > intPosition Then
                   Do Until Mid$(strLineText, intPosition, 1) = " " Or intPosition = 1
                       intPosition = intPosition - 1
                   Loop
               End If

               FillNotes = FillNotes & FS(strLineText, intPosition) & vbCrLf

               If Len(strLineText) > intPosition Then
                   strLineText = Mid$(strLineText, intPosition + 1)
               Else
                   strLineText = ""
               End If
           Loop
       Loop

          ' Process last line
       strLineText = strNotes

          ' Format line text into intFormatTo column lines
       Do While strLineText & "" <> ""
           intPosition = intFormatTo
           If Len(strLineText) > intPosition Then
               Do Until Mid$(strLineText, intPosition, 1) = " " Or intPosition = 1
                   intPosition = intPosition - 1
               Loop
           End If

           FillNotes = FillNotes & FS(strLineText, intPosition) & vbCrLf


           If Len(strLineText) > intPosition Then
               strLineText = Mid$(strLineText, intPosition + 1)
           Else
               strLineText = ""
           End If
       Loop

FillNotes_Exit:
       On Error Resume Next

       Exit Function

FillNotes_Error:
MsgBox "Error FillNotes"
       'UnexpectedError ModuleName, RoutineName, Version, Err.Number, Err.Description, Err.Source, VBA.Erl
       Resume FillNotes_Exit

End Function

Function FS(strInput, intLength As Integer) As String

          ' "FS" - Fixed string
          ' Returns a given string of a specific length
          Const RoutineName = "FS"
          Const Version = "1.0"

        On Error GoTo FS_Error

        FS = Left$(strInput & Space(intLength), intLength)

FS_Exit:
        On Error Resume Next
        Exit Function

FS_Error:
MsgBox "Error Function FS"
        'UnexpectedError ModuleName, RoutineName, Version, Err.Number, Err.Description, Err.Source, VBA.Erl
        Resume FS_Exit

End Function

Open in new window



Found on the Main form was a button call Print Label and in the Events of OnClick I placed:

=PrintLabel()

Open in new window


I hope this helps people out.
0
 

Author Comment

by:Dustin Stanley
Comment Utility
Did you try my comment, https:#a41871450 ?

I just tried it but it is cutting the title all apart. I am only getting the middle of the title.

I thank you for your help.
0
 

Author Closing Comment

by:Dustin Stanley
Comment Utility
Thank you!
0

Featured Post

How to improve team productivity

Quip adds documents, spreadsheets, and tasklists to your Slack experience
- Elevate ideas to Quip docs
- Share Quip docs in Slack
- Get notified of changes to your docs
- Available on iOS/Android/Desktop/Web
- Online/Offline

Join & Write a Comment

Most if not all databases provide tools to filter data; even simple mail-merge programs might offer basic filtering capabilities. This is so important that, although Access has many built-in features to help the user in this task, developers often n…
Overview: This article:       (a) explains one principle method to cross-reference invoice items in Quickbooks®       (b) explores the reasons one might need to cross-reference invoice items       (c) provides a sample process for creating a M…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…
In Microsoft Access, learn different ways of passing a string value within a string argument. Also learn what a “Type Mis-match” error is about.

763 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

11 Experts available now in Live!

Get 1:1 Help Now